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 : : private :: pawxc_gxc_moments ! Accumulate the moments of the GGA term gxc over the angular points
70 : : private :: pawxc_gxc_divergence ! Subtract the divergence of the GGA term gxc from Vxc at an angular point
71 : :
72 : : !Wrappers
73 : : private :: pawxc_drivexc_wrapper ! wrapper for drivexc
74 : : private :: pawxc_mkdenpos_wrapper ! wrapper for mkdenpos
75 : : private :: pawxc_xcmult_wrapper ! wrapper for xcmult
76 : : private :: pawxc_size_dvxc_wrapper ! wrapper for size_dvxc
77 : : private :: pawxc_xcpositron_wrapper ! wrapper for xcpositron
78 : :
79 : : !Zero of density
80 : : real(dp),parameter :: rho_min=tol14
81 : : !!***
82 : :
83 : : CONTAINS !===========================================================
84 : : !!***
85 : :
86 : : !!****f* m_pawxc/pawxc_xcpositron_wrapper
87 : : !! NAME
88 : : !! pawxc_xcpositron_wrapper
89 : : !!
90 : : !! FUNCTION
91 : : !! Compute electron-positron correlation potentials and energy density.
92 : : !! Used electron-positron correlation functional is controlled by ipawxc_xcpositron_wrapper argument.
93 : : !! Returns Fxc, Vxc_pos, Vxc_el from input rhor_pos and rhor_el for positron and electrons.
94 : : !!
95 : : !! INPUTS
96 : : !! grhoe2(ngr)=square of the gradient of electronic density rhoe (needed for GGA)
97 : : !! ixcpositron=type of electron-positron correlation functional:
98 : : !! 1 or -1: LDA zero positron density limit parametrized by Arponen & Pajanne
99 : : !! and provided by Boronski & Nieminen [1,2]
100 : : !! 11: LDA zero positron density limit parametrized by Arponen & Pajanne
101 : : !! and fitted by Sterne & Kaiser [1,3]
102 : : !! 2: LDA electron-positron correlation
103 : : !! provided by Puska, Seitsonen, and Nieminen [1,4]
104 : : !! 3: GGA zero positron density limit parametrized by Arponen & Pajanne
105 : : !! and provided by Boronski & Nieminen [1,2,5]
106 : : !! 31: GGA zero positron density limit parametrized by Arponen & Pajanne
107 : : !! and fitted by Sterne & Kaiser [1,3,5]
108 : : !! See references below
109 : : !! ngr=size of grho2 array (0 if LDA, npt if GGA)
110 : : !! npt=number of real space points on which density is provided
111 : : !! posdensity0_limit=True if we are in the zero positron density limit
112 : : !! rhoer(npt)=electron density (bohr^-3)
113 : : !! rhopr(npt)=positron density (bohr^-3)
114 : : !!
115 : : !! OUTPUT
116 : : !! fnxc(npt)=correlation energy per unit volume fxc
117 : : !! vxce(npt)=correlation potential for electron dfxc/drhoe (hartree)
118 : : !! vxcp(npt)=correlation potential for positron dfxc/drhop (hartree)
119 : : !! vxcegr(ngr)= 1/|gradRhoe| dfxc/d|gradRhoe| (empty if LDA, i.e. ngr=0)
120 : : !! Optional outputs:
121 : : !! dvxce(npt)=partial second derivatives of the xc energy wr to the electronic density
122 : : !! dvxce(:)=dVxce/dRhoe
123 : : !! dvxcp(npt)=partial second derivatives of the xc energy wr to the positronic density
124 : : !! dvxcp(:)=dVxcp/drhop
125 : : !!
126 : : !! NOTES
127 : : !! References for electron-positron correlation functionals:
128 : : !! [1] J. Arponen and E. Pajanne, Ann. Phys. (N.Y.) 121, 343 (1979) [[cite:Arponen1979a]].
129 : : !! [2] E. Boronski and R.M. Nieminen, Phys. Rev. B 34, 3820 (1986) [[cite:Boronski1986]].
130 : : !! [3] P.A. Sterne and J.H. Kaiser, Phys. Rev. B 43, 13892 (1991) [[cite:Sterne1991]].
131 : : !! [4] M.J. Puska, A.P. Seitsonen and R.M. Nieminen, Phys. Rev. B 52, 10947 (1994) [[cite:Puska1994]].
132 : : !! [5] B. Barbiellini, M.J. Puska, T. Torsti and R.M.Nieminen, Phys. Rev. B 51, 7341 (1995) [[cite:Barbiellini1995]]
133 : : !!
134 : : !! SOURCE
135 : :
136 : 58760 : subroutine pawxc_xcpositron_wrapper(fnxc,grhoe2,ixcpositron,ngr,npt,posdensity0_limit,&
137 : 58760 : & rhoer,rhopr,vxce,vxcegr,vxcp,&
138 : : & dvxce,dvxcp) ! optional arguments
139 : :
140 : : !Arguments ------------------------------------
141 : : !scalars
142 : : integer,intent(in) :: ixcpositron,ngr,npt
143 : : logical,intent(in) :: posdensity0_limit
144 : : !arrays
145 : : real(dp),intent(in) :: grhoe2(ngr),rhoer(npt),rhopr(npt)
146 : : real(dp),intent(out) :: fnxc(npt),vxce(npt),vxcegr(ngr),vxcp(npt)
147 : : real(dp),intent(out),optional :: dvxce(npt),dvxcp(npt)
148 : :
149 : : !Local variables-------------------------------
150 : :
151 : : ! *************************************************************************
152 : :
153 : : #if defined HAVE_LIBPAW_ABINIT
154 : 58760 : call pawxc_xcpositron_abinit()
155 : : #else
156 : : call pawxc_xcpositron_local()
157 : : #endif
158 : : !!***
159 : :
160 : : contains
161 : : !!***
162 : :
163 : : #if defined HAVE_LIBPAW_ABINIT
164 : : !!****f* pawxc_xcpositron_wrapper/pawxc_xcpositron_abinit
165 : : !! NAME
166 : : !! pawxc_xcpositron_abinit
167 : : !!
168 : : !! FUNCTION
169 : : !! ABINIT version of electron-positron correlation
170 : : !!
171 : : !! SOURCE
172 : :
173 : 58760 : subroutine pawxc_xcpositron_abinit()
174 : :
175 : : ! *************************************************************************
176 : :
177 [ - + ]: 58760 : if(present(dvxce) .and. present(dvxcp)) then
178 : : call xcpositron(fnxc,grhoe2,ixcpositron,ngr,npt,posdensity0_limit,rhoer,rhopr,vxce,vxcegr,vxcp,&
179 : 0 : & dvxce=dvxce,dvxcp=dvxcp) ! optional arguments
180 [ - + ]: 58760 : elseif( present(dvxce) .and. .not. present(dvxcp)) then
181 : : call xcpositron(fnxc,grhoe2,ixcpositron,ngr,npt,posdensity0_limit,rhoer,rhopr,vxce,vxcegr,vxcp,&
182 : 0 : & dvxce=dvxce) ! optional arguments
183 [ - + ]: 58760 : elseif( .not. present(dvxce) .and. present(dvxcp)) then
184 : : call xcpositron(fnxc,grhoe2,ixcpositron,ngr,npt,posdensity0_limit,rhoer,rhopr,vxce,vxcegr,vxcp,&
185 : 0 : & dvxcp=dvxcp) ! optional arguments
186 : : else
187 : 58760 : call xcpositron(fnxc,grhoe2,ixcpositron,ngr,npt,posdensity0_limit,rhoer,rhopr,vxce,vxcegr,vxcp)
188 : : end if
189 : :
190 : 58760 : end subroutine pawxc_xcpositron_abinit
191 : : !!***
192 : :
193 : : #else
194 : : !!****f* pawxc_xcpositron_wrapper/pawxc_xcpositron_local
195 : : !! NAME
196 : : !! pawxc_xcpositron_local
197 : : !!
198 : : !! FUNCTION
199 : : !! Local version of electron-positron correlation (to use outside ABINIT)
200 : : !! NOT AVAILABLE
201 : : !!
202 : : !! SOURCE
203 : :
204 : : subroutine pawxc_xcpositron_local()
205 : :
206 : : character(len=*), parameter :: msg='xcpositron only available in ABINIT!'
207 : :
208 : : ! *************************************************************************
209 : :
210 : : LIBPAW_BUG(msg)
211 : :
212 : : end subroutine pawxc_xcpositron_local
213 : : !!***
214 : : #endif
215 : :
216 : : end subroutine pawxc_xcpositron_wrapper
217 : : !!***
218 : :
219 : : !----------------------------------------------------------------------
220 : :
221 : : !!****f* m_pawxc/pawxc_size_dvxc_wrapper
222 : : !! NAME
223 : : !! pawxc_size_dvxc_wrapper
224 : : !!
225 : : !! FUNCTION
226 : : !! Give the sizes of the several arrays involved in exchange-correlation calculation
227 : : !! needed to allocated them for the drivexc routine
228 : : !!
229 : : !! INPUTS
230 : : !! ixc= choice of exchange-correlation scheme
231 : : !! order= gives the maximal derivative of Exc computed.
232 : : !! 1=usual value (return exc and vxc)
233 : : !! 2=also computes the kernel (return exc,vxc,kxc)
234 : : !! -2=like 2, except (to be described)
235 : : !! 3=also computes the derivative of the kernel (return exc,vxc,kxc,k3xc)
236 : : !! nspden= number of spin components
237 : : !! [xc_funcs(2)]= <type(libxc_functional_type)>
238 : : !! [add_tfw]= optional flag controling the addition of Weiszacker gradient correction to Thomas-Fermi XC energy
239 : : !!
240 : : !! OUTPUT
241 : : !! --- All optionals
242 : : !! [usegradient]= [flag] 1 if the XC functional needs the gradient of the density (grho2_updn)
243 : : !! [uselaplacian]= [flag] 1 if the XC functional needs the laplacian of the density (lrho_updn)
244 : : !! [usekden]= [flag] 1 if the XC functional needs the kinetic energy density (lrho_updn)
245 : : !! [nvxcgrho]= size of the array dvxcdgr(npts,nvxcgrho) (derivative of Exc wrt to gradient)
246 : : !! [nvxclrho]= size of the array dvxclpl(npts,nvxclrho) (derivative of Exc wrt to laplacian)
247 : : !! [nvxctau]= size of the array dvxctau(npts,nvxctau) (derivative of Exc wrt to kin. ener. density)
248 : : !! [ndvxc]= size of the array dvxc(npts,ndvxc) (second derivatives of Exc wrt to density and gradient)
249 : : !! [nd2vxc]= size of the array d2vxc(npts,nd2vxc) (third derivatives of Exc wrt density)
250 : : !!
251 : : !! SOURCE
252 : :
253 : 245577 : subroutine pawxc_size_dvxc_wrapper(ixc,order,nspden,&
254 : : & usegradient,uselaplacian,usekden,&
255 : : & nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc)
256 : :
257 : : !Arguments----------------------
258 : : integer,intent(in) :: ixc,nspden,order
259 : : integer,intent(out),optional :: nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc
260 : : integer,intent(out),optional :: usegradient,uselaplacian,usekden
261 : : !Local variables----------------
262 : : integer :: nvxcgrho_,nvxclrho_,nvxctau_,ndvxc_,nd2vxc_
263 : : integer :: usegradient_,uselaplacian_,usekden_
264 : :
265 : : ! *************************************************************************
266 : :
267 : : #if defined HAVE_LIBPAW_ABINIT
268 : : call size_dvxc(ixc,order,nspden,&
269 : : & usegradient=usegradient_,uselaplacian=uselaplacian_,usekden=usekden_,&
270 : : nvxcgrho=nvxcgrho_,nvxclrho=nvxclrho_,nvxctau=nvxctau_,&
271 : 245577 : & ndvxc=ndvxc_,nd2vxc=nd2vxc_)
272 : : #else
273 : : call pawxc_size_dvxc_local()
274 : : #endif
275 [ + - ]: 245577 : if (present(usegradient)) usegradient=usegradient_
276 [ + + ]: 245577 : if (present(uselaplacian)) uselaplacian=uselaplacian_
277 [ + + ]: 245577 : if (present(usekden)) usekden=usekden_
278 [ + - ]: 245577 : if (present(nvxcgrho)) nvxcgrho=nvxcgrho_
279 [ + + ]: 245577 : if (present(nvxclrho)) nvxclrho=nvxclrho_
280 [ + + ]: 245577 : if (present(nvxctau)) nvxctau=nvxctau_
281 [ + - ]: 245577 : if (present(ndvxc)) ndvxc=ndvxc_
282 [ + + ]: 245577 : if (present(nd2vxc)) nd2vxc=nd2vxc_
283 : : !!***
284 : :
285 : : #if ! defined HAVE_LIBPAW_ABINIT
286 : : contains
287 : : !!***
288 : :
289 : : !!****f* pawxc_size_dvxc_wrapper/pawxc_size_dvxc_local
290 : : !! NAME
291 : : !! pawxc_size_dvxc_local
292 : : !!
293 : : !! FUNCTION
294 : : !! Local version of size_dvxc routine (to use outside ABINIT)
295 : : !!
296 : : !! SOURCE
297 : :
298 : : subroutine pawxc_size_dvxc_local()
299 : :
300 : : !Local variables----------------
301 : : logical :: need_gradient,need_kden,need_laplacian
302 : :
303 : : ! *************************************************************************
304 : :
305 : : !Do we use the gradient?
306 : : need_gradient=((ixc>=11.and.ixc<=17).or.(ixc==23.or.ixc==24).or. &
307 : : & (ixc==26.or.ixc==27).or.(ixc>=31.and.ixc<=35).or. &
308 : : & (ixc==41.or.ixc==42).or.ixc==1402000.or.ixc==60)
309 : : if (ixc<0) then
310 : : if (libxc_functionals_isgga().or.libxc_functionals_ismgga().or. &
311 : : & libxc_functionals_is_hybrid()) need_gradient=.true.
312 : : end if
313 : : usegradient_=0 ; if (need_gradient) usegradient_=2*min(nspden,2)-1
314 : :
315 : : !Do we use the laplacian?
316 : : need_laplacian=(ixc==32.or.ixc==35)
317 : : if (ixc<0) need_laplacian=libxc_functionals_needs_laplacian()
318 : : uselaplacian_=0 ; if (need_laplacian) uselaplacian_=min(nspden,2)
319 : :
320 : : !Do we use the kinetic energy density?
321 : : need_kden=(ixc==31.or.ixc==34.or.ixc==35)
322 : : if (ixc<0) need_kden=libxc_functionals_needs_tau()
323 : : usekden_=0 ; if (need_kden) usekden_=min(nspden,2)
324 : :
325 : : !First derivative(s) of XC functional wrt gradient of density
326 : : nvxcgrho_=0
327 : : if (abs(order)>=1) then
328 : : if (need_gradient) nvxcgrho_=3
329 : : if (ixc==16.or.ixc==17.or.ixc==26.or.ixc==27) nvxcgrho_=2
330 : : end if
331 : :
332 : : !First derivative(s) of XC functional wrt laplacian of density
333 : : nvxclrho_=0
334 : : if (abs(order)>=1) then
335 : : if (need_laplacian) nvxclrho_=min(nspden,2)
336 : : end if
337 : :
338 : : !First derivative(s) of XC functional wrt kinetic energy density
339 : : nvxctau_=0
340 : : if (abs(order)>=1) then
341 : : if (need_kden) nvxctau_=min(nspden,2)
342 : : end if
343 : :
344 : : !Second derivative(s) of XC functional wrt density
345 : : ndvxc_=0
346 : : if (abs(order)>=2) then
347 : : if (ixc==1.or.ixc==7.or.ixc==8.or.ixc==9.or.ixc==10.or.ixc==13.or. &
348 : : & ixc==21.or.ixc==22) then
349 : : ndvxc_=min(nspden,2)+1
350 : : else if ((ixc>=2.and.ixc<=6).or.(ixc>=31.and.ixc<=35).or.&
351 : : & (ixc==50.or.ixc==51.or.ixc==60)) then
352 : : ndvxc_=1
353 : : else if (ixc==12.or.ixc==24) then
354 : : ndvxc_=8
355 : : else if (ixc==11.or.ixc==12.or.ixc==14.or.ixc==15.or. &
356 : : & ixc==23.or.ixc==41.or.ixc==42.or.ixc==1402000) then
357 : : ndvxc_=15
358 : : else if (ixc<0) then
359 : : if (libxc_functionals_has_kxc() then
360 : : ndvxc_=2*min(nspden,2)+1 ; if (order==-2) ndvxc_=2
361 : : if (need_gradient) ndvxc_=15
362 : : end if
363 : : end if
364 : : end if
365 : :
366 : : !Third derivative(s) of XC functional wrt density
367 : : nd2vxc_=0
368 : : if (abs(order)>=3) then
369 : : if (ixc==3.or.(ixc>=11.and.ixc<=15.and.ixc/=13).or. &
370 : : & ixc==23.or.ixc==24.or.ixc==41.or.ixc==42) then
371 : : nd2vxc_=1
372 : : else if ((ixc>=7.and.ixc<=10).or.ixc==13.or.ixc==1402000) then
373 : : nd2vxc_=3*min(nspden,2)-2
374 : : else if (ixc<0) then
375 : : if (libxc_functionals_has_k3xc() then
376 : : if (.not.need_gradient) nd2vxc_=3*min(nspden,2)-2
377 : : end if
378 : : end if
379 : : end if
380 : :
381 : : end subroutine pawxc_size_dvxc_local
382 : : !!***
383 : : #endif
384 : :
385 : 245577 : end subroutine pawxc_size_dvxc_wrapper
386 : : !!***
387 : :
388 : : !----------------------------------------------------------------------
389 : :
390 : : !!****f* m_pawxc/pawxc_xcmult_wrapper
391 : : !! NAME
392 : : !! pawxc_xcmult_wrapper
393 : : !!
394 : : !! FUNCTION
395 : : !! In the case of GGA, multiply the different gradient of spin-density
396 : : !! by the derivative of the XC functional with respect
397 : : !! to the norm of the gradient, then divide it by the
398 : : !! norm of the gradient
399 : : !!
400 : : !! INPUTS
401 : : !! depsxc(nfft,nspgrad)=derivative of Exc with respect to the (spin-)density,
402 : : !! or to the norm of the gradient of the (spin-)density,
403 : : !! further divided by the norm of the gradient of the (spin-)density
404 : : !! The different components of depsxc will be
405 : : !! for nspden=1, depsxc(:,1)=d(rho.exc)/d(rho)
406 : : !! and if ngrad=2, depsxc(:,2)=1/2*1/|grad rho_up|*d(rho.exc)/d(|grad rho_up|)
407 : : !! + 1/|grad rho|*d(rho.exc)/d(|grad rho|)
408 : : !! (do not forget : |grad rho| /= |grad rho_up| + |grad rho_down|
409 : : !! for nspden=2, depsxc(:,1)=d(rho.exc)/d(rho_up)
410 : : !! depsxc(:,2)=d(rho.exc)/d(rho_down)
411 : : !! and if ngrad=2, depsxc(:,3)=1/|grad rho_up|*d(rho.exc)/d(|grad rho_up|)
412 : : !! depsxc(:,4)=1/|grad rho_down|*d(rho.exc)/d(|grad rho_down|)
413 : : !! depsxc(:,5)=1/|grad rho|*d(rho.exc)/d(|grad rho|)
414 : : !! nfft=(effective) number of FFT grid points (for this processor)
415 : : !! ngrad = must be 2
416 : : !! nspden=number of spin-density components
417 : : !! nspgrad=number of spin-density and spin-density-gradient components
418 : : !!
419 : : !! OUTPUT
420 : : !! (see side effects)
421 : : !!
422 : : !! SIDE EFFECTS
423 : : !! rhonow(nfft,nspden,ngrad*ngrad)=
424 : : !! at input :
425 : : !! electron (spin)-density in real space and its gradient,
426 : : !! either on the unshifted grid (if ishift==0,
427 : : !! then equal to rhor), or on the shifted grid
428 : : !! rhonow(:,:,1)=electron density in electrons/bohr**3
429 : : !! rhonow(:,:,2:4)=gradient of electron density in el./bohr**4
430 : : !! at output :
431 : : !! rhonow(:,:,2:4) has been multiplied by the proper factor,
432 : : !! described above.
433 : : !!
434 : : !! SOURCE
435 : :
436 : 189648 : subroutine pawxc_xcmult_wrapper(depsxc,nfft,ngrad,nspden,nspgrad,rhonow)
437 : :
438 : : !Arguments ------------------------------------
439 : : !scalars
440 : : integer,intent(in) :: nfft,ngrad,nspden,nspgrad
441 : : !arrays
442 : : real(dp),intent(in) :: depsxc(nfft,nspgrad)
443 : : real(dp),intent(inout) :: rhonow(nfft,nspden,ngrad*ngrad)
444 : :
445 : : ! *************************************************************************
446 : :
447 : : #if defined HAVE_LIBPAW_ABINIT
448 : 189648 : call xcmult(depsxc,nfft,ngrad,nspden,nspgrad,rhonow)
449 : : #else
450 : : call pawxc_xcmult_local()
451 : : #endif
452 : : !!***
453 : :
454 : : #if ! defined HAVE_LIBPAW_ABINIT
455 : : contains
456 : : !!***
457 : :
458 : : !!****f* pawxc_xcmult_wrapper/pawxc_xcmult_local
459 : : !! NAME
460 : : !! pawxc_xcmult_local
461 : : !!
462 : : !! FUNCTION
463 : : !! Local version of xcmult routine (to use outside ABINIT)
464 : : !!
465 : : !! SOURCE
466 : :
467 : : subroutine pawxc_xcmult_local()
468 : :
469 : : !Local variables-------------------------------
470 : : !scalars
471 : : integer :: idir,ifft
472 : : real(dp) :: rho_tot,rho_up
473 : :
474 : : ! *************************************************************************
475 : :
476 : : do idir=1,3
477 : :
478 : : if(nspden==1)then
479 : : !$OMP PARALLEL DO PRIVATE(ifft) SHARED(depsxc,idir,nfft,rhonow)
480 : : do ifft=1,nfft
481 : : rhonow(ifft,1,1+idir)=rhonow(ifft,1,1+idir)*depsxc(ifft,2)
482 : : end do
483 : : else
484 : : ! In the spin-polarized case, there are more factors to take into account
485 : : !$OMP PARALLEL DO PRIVATE(ifft,rho_tot,rho_up) SHARED(depsxc,idir,nfft,rhonow)
486 : : do ifft=1,nfft
487 : : rho_tot=rhonow(ifft,1,1+idir)
488 : : rho_up =rhonow(ifft,2,1+idir)
489 : : rhonow(ifft,1,1+idir)=rho_up *depsxc(ifft,3) + rho_tot*depsxc(ifft,5)
490 : : rhonow(ifft,2,1+idir)=(rho_tot-rho_up)*depsxc(ifft,4)+ rho_tot*depsxc(ifft,5)
491 : : end do
492 : : end if ! nspden==1
493 : : end do ! End loop on directions
494 : :
495 : : end subroutine pawxc_xcmult_local
496 : : !!***
497 : : #endif
498 : :
499 : : end subroutine pawxc_xcmult_wrapper
500 : : !!***
501 : :
502 : : !----------------------------------------------------------------------
503 : :
504 : : !!****f* m_pawxc/pawxc_mkdenpos_wrapper
505 : : !! NAME
506 : : !! pawxc_mkdenpos_wrapper
507 : : !!
508 : : !! FUNCTION
509 : : !! Make a density positive everywhere :
510 : : !! when the density (or spin-density) is smaller than xc_denpos,
511 : : !! set it to the value of xc_denpos
512 : : !!
513 : : !! INPUTS
514 : : !! nfft=(effective) number of FFT grid points (for this processor)
515 : : !! nspden=number of spin-density components (max. 2)
516 : : !! option=0 if density rhonow is stored as (up,dn)
517 : : !! 1 if density rhonow is stored as (up+dn,up)
518 : : !! Active only when nspden=2
519 : : !! xc_denpos= lowest allowed density (usually for the computation of the XC functionals)
520 : : !!
521 : : !! OUTPUT
522 : : !!
523 : : !! SIDE EFFECTS
524 : : !! Input/output
525 : : !! iwarn=At input: iwarn=0 a warning will be printed when rho is negative
526 : : !! iwarn>0 no warning will be printed out
527 : : !! At output: iwarn is increased by 1
528 : : !! rhonow(nfft,nspden)=electron (spin)-density in real space,
529 : : !! either on the unshifted grid (if ishift==0,
530 : : !! then equal to rhor),or on the shifted grid
531 : : !!
532 : : !! SOURCE
533 : :
534 : 530929 : subroutine pawxc_mkdenpos_wrapper(iwarn,nfft,nspden,option,rhonow,xc_denpos)
535 : :
536 : : !Arguments ------------------------------------
537 : : !scalars
538 : : integer,intent(in) :: nfft,nspden,option
539 : : integer,intent(inout) :: iwarn
540 : : real(dp),intent(in) :: xc_denpos
541 : : !arrays
542 : : real(dp),intent(inout) :: rhonow(nfft,nspden)
543 : :
544 : : ! *************************************************************************
545 : :
546 : : #if defined HAVE_LIBPAW_ABINIT
547 : 530929 : call mkdenpos(iwarn,nfft,nspden,option,rhonow,xc_denpos)
548 : : #else
549 : : call pawxc_mkdenpos_local()
550 : : #endif
551 : : !!***
552 : :
553 : : #if ! defined HAVE_LIBPAW_ABINIT
554 : : contains
555 : : !!***
556 : :
557 : : !!****f* pawxc_mkdenpos_wrapper/pawxc_mkdenpos_local
558 : : !! NAME
559 : : !! pawxc_mkdenpos_local
560 : : !!
561 : : !! FUNCTION
562 : : !! Local version of mkdenpos routine (to use outside ABINIT)
563 : : !!
564 : : !! SOURCE
565 : :
566 : : subroutine pawxc_mkdenpos_local()
567 : :
568 : : !Local variables-------------------------------
569 : : !scalars
570 : : integer :: ifft,ispden,numneg
571 : : real(dp) :: rhotmp,worst
572 : : character(len=500) :: msg
573 : : !arrays
574 : : real(dp) :: rho(2)
575 : :
576 : : ! *************************************************************************
577 : :
578 : : numneg=0;worst=zero
579 : :
580 : : if(nspden==1)then
581 : : ! Non spin-polarized
582 : : !$OMP PARALLEL DO PRIVATE(ifft,rhotmp) REDUCTION(MIN:worst) REDUCTION(+:numneg) SHARED(nfft,rhonow)
583 : : !$OMP&SHARED(nfft,rhonow)
584 : : do ifft=1,nfft
585 : : rhotmp=rhonow(ifft,1)
586 : : if(rhotmp<xc_denpos)then
587 : : if(rhotmp<-xc_denpos)then
588 : : ! This case is probably beyond machine precision considerations
589 : : worst=min(worst,rhotmp)
590 : : numneg=numneg+1
591 : : end if
592 : : rhonow(ifft,1)=xc_denpos
593 : : end if
594 : : end do
595 : :
596 : : else if (nspden==2) then
597 : : ! Spin-polarized
598 : :
599 : : ! rhonow is stored as (up,dn)
600 : : if (option==0) then
601 : : !$OMP PARALLEL DO PRIVATE(ifft,ispden,rho,rhotmp) REDUCTION(MIN:worst) REDUCTION(+:numneg) &
602 : : !$OMP&SHARED(nfft,nspden,rhonow)
603 : : do ifft=1,nfft
604 : : ! For polarized case, rho(1) is spin-up density, rho(2) is spin-down density
605 : : rho(1)=rhonow(ifft,1)
606 : : rho(2)=rhonow(ifft,2)
607 : : do ispden=1,nspden
608 : : if (rho(ispden)<xc_denpos) then
609 : : if (rho(ispden)<-xc_denpos) then
610 : : ! This case is probably beyond machine precision considerations
611 : : worst=min(worst,rho(ispden))
612 : : numneg=numneg+1
613 : : end if
614 : : rhonow(ifft,ispden)=xc_denpos
615 : : end if
616 : : end do
617 : : end do
618 : :
619 : : ! rhonow is stored as (up+dn,up)
620 : : else if (option==1) then
621 : : !$OMP PARALLEL DO PRIVATE(ifft,ispden,rho,rhotmp) &
622 : : !$OMP&REDUCTION(MIN:worst) REDUCTION(+:numneg) &
623 : : !$OMP&SHARED(nfft,nspden,rhonow)
624 : : do ifft=1,nfft
625 : : ! For polarized case, rho(1) is spin-up density, rho(2) is spin-down density
626 : : rho(1)=rhonow(ifft,2)
627 : : rho(2)=rhonow(ifft,1)-rho(1)
628 : : do ispden=1,nspden
629 : : if (rho(ispden)<xc_denpos) then
630 : : if (rho(ispden)<-xc_denpos) then
631 : : ! This case is probably beyond machine precision considerations
632 : : worst=min(worst,rho(ispden))
633 : : numneg=numneg+1
634 : : end if
635 : : rho(ispden)=xc_denpos
636 : : rhonow(ifft,1)=rho(1)+rho(2)
637 : : rhonow(ifft,2)=rho(1)
638 : : end if
639 : : end do
640 : : end do
641 : :
642 : : end if ! option
643 : : else
644 : : msg='nspden>2 not allowed !'
645 : : LIBPAW_BUG(msg)
646 : : end if ! End choice between non-spin polarized and spin-polarized.
647 : :
648 : : if (numneg>0) then
649 : : if (iwarn==0) then
650 : : write(msg,'(a,i10,a,a,a,es10.2,a,e10.2,a,a,a,a)')&
651 : : & 'Density went too small (lower than xc_denpos) at',numneg,' points',ch10,&
652 : : & 'and was set to xc_denpos=',xc_denpos,'. Lowest was ',worst,'.',ch10,&
653 : : & 'Likely due to too low boxcut or too low ecut for','pseudopotential core charge.'
654 : : LIBPAW_WARNING(msg)
655 : : end if
656 : : iwarn=iwarn+1
657 : : end if
658 : :
659 : : end subroutine pawxc_mkdenpos_local
660 : : !!***
661 : : #endif
662 : :
663 : 155916 : end subroutine pawxc_mkdenpos_wrapper
664 : : !!***
665 : :
666 : : !----------------------------------------------------------------------
667 : :
668 : : !!****f* m_pawxc/pawxc_get_xclevel
669 : : !! NAME
670 : : !! pawxc_get_xclevel
671 : : !!
672 : : !! FUNCTION
673 : : !! Give the eXchange-Correlation "level" (1=LDA, 2=GGA/mGGA, 3=TDDFT)
674 : : !!
675 : : !! INPUTS
676 : : !! ixc= choice of exchange-correlation scheme
677 : : !!
678 : : !! SOURCE
679 : :
680 : 629 : function pawxc_get_xclevel(ixc)
681 : : !Arguments ------------------------------------
682 : : integer,intent(in) :: ixc
683 : : integer :: pawxc_get_xclevel
684 : :
685 : : ! *************************************************************************
686 : :
687 : 629 : pawxc_get_xclevel=0
688 : :
689 : : !ABINIT
690 [ + + ]: 629 : if ((1<=ixc.and.ixc<=10).or.(30<=ixc.and.ixc<=39).or.(ixc==50)) pawxc_get_xclevel=1 ! ABINIT LDA
691 [ + + - + ]: 629 : if ((11<=ixc.and.ixc<=19).or.(23<=ixc.and.ixc<=29).or.ixc==1402000) pawxc_get_xclevel=2 ! ABINIT GGA
692 [ - + ]: 629 : if (20<=ixc.and.ixc<=22) pawxc_get_xclevel=3 ! ABINIT TDDFT kernel tests
693 [ - + ]: 629 : if (ixc>=31.and.ixc<=35) pawxc_get_xclevel=2 ! ABINIT internal fake mGGA
694 [ + + ]: 629 : if (ixc>=41.and.ixc<=42) pawxc_get_xclevel=2 ! ABINIT internal hybrids using GGA
695 : :
696 : : !LibXC functionals
697 [ + + ]: 629 : if (ixc<0) then
698 : 261 : pawxc_get_xclevel=1
699 [ + + ]: 261 : if (libxc_functionals_isgga()) pawxc_get_xclevel=2
700 [ + + ]: 261 : if (libxc_functionals_ismgga()) pawxc_get_xclevel=2
701 [ + + ]: 261 : if (libxc_functionals_is_hybrid()) pawxc_get_xclevel=2
702 : : end if
703 : :
704 : 629 : end function pawxc_get_xclevel
705 : : !!***
706 : :
707 : : !----------------------------------------------------------------------
708 : :
709 : : !!****f* m_pawxc/pawxc_get_usekden
710 : : !! NAME
711 : : !! pawxc_get_usekden
712 : : !!
713 : : !! FUNCTION
714 : : !! Check if kinetic energy density is used in XC functional
715 : : !!
716 : : !! INPUTS
717 : : !! ixc= choice of exchange-correlation scheme
718 : : !!
719 : : !! SOURCE
720 : :
721 : 27898 : function pawxc_get_usekden(ixc)
722 : : !Arguments ------------------------------------
723 : : integer,intent(in) :: ixc
724 : : integer :: pawxc_get_usekden
725 : :
726 : : ! *************************************************************************
727 : :
728 : 27898 : pawxc_get_usekden=0
729 [ + + ]: 27898 : if (ixc<0) then
730 [ + + ]: 10772 : if (libxc_functionals_ismgga()) pawxc_get_usekden=1
731 [ - + ]: 17126 : else if (ixc==31.or.ixc==34.or.ixc==35) then
732 : 648 : pawxc_get_usekden=1
733 : : end if
734 : :
735 : 27898 : end function pawxc_get_usekden
736 : : !!***
737 : :
738 : : !----------------------------------------------------------------------
739 : :
740 : : !!****f* m_pawxc/pawxc_get_uselaplacian
741 : : !! NAME
742 : : !! pawxc_get_uselaplacian
743 : : !!
744 : : !! FUNCTION
745 : : !! Check if laplacian of density is used in XC functional
746 : : !!
747 : : !! INPUTS
748 : : !! ixc= choice of exchange-correlation scheme
749 : : !!
750 : : !! SOURCE
751 : :
752 : 618 : function pawxc_get_uselaplacian(ixc)
753 : : !Arguments ------------------------------------
754 : : integer,intent(in) :: ixc
755 : : integer :: pawxc_get_uselaplacian
756 : :
757 : : ! *************************************************************************
758 : :
759 : 618 : pawxc_get_uselaplacian=0
760 [ + + ]: 618 : if (ixc<0) then
761 [ + + ]: 251 : if (libxc_functionals_needs_laplacian()) pawxc_get_uselaplacian=1
762 [ - + ]: 367 : else if (ixc==32.or.ixc==35) then
763 : 2 : pawxc_get_uselaplacian=1
764 : : end if
765 : :
766 : 618 : end function pawxc_get_uselaplacian
767 : : !!***
768 : :
769 : : !----------------------------------------------------------------------
770 : :
771 : : !!****f* m_pawxc/pawxc_is_tb09
772 : : !! NAME
773 : : !! pawxc_is_tb09
774 : : !!
775 : : !! FUNCTION
776 : : !! Check if the XC functional is Tran-Blaha 09 (modified BJ)
777 : : !!
778 : : !! INPUTS
779 : : !! ixc= choice of exchange-correlation scheme
780 : : !!
781 : : !! SOURCE
782 : :
783 : 1991 : function pawxc_is_tb09(ixc)
784 : : !Arguments ------------------------------------
785 : : integer,intent(in) :: ixc
786 : : logical :: pawxc_is_tb09
787 : :
788 : : ! *************************************************************************
789 : :
790 : 1991 : pawxc_is_tb09=.false.
791 [ # # # # ]: 0 : if (ixc<0) then
792 : 1108 : pawxc_is_tb09 = libxc_functionals_is_tb09()
793 : : end if
794 : :
795 : 0 : end function pawxc_is_tb09
796 : : !!***
797 : :
798 : : !----------------------------------------------------------------------
799 : :
800 : : !!****f* m_pawxc/pawxc
801 : : !! NAME
802 : : !! pawxc
803 : : !!
804 : : !! FUNCTION
805 : : !! Start from the density or spin-density, and compute xc correlation
806 : : !! potential and energies inside a paw sphere.
807 : : !! USE THE DENSITY OVER A WHOLE SPHERICAL GRID (r,theta,phi)
808 : : !! Driver of XC functionals.
809 : : !!
810 : : !! INPUTS
811 : : !! corexc(nrad)=core density on radial grid
812 : : !! ixc= choice of exchange-correlation scheme
813 : : !! lm_size=size of density array rhor (see below)
814 : : !! lmselect(lm_size)=select the non-zero LM-moments of input density rhor
815 : : !! nhat(nrad,lm_size,nspden)=compensation density
816 : : !! (total in 1st half and spin-up in 2nd half if nspden=2)
817 : : !! nkxc=second dimension of the kxc array. If /=0, the exchange-correlation kernel must be computed
818 : : !! non_magnetic_xc= if true, handle density/potential as non-magnetic (even if it is)
819 : : !! nrad=size of radial mesh for densities/potentials (might be different from pawrad%mesh_size)
820 : : !! nspden=number of spin-density components
821 : : !! option=0 compute both XC energies (direct+double-counting) and potential
822 : : !! 1 compute only XC potential
823 : : !! 2 compute only XC energies (direct+double-counting)
824 : : !! 3 compute only XC energy by direct scheme
825 : : !! 4 compute only XC energy by direct scheme for spherical part of the density
826 : : !! 5 compute only XC potential for spherical part of the density
827 : : !! pawang <type(pawang_type)>=paw angular mesh and related data
828 : : !! pawrad <type(pawrad_type)>=paw radial mesh and related data
829 : : !! rhor(nrad,lm_size,nspden)=electron density in real space in electrons/bohr**3
830 : : !! (total in 1st half and spin-up in 2nd half if nspden=2)
831 : : !! usecore= 1 if core density has to be used in Exc/Vxc ; 0 otherwise
832 : : !! usexcnhat= 0 if compensation density does not have to be used
833 : : !! 1 if compensation density has to be used in double counting energy term only
834 : : !! 2 if compensation density (nhat) has to be used in Exc/Vxc and double counting energy term
835 : : !! xclevel= XC functional level
836 : : !! xc_denpos= lowest allowed density (usually for the computation of the XC functionals)
837 : : !! el_temp=electronic temperature (hartree)
838 : : !! ----- Optional arguments -----
839 : : !! [coretau(nrad*usekden)]= core kinetic energy density (optional)
840 : : !! [taur(nrad,lm_size,nspden*usekden)]= kinetic energy density on radial mesh (optional)
841 : : !! [xc_taupos]= lowest allowed kinetic energy density (for mGGA XC functionals)
842 : : !!
843 : : !! OUTPUT
844 : : !! == if option=0, 2, 3, or 4 ==
845 : : !! enxc=returned exchange and correlation energy (hartree)
846 : : !! snxc=returned exchange and correlation entropy (for finite-temperature xc functionals)
847 : : !! == if option=0 or 2 ==
848 : : !! enxcdc=returned exchange-cor. contribution to double-counting energy
849 : : !! == if option=0, 1 or 5 ==
850 : : !! vxc(nrad,pawang%angl_size,nspden)=xc potential
851 : : !! (spin up in 1st half and spin-down in 2nd half if nspden=2)
852 : : !! == if option=0, 1 or 5 and usekden=1 ==
853 : : !! [vxctau(nrad,pawang%angl_size,nspden*usekden)]=xc potential due to kinetic energy density
854 : : !! (spin up in 1st half and spin-down in 2nd half if nspden=2) (optional)
855 : : !! == if nkxc>0 ==
856 : : !! kxc(nrad,pawang%angl_size,nkxc)=xc kernel
857 : : !! (see notes below for nkxc)
858 : : !! == if nk3xc>0 ==
859 : : !! k3xc(nrad,pawang%angl_size,nk3xc)= derivative of xc kernel
860 : : !! (see notes below for nk3xc)
861 : : !! == For the TB09 XC functional (modified Becke-Johnson)
862 : : !! [grho1_over_rho1]=Integral of |Grad(rho^1)|/rho^1 over the augmentation region
863 : : !! Used to compute the c parameter of the TB09 XC functional
864 : : !!
865 : : !! NOTES
866 : : !! Content of Kxc array:
867 : : !! ===== if LDA
868 : : !! if nspden==1: kxc(:,1)= d2Exc/drho2
869 : : !! (kxc(:,2)= d2Exc/drho_up drho_dn)
870 : : !! if nspden>=2: kxc(:,1)= d2Exc/drho_up drho_up
871 : : !! kxc(:,2)= d2Exc/drho_up drho_dn
872 : : !! kxc(:,3)= d2Exc/drho_dn drho_dn
873 : : !! if nspden==4: kxc(:,4:6)= (m_x, m_y, m_z) (magnetization)
874 : : !! ===== if GGA or mGGA
875 : : !! if nspden==1:
876 : : !! kxc(:,1)= d2Exc/drho2
877 : : !! kxc(:,2)= 1/|grad(rho)| dExc/d|grad(rho)|
878 : : !! kxc(:,3)= 1/|grad(rho)| d2Exc/d|grad(rho)| drho
879 : : !! kxc(:,4)= 1/|grad(rho)| * d/d|grad(rho)| ( 1/|grad(rho)| dExc/d|grad(rho)| )
880 : : !! kxc(:,5)= gradx(rho)
881 : : !! kxc(:,6)= grady(rho)
882 : : !! kxc(:,7)= gradz(rho)
883 : : !! if nspden>=2:
884 : : !! kxc(:,1)= d2Exc/drho_up drho_up
885 : : !! kxc(:,2)= d2Exc/drho_up drho_dn
886 : : !! kxc(:,3)= d2Exc/drho_dn drho_dn
887 : : !! kxc(:,4)= 1/|grad(rho_up)| dEx/d|grad(rho_up)|
888 : : !! kxc(:,5)= 1/|grad(rho_dn)| dEx/d|grad(rho_dn)|
889 : : !! kxc(:,6)= 1/|grad(rho_up)| d2Ex/d|grad(rho_up)| drho_up
890 : : !! kxc(:,7)= 1/|grad(rho_dn)| d2Ex/d|grad(rho_dn)| drho_dn
891 : : !! kxc(:,8)= 1/|grad(rho_up)| * d/d|grad(rho_up)| ( 1/|grad(rho_up)| dEx/d|grad(rho_up)| )
892 : : !! kxc(:,9)= 1/|grad(rho_dn)| * d/d|grad(rho_dn)| ( 1/|grad(rho_dn)| dEx/d|grad(rho_dn)| )
893 : : !! kxc(:,10)=1/|grad(rho)| dEc/d|grad(rho)|
894 : : !! kxc(:,11)=1/|grad(rho)| d2Ec/d|grad(rho)| drho_up
895 : : !! kxc(:,12)=1/|grad(rho)| d2Ec/d|grad(rho)| drho_dn
896 : : !! kxc(:,13)=1/|grad(rho)| * d/d|grad(rho)| ( 1/|grad(rho)| dEc/d|grad(rho)| )
897 : : !! kxc(:,14)=gradx(rho_up)
898 : : !! kxc(:,15)=gradx(rho_dn)
899 : : !! kxc(:,16)=grady(rho_up)
900 : : !! kxc(:,17)=grady(rho_dn)
901 : : !! kxc(:,18)=gradz(rho_up)
902 : : !! kxc(:,19)=gradz(rho_dn)
903 : : !! if nspden==4:
904 : : !! kxc(:,20:22)= (m_x, m_y, m_z) (magnetization)
905 : : !! Note about mGGA: 2nd derivatives involving Tau or Laplacian are not output
906 : : !! Content of K3xc array:
907 : : !! ===== if LDA (xclevel=1) :
908 : : !! if nspden==1: return k3xc(:,1)=d3Exc/drho3
909 : : !! if nspden>=2, return k3xc(:,1)=d3Exc/drho_up drho_up drho_up
910 : : !! k3xc(:,2)=d3Exc/drho_up drho_up drho_dn
911 : : !! k3xc(:,3)=d3Exc/drho_up drho_dn drho_dn
912 : : !! k3xc(:,4)=d3Exc/drho_dn drho_dn drho_dn
913 : : !!
914 : : !! SOURCE
915 : 5973 : subroutine pawxc(corexc,enxc,enxcdc,snxc,hyb_mixing,ixc,kxc,k3xc,lm_size,lmselect,nhat,nkxc,nk3xc,non_magnetic_xc,&
916 : 3982 : & nrad,nspden,option,pawang,pawrad,rhor,usecore,usexcnhat,vxc,xclevel,xc_denpos,el_temp,&
917 [ + + + - : 1991 : & coretau,taur,vxctau,xc_taupos,grho1_over_rho1) ! optional arguments
- + + + +
+ - + + +
+ + - + ]
918 : :
919 : : !Arguments ------------------------------------
920 : : !scalars
921 : : integer,intent(in) :: ixc,lm_size,nkxc,nk3xc,nrad,nspden,option,usecore,usexcnhat,xclevel
922 : : logical,intent(in) :: non_magnetic_xc
923 : : real(dp),intent(in) :: el_temp,hyb_mixing,xc_denpos
924 : : real(dp),intent(in),optional :: xc_taupos
925 : : real(dp),intent(out) :: enxc,enxcdc,snxc
926 : : real(dp),intent(out),optional :: grho1_over_rho1
927 : : type(pawang_type),intent(in) :: pawang
928 : : type(pawrad_type),intent(in) :: pawrad
929 : : !arrays
930 : : logical,intent(in) :: lmselect(lm_size)
931 : : real(dp),intent(in) :: corexc(nrad)
932 : : real(dp),intent(in) :: nhat(nrad,lm_size,nspden*((usexcnhat+1)/2))
933 : : real(dp),intent(in),target :: rhor(nrad,lm_size,nspden)
934 : : real(dp),intent(in),target,optional:: coretau(:),taur(:,:,:)
935 : : real(dp),intent(out) :: kxc(nrad,pawang%angl_size,nkxc)
936 : : real(dp),intent(out) :: k3xc(nrad,pawang%angl_size,nk3xc)
937 : : real(dp),intent(out),target :: vxc(nrad,pawang%angl_size,nspden)
938 : : real(dp),intent(out),target,optional :: vxctau(:,:,:)
939 : :
940 : : !Local variables-------------------------------
941 : : !scalars
942 : : integer,parameter :: mu(3,3)=reshape([4,9,8,9,5,7,8,7,6],[3,3]) ! Voigt indices
943 : : integer,parameter :: nrad_blk=32 ! Size of the blocks of radial points for the moments of gxc and lxc
944 : : integer :: ii,ilm,ipass,ipts,ipts_first,ipts_last,ir,ir1,ir2,ispden,iwarn,jj,lm_size_eff,ndvxc,nd2vxc,ngrad
945 : : integer :: nkxc_updn,npts,nspden_eff,nspden_updn,nspgrad,nu
946 : : integer :: nvxcgrho,nvxclrho,nvxctau,order
947 : : integer :: usecoretau,usegradient,usekden,uselaplacian
948 : : logical :: need_grho1,need_vxctau,store_gxc,store_lxc,use_omp,with_taur
949 : : real(dp) :: factor,my_xc_taupos,rhotot
950 : : character(len=500) :: msg
951 : : !arrays
952 : 1991 : real(dp),allocatable :: dgxc(:),dlxc(:),d2lxc(:),dnexcdn(:,:),drho(:),d2rho(:),drhocore(:)
953 : 1991 : real(dp),allocatable :: vxci(:,:),vxci_grho(:,:),vxci_lrho(:,:),vxci_tau(:,:)
954 : 1991 : real(dp),allocatable :: dvxci(:,:),d2vxci(:,:),dylmdr(:,:,:)
955 : 1991 : real(dp),allocatable :: exci(:),tsxci(:),ff(:),grho2_updn(:,:),gxc(:,:,:,:),lxc(:,:,:)
956 : 1991 : real(dp),allocatable :: rhoarr(:,:),rho_updn(:,:),lrho_updn(:,:),lrhocore(:)
957 : 1991 : real(dp),allocatable :: tauarr(:,:),tau_updn(:,:),ylmlapl(:,:)
958 : 1991 : real(dp),allocatable :: dgxc_lm(:,:,:),gxcr_lm(:,:,:)
959 : 1991 : real(dp),allocatable :: enxc_pts(:),grho1_pts(:),snxc_pts(:),vxcrho_pts(:)
960 : 1991 : real(dp),allocatable :: gxc_pts(:,:,:,:),lxc_pts(:,:,:)
961 : 1991 : real(dp),allocatable,target :: mag(:,:,:),rhohat(:,:,:),rhonow(:,:,:)
962 : 1991 : real(dp),pointer :: mag_(:,:),rho_(:,:,:),tau_(:,:,:),vxctau_(:,:,:)
963 : 1991 : real(dp), LIBPAW_CONTIGUOUS pointer :: vxc_diag(:,:),vxc_nc(:,:),vxc_updn(:,:,:)
964 : : #ifdef LIBPAW_ISO_C_BINDING
965 : : type(C_PTR) :: cptr
966 : : #endif
967 : :
968 : : ! *************************************************************************
969 : :
970 : : !----------------------------------------------------------------------
971 : : !----- Check options
972 : : !----------------------------------------------------------------------
973 : :
974 : : !Some dimensions
975 : 3982 : nkxc_updn=merge(nkxc-3,nkxc,nkxc==6.or.nkxc==22)
976 : :
977 : : !Compatibility tests
978 [ + + - + ]: 1991 : if(nspden==4.and.nk3xc>0) then
979 : 0 : msg='K3xc for nspden=4 not implemented!'
980 : 0 : LIBPAW_ERROR(msg)
981 : : end if
982 [ + + - + ]: 1991 : if(nk3xc>0.and.nkxc_updn==0) then
983 : 0 : msg='nkxc must be non-zero if nk3xc is!'
984 : 0 : LIBPAW_ERROR(msg)
985 : : end if
986 [ + + + + : 1991 : if(nspden==4.and.xclevel==2.and..not.non_magnetic_xc) then
- + ]
987 : 0 : msg='GGA/mGGA for nspden=4 not fully implemented! (only works if usepawu=4 or pawxcdev/=0)'
988 : 0 : LIBPAW_ERROR(msg)
989 : : end if
990 [ - + ]: 1991 : if(pawang%angl_size==0) then
991 : 0 : msg='pawang%angl_size=0!'
992 : 0 : LIBPAW_BUG(msg)
993 : : end if
994 [ - + ]: 1991 : if(.not.allocated(pawang%ylmr)) then
995 : 0 : msg='pawang%ylmr must be allocated!'
996 : 0 : LIBPAW_BUG(msg)
997 : : end if
998 [ + + - + ]: 1991 : if(xclevel==2.and.(.not.allocated(pawang%ylmrgr))) then
999 : 0 : msg='pawang%ylmrgr must be allocated!'
1000 : 0 : LIBPAW_BUG(msg)
1001 : : end if
1002 [ + + ]: 1991 : if(option==4.or.option==5) then
1003 [ - + ]: 43 : if (pawang%angl_size/=1) then
1004 : 0 : msg='When option=4 or 5, pawang%angl_size must be 1!'
1005 : 0 : LIBPAW_BUG(msg)
1006 : : end if
1007 [ - + ]: 43 : if (pawang%ylm_size/=1) then
1008 : 0 : msg='When option=4 or 5, pawang%ylm_size must be 1!'
1009 : 0 : LIBPAW_BUG(msg)
1010 : : end if
1011 [ + - + - : 43 : if (abs(pawang%anginit(1,1)-one)>tol12.or.abs(pawang%anginit(2,1))>tol12.or. &
- + ]
1012 : : & abs(pawang%anginit(3,1))>tol12) then
1013 : 0 : msg='When option=4 or 5, pawang%anginit must be (1 0 0)!'
1014 : 0 : LIBPAW_BUG(msg)
1015 : : end if
1016 : : end if
1017 [ + + ]: 1991 : if (option/=1.and.option/=5) then
1018 [ - + ]: 1767 : if (nrad<pawrad%int_meshsz) then
1019 : 0 : msg='When option=0,2,3,4, nrad must be greater than pawrad%int_meshsz!'
1020 : 0 : LIBPAW_BUG(msg)
1021 : : end if
1022 : : end if
1023 : :
1024 : :
1025 : : !----------------------------------------------------------------------
1026 : : !----- Initializations
1027 : : !----------------------------------------------------------------------
1028 : 1991 : iwarn=0
1029 : 1991 : nspden_updn=min(nspden,2)
1030 [ + + + + ]: 1991 : nspden_eff=nspden_updn;if (nspden==4.and.xclevel==2) nspden_eff=4
1031 : 1991 : npts=pawang%angl_size
1032 : 1991 : lm_size_eff=min(lm_size,pawang%ylm_size)
1033 [ + + ]: 1991 : ngrad=1;if(xclevel==2)ngrad=2
1034 [ + + ]: 1991 : nspgrad=0;if (xclevel==2) nspgrad=3*nspden_updn-1
1035 [ + + ]: 1991 : if (option/=1.and.option/=5) then
1036 : 1767 : enxc=zero
1037 : 1767 : snxc=zero
1038 : : end if
1039 [ + + ]: 1991 : if (option==0.or.option==2) enxcdc=zero
1040 [ + + + + : 547680069 : if (option/=3.and.option/=4) vxc(:,:,:)=zero
+ + + + ]
1041 [ + + + - : 216536575 : if (present(vxctau).and.option/=3.and.option/=4) vxctau(:,:,:)=zero
+ - + + +
+ + + ]
1042 [ + + + + : 44777967 : if (nkxc>0) kxc(:,:,:)=zero
+ + + + ]
1043 [ + + + + : 9987915 : if (nk3xc>0) k3xc(:,:,:)=zero
+ + + + ]
1044 [ + + + + ]: 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
1045 [ - + ]: 1991 : if (present(grho1_over_rho1)) grho1_over_rho1=zero
1046 [ + + ]: 1991 : my_xc_taupos=xc_denpos;if(present(xc_taupos)) my_xc_taupos=xc_taupos
1047 : :
1048 [ + - - + ]: 1991 : if (xclevel==0.or.ixc==0) then
1049 : 0 : msg='Note that no xc is applied (ixc=0).'
1050 : 0 : LIBPAW_WARNING(msg)
1051 : :
1052 : : else
1053 : :
1054 : : ! Determine several flags/sizes defining the XCfunctional
1055 : : call pawxc_size_dvxc_wrapper(ixc,order,nspden_updn,&
1056 : : & usegradient=usegradient,uselaplacian=uselaplacian,usekden=usekden,&
1057 : 1991 : & nvxcgrho=nvxcgrho,nvxclrho=nvxclrho,nvxctau=nvxctau,ndvxc=ndvxc,nd2vxc=nd2vxc)
1058 : :
1059 : : ! Allocation of temporary memory space
1060 [ + + ]: 1991 : if (usexcnhat>0) then
1061 [ - + + - : 525 : LIBPAW_ALLOCATE(rhohat,(nrad,lm_size,nspden))
- + + - -
+ + - + -
+ - - + -
+ ]
1062 [ + + + + : 8322801 : rhohat(:,:,:)=rhor(:,:,:)+nhat(:,:,:)
+ + ]
1063 : : end if
1064 [ + + ]: 1991 : if (usexcnhat< 2) rho_=> rhor
1065 [ + + ]: 1991 : if (usexcnhat==2) rho_=> rhohat
1066 [ + + ]: 1991 : if (option/=3.and.option/=4) then
1067 [ + + ]: 1948 : if (nspden/=4) then
1068 : 1750 : vxc_updn => vxc
1069 : : else
1070 [ - + + - : 990 : LIBPAW_POINTER_ALLOCATE(vxc_updn,(nrad,npts,nspden_updn))
- + + - -
+ + - + -
+ - - + -
+ ]
1071 [ - + + - : 990 : LIBPAW_ALLOCATE(mag,(nrad,npts,3))
- + + - +
- + - + -
- + - + ]
1072 : : end if
1073 : : end if
1074 : :
1075 : : ! Meta-GGA: allocation of temporary space
1076 : 1991 : with_taur=.false. ; tau_ => null()
1077 : 1991 : usecoretau=0 ; need_vxctau=.false.
1078 [ + + ]: 1991 : if (usekden==1) then
1079 [ + + ]: 982 : if (present(taur)) then
1080 : 968 : with_taur=.true. ; tau_=> taur
1081 [ + + - + ]: 3872 : if (size(taur)/=nrad*lm_size*nspden) then
1082 : 0 : msg='wrong size for taur!'
1083 : 0 : LIBPAW_BUG(msg)
1084 : : end if
1085 : : end if
1086 [ + + ]: 982 : if (present(vxctau)) then
1087 : 968 : need_vxctau=.true. ; vxctau_ => vxctau
1088 [ + + - + ]: 3872 : if (size(vxctau)/=nrad*pawang%angl_size*nspden) then
1089 : 0 : msg='wrong size for vxctau!'
1090 : 0 : LIBPAW_BUG(msg)
1091 : : end if
1092 [ - + ]: 14 : else if (option==0.or.option==2) then
1093 : : !Need to compute vxctau temporarily
1094 : 0 : need_vxctau=.true.
1095 [ # # # # : 0 : LIBPAW_ALLOCATE(vxctau_,(nrad,pawang%angl_size,nspden))
# # # # #
# # # # #
# # # # #
# ]
1096 : : end if
1097 [ + - ]: 982 : if (present(coretau)) then
1098 : 982 : usecoretau=usecore
1099 [ - + ]: 982 : if (size(coretau)/=nrad) then
1100 : 0 : msg='wrong size for coretau!'
1101 : 0 : LIBPAW_BUG(msg)
1102 : : end if
1103 : : end if
1104 : : end if
1105 : :
1106 : : ! Need derivative of core density for GGA/mGGA
1107 [ + + + + ]: 1991 : if (xclevel==2.and.usecore==1) then
1108 [ - + + - : 3561 : LIBPAW_ALLOCATE(drhocore,(nrad))
+ - + - -
+ - + ]
1109 : 1187 : call nderiv_gen(drhocore,corexc,pawrad)
1110 [ + + ]: 1187 : if (uselaplacian==1) then
1111 [ - + + - : 452 : LIBPAW_ALLOCATE(lrhocore,(nrad))
- + - + ]
1112 [ - + + - : 452 : LIBPAW_ALLOCATE(d2rho,(nrad))
- + - + ]
1113 : 226 : call nderiv_gen(d2rho,drhocore,pawrad)
1114 [ + + ]: 315362 : lrhocore(2:nrad)=d2rho(2:nrad)+two*drhocore(2:nrad)/pawrad%rad(2:nrad)
1115 : 226 : call pawrad_deducer0(lrhocore,nrad,pawrad)
1116 [ - + ]: 226 : LIBPAW_DEALLOCATE(d2rho)
1117 : : end if
1118 : : end if
1119 : :
1120 : : ! GGA/mGGA: convert Ylm derivatives from normalized (r_i^hat)
1121 : : ! to standard cartesian coordinates (r_i)
1122 : : ! dYlm/dr_i = { dYlm/dr_i^hat - r_i^hat * Sum_j[dYlm/dr_j^hat r_j^hat] } * (1/r)
1123 : : ! Laplacian: convert Ylm second derivatives from normalized to standard cartesian coordinates
1124 : : ! Sum_i[d^2Ylm/dr_i^2] = { Sum_j[dYlm/dr_j^hat r_j^hat]
1125 : : ! - Sum_j>k[d^2Ylm/dr_j^hat.dr_k^hat r_j^hat r_k^hat] } * (-2/r^2)
1126 : : ! Note that we consider here r=1 (r will be used later)...
1127 [ + + ]: 1991 : if (xclevel==2) then
1128 [ - + + - : 5188 : LIBPAW_ALLOCATE(dylmdr,(3,npts,pawang%ylm_size))
- + + - +
- + - - +
- + ]
1129 [ + + ]: 38354 : do ilm=1,pawang%ylm_size
1130 [ + + ]: 5499147 : do ipts=1,npts
1131 [ + + ]: 21843172 : factor=sum(pawang%ylmrgr(1:3,ilm,ipts)*pawang%anginit(1:3,ipts))
1132 [ + + ]: 21880229 : dylmdr(1:3,ipts,ilm)=pawang%ylmrgr(1:3,ilm,ipts)-factor*pawang%anginit(1:3,ipts)
1133 : : end do
1134 : : end do
1135 [ - + + - : 6485 : LIBPAW_ALLOCATE(gxc,(nrad,3,pawang%ylm_size,nspden_updn))
- + + - -
+ + - + -
+ - - + -
+ ]
1136 [ + + + + : 164423277 : gxc=zero
+ + + + ]
1137 [ + + ]: 1297 : if (uselaplacian==1) then
1138 [ - + + - : 904 : LIBPAW_ALLOCATE(ylmlapl,(npts,pawang%ylm_size))
- + + - +
- + - - +
- + ]
1139 [ + + + + ]: 562918 : ylmlapl(:,:)=zero
1140 [ + + ]: 3812 : do ilm=1,pawang%ylm_size
1141 [ + + ]: 562918 : do ipts=1,npts
1142 [ + + ]: 2240010 : do ii=1,3
1143 : 1677318 : factor=zero
1144 [ + + ]: 5031954 : do jj=1,ii
1145 : 3354636 : nu=mu(jj,ii)
1146 : 5031954 : factor=factor+pawang%ylmrgr(nu,ilm,ipts)*pawang%anginit(jj,ipts)
1147 : : end do
1148 : : ylmlapl(ipts,ilm)=ylmlapl(ipts,ilm) &
1149 : 2236424 : & -two*(pawang%ylmrgr(ii,ilm,ipts)+factor)*pawang%anginit(ii,ipts)
1150 : : end do
1151 : : end do
1152 : : end do
1153 [ - + + - : 1130 : LIBPAW_ALLOCATE(lxc,(nrad,pawang%ylm_size,nspden_updn))
- + + - -
+ + - + -
+ - - + -
+ ]
1154 [ + + + + : 4989800 : lxc=zero
+ + ]
1155 : : end if
1156 : : end if
1157 : :
1158 : : ! ----------------------------------------------------------------------
1159 : : ! ----- Loop on the angular part and inits
1160 : : ! ----------------------------------------------------------------------
1161 : :
1162 : : ! Results of the angular points that are summed: they are accumulated after the loop,
1163 : : ! in the order of the points, so that they do not depend on the number of threads
1164 [ - + - - : 1991 : need_grho1=(present(grho1_over_rho1).and.pawxc_is_tb09(ixc).and.option<4)
- - ]
1165 [ + + + + : 1991 : store_gxc=(option/=3.and.option/=4.and.xclevel==2.and.ixc/=13)
- + ]
1166 [ + + + + : 1991 : store_lxc=(option/=3.and.option/=4.and.xclevel==2.and.uselaplacian==1)
+ + ]
1167 [ - + + - : 5973 : LIBPAW_ALLOCATE(enxc_pts,(npts))
+ - + - -
+ - + ]
1168 [ - + + - : 3982 : LIBPAW_ALLOCATE(snxc_pts,(npts))
- + - + ]
1169 [ - + + - : 3982 : LIBPAW_ALLOCATE(grho1_pts,(npts))
- + - + ]
1170 [ + + + + : 887432 : enxc_pts(:)=zero ; snxc_pts(:)=zero ; grho1_pts(:)=zero
+ + ]
1171 [ + + ]: 1991 : if (store_gxc) then
1172 [ - + + - : 6360 : LIBPAW_ALLOCATE(gxc_pts,(nrad,3,nspden_updn,npts))
- + + - -
+ + - + -
+ - - + -
+ ]
1173 : : end if
1174 [ + + ]: 1991 : if (store_lxc) then
1175 [ - + + - : 2887 : LIBPAW_ALLOCATE(lxc_pts,(nrad,nspden_updn,npts))
- + + - -
+ + - + -
+ - - + -
+ + + ]
1176 : : end if
1177 : :
1178 : : ! The angular points are independent: they are distributed over the OpenMP threads,
1179 : : ! except for TB09, whose c parameter is stored in the (shared) functional at each call.
1180 : : ! The first point is treated alone, before the others (ipass=1): some XC functionals
1181 : : ! initialize saved constants at their first call.
1182 : 1991 : use_omp=(.not.pawxc_is_tb09(ixc))
1183 : : !$OMP PARALLEL IF(use_omp) DEFAULT(SHARED) &
1184 : : !$OMP& PRIVATE(ipass,ipts_first,ipts_last,ii,ilm,ipts,ir,ispden,factor,rhotot,mag_,msg) &
1185 : : !$OMP& PRIVATE(rhoarr,tauarr,rhonow,rho_updn,grho2_updn,lrho_updn,tau_updn,exci,tsxci,vxci) &
1186 : : !$OMP& PRIVATE(vxci_grho,vxci_lrho,vxci_tau,dvxci,d2vxci,dnexcdn,drho,d2rho,ff)
1187 : :
1188 : : ! Work arrays of the thread
1189 [ - + + - : 9955 : LIBPAW_ALLOCATE(rhonow,(nrad,nspden,ngrad*ngrad+uselaplacian))
- + + - -
+ + - + -
+ - - + -
+ ]
1190 [ - + + - : 7964 : LIBPAW_ALLOCATE(rhoarr,(nrad,nspden))
- + + - +
- + - - +
- + ]
1191 [ - + + - : 7964 : LIBPAW_ALLOCATE(tauarr,(nrad,nspden*usekden))
+ + + - +
- + + - +
- + ]
1192 [ - + + - : 5973 : LIBPAW_ALLOCATE(drho,(nrad))
+ - + - -
+ - + ]
1193 [ + + + - : 5973 : LIBPAW_ALLOCATE(d2rho,(nrad*uselaplacian))
+ - + + -
+ - + -
+ ]
1194 [ - + + - : 3982 : LIBPAW_ALLOCATE(ff,(nrad))
- + - + ]
1195 : : ! Mandatory arguments of drivexc
1196 [ - + + - : 3982 : LIBPAW_ALLOCATE(exci,(nrad))
- + - + ]
1197 [ - + + - : 3982 : LIBPAW_ALLOCATE(tsxci,(nrad))
- + - + ]
1198 [ - + + - : 7964 : LIBPAW_ALLOCATE(vxci,(nrad,nspden_updn))
- + + - +
- + - - +
- + ]
1199 [ - + + - : 5973 : LIBPAW_ALLOCATE(rho_updn,(nrad,nspden_updn))
- + + - -
+ - + ]
1200 : : ! Optional arguments of drivexc
1201 [ - + + - : 7964 : LIBPAW_ALLOCATE(grho2_updn,(nrad,(2*nspden_updn-1)*usegradient))
+ + + - +
- + + - +
- + ]
1202 [ - + + - : 7964 : LIBPAW_ALLOCATE(lrho_updn,(nrad,nspden_updn*uselaplacian))
+ + + - +
- + + - +
- + ]
1203 [ - + + - : 7964 : LIBPAW_ALLOCATE(tau_updn,(nrad,nspden_updn*usekden))
+ + + - +
- + + - +
- + ]
1204 [ - + + - : 7964 : LIBPAW_ALLOCATE(vxci_grho,(nrad,nvxcgrho))
+ + + - +
- + + - +
- + ]
1205 [ - + + - : 7964 : LIBPAW_ALLOCATE(vxci_lrho,(nrad,nvxclrho))
+ + + - +
- + + - +
- + ]
1206 [ - + + - : 7964 : LIBPAW_ALLOCATE(vxci_tau,(nrad,nvxctau))
+ + + - +
- + + - +
- + ]
1207 [ - + + - : 7964 : LIBPAW_ALLOCATE(dvxci,(nrad,ndvxc))
+ + + - +
- + + - +
- + ]
1208 [ - + + - : 7964 : LIBPAW_ALLOCATE(d2vxci,(nrad,nd2vxc))
+ + + - +
- + + - +
- + ]
1209 [ - + + - : 7964 : LIBPAW_ALLOCATE(dnexcdn,(nrad,nspgrad))
+ + + - +
- + + - +
- + ]
1210 : :
1211 [ + + ]: 5973 : do ipass=1,2
1212 [ + + ]: 3982 : ipts_first=merge(1,2,ipass==1) ; ipts_last=merge(1,npts,ipass==1)
1213 : : !$OMP DO SCHEDULE(STATIC)
1214 [ + + ]: 301120 : do ipts=ipts_first,ipts_last
1215 : :
1216 : : ! Copy the input density for this (theta,phi)
1217 [ + + + + ]: 548043743 : rhoarr(:,:)=zero
1218 [ + + ]: 763679 : do ispden=1,nspden
1219 [ + + ]: 9992083 : do ilm=1,lm_size_eff
1220 [ + + ]: 9696936 : if (lmselect(ilm)) then
1221 : : rhoarr(1:nrad,ispden)=rhoarr(1:nrad,ispden) &
1222 [ + + ]: 8233930068 : & +rho_(1:nrad,ilm,ispden)*pawang%ylmr(ilm,ipts)
1223 : : end if
1224 : : end do
1225 : : end do
1226 [ + + ]: 295147 : if (usekden==1) then
1227 [ + + + + ]: 216712662 : tauarr(:,:)=zero
1228 [ + + ]: 151022 : if (with_taur) then
1229 [ + + ]: 302016 : do ispden=1,nspden
1230 [ + + ]: 3258528 : do ilm=1,lm_size_eff
1231 : : tauarr(1:nrad,ispden)=tauarr(1:nrad,ispden) &
1232 [ + + ]: 4274826192 : & +tau_(1:nrad,ilm,ispden)*pawang%ylmr(ilm,ipts)
1233 : : end do
1234 : : end do
1235 : : end if
1236 : : end if
1237 [ + + ]: 295147 : if (usecore==1) then
1238 [ + + ]: 345092595 : rhoarr(1:nrad,1)=rhoarr(1:nrad,1)+corexc(1:nrad)
1239 [ + + + + ]: 76497759 : if (nspden==2) rhoarr(1:nrad,2)=rhoarr(1:nrad,2)+half*corexc(1:nrad)
1240 : : end if
1241 [ + + ]: 295147 : if (usecoretau==1) then
1242 [ + + ]: 216561640 : tauarr(1:nrad,1)=tauarr(1:nrad,1)+coretau(1:nrad)
1243 [ - + - - ]: 151022 : if (nspden==2) tauarr(1:nrad,2)=tauarr(1:nrad,2)+half*coretau(1:nrad)
1244 : : end if
1245 : :
1246 : : ! Optionally suppress magnetic part
1247 [ + + ]: 295147 : if (non_magnetic_xc) then
1248 [ - + - - ]: 18408 : if(nspden==2) rhoarr(:,2)=rhoarr(:,1)*half
1249 [ + - + + : 58840392 : if(nspden==4) rhoarr(:,2:4)=zero
+ + ]
1250 [ - + ]: 18408 : if (usekden==1) then
1251 [ # # # # ]: 0 : if(nspden==2) tauarr(:,2)=tauarr(:,1)*half
1252 [ # # # # : 0 : if(nspden==4) tauarr(:,2:4)=zero
# # ]
1253 : : end if
1254 : : endif
1255 : :
1256 [ + + + + ]: 548043743 : rhonow(1:nrad,1:nspden,1)=rhoarr(1:nrad,1:nspden)
1257 : :
1258 : : ! GGA: compute gradient (and possibly laplacian) of density
1259 [ + + ]: 295147 : if (xclevel==2) then
1260 [ + + + + : 934293872 : rhonow(:,:,2:4+uselaplacian)=zero
+ + ]
1261 [ + + ]: 418571 : do ispden=1,nspden
1262 [ + + ]: 5034349 : do ilm=1,lm_size_eff
1263 [ + + ]: 4844676 : if (lmselect(ilm)) then
1264 [ + + ]: 4966128770 : ff(1:nrad)=rho_(1:nrad,ilm,ispden)
1265 : 3777186 : call nderiv_gen(drho,ff,pawrad)
1266 [ + + ]: 4962351584 : ff(2:nrad)=ff(2:nrad)/pawrad%rad(2:nrad)
1267 : 3777186 : call pawrad_deducer0(ff,nrad,pawrad)
1268 [ + + ]: 15108744 : do ii=1,3
1269 : : rhonow(1:nrad,ispden,1+ii)=rhonow(1:nrad,ispden,1+ii) &
1270 : : & +drho(1:nrad)*pawang%ylmr(ilm,ipts)*pawang%anginit(ii,ipts) &
1271 [ + + ]: 14902163496 : & +ff(1:nrad)*dylmdr(ii,ipts,ilm)
1272 : : end do
1273 [ + + ]: 3777186 : if (uselaplacian==1) then
1274 : 115442 : call nderiv_gen(d2rho,drho,pawrad)
1275 [ + + ]: 160465602 : ff(2:nrad)=ff(2:nrad)/pawrad%rad(2:nrad)
1276 : 115442 : call pawrad_deducer0(ff,nrad,pawrad)
1277 [ + + ]: 160465602 : drho(2:nrad)=drho(2:nrad)/pawrad%rad(2:nrad)
1278 : 115442 : call pawrad_deducer0(drho,nrad,pawrad)
1279 : : rhonow(1:nrad,ispden,5)=rhonow(1:nrad,ispden,5) &
1280 : : & +ff(1:nrad)*ylmlapl(ipts,ilm) &
1281 [ + + ]: 160581044 : & +(d2rho(1:nrad)+two*drho(1:nrad))*pawang%ylmr(ilm,ipts)
1282 : : end if
1283 : : end if
1284 : : end do
1285 : : end do
1286 [ + + ]: 189673 : if (non_magnetic_xc) then
1287 [ + + ]: 38688 : do ii=1,3
1288 [ - + - - ]: 29016 : if(nspden==2) rhonow(1:nrad,2,1+ii)=rhonow(1:nrad,1,1+ii)*half
1289 [ + - + + : 93005952 : if(nspden==4) rhonow(1:nrad,2:4,1+ii)=zero
+ + ]
1290 : : end do
1291 [ - + ]: 9672 : if (uselaplacian==1) then
1292 [ # # # # ]: 0 : if(nspden==2) rhonow(1:nrad,2,5)=rhonow(1:nrad,1,5)*half
1293 [ # # # # : 0 : if(nspden==4) rhonow(1:nrad,2:4,5)=zero
# # ]
1294 : : end if
1295 : : end if
1296 [ + + ]: 189673 : if (usecore==1) then
1297 [ + + ]: 705828 : do ii=1,3
1298 : : rhonow(1:nrad,1,1+ii)=rhonow(1:nrad,1,1+ii) &
1299 [ + + ]: 732276252 : & +drhocore(1:nrad)*pawang%anginit(ii,ipts)
1300 : : end do
1301 [ + + ]: 176457 : if (nspden==2) then
1302 [ + + ]: 20420 : do ii=1,3
1303 : : rhonow(1:nrad,2,1+ii)=rhonow(1:nrad,2,1+ii) &
1304 [ + + ]: 10312208 : & +half*drhocore(1:nrad)*pawang%anginit(ii,ipts)
1305 : : end do
1306 : : end if
1307 [ + + ]: 176457 : if (uselaplacian==1) then
1308 [ + + ]: 48611108 : rhonow(1:nrad,1,5)=rhonow(1:nrad,1,5)+lrhocore(1:nrad)
1309 [ - + - - ]: 34946 : if (nspden==2) rhonow(1:nrad,2,5)=rhonow(1:nrad,2,5)+half*lrhocore(1:nrad)
1310 : : end if
1311 : : end if
1312 : : end if
1313 : :
1314 : : ! Storage of density (and gradient) in (up,dn) format
1315 [ + + ]: 295147 : if (nspden==1) then
1316 [ + + ]: 256831738 : rho_updn(1:nrad,1)=rhonow(1:nrad,1,1)*half
1317 [ + + ]: 183538 : if (xclevel==2) grho2_updn(1:nrad,1)= &
1318 [ + + ]: 239904456 : & quarter*(rhonow(1:nrad,1,2)**2+rhonow(1:nrad,1,3)**2+rhonow(1:nrad,1,4)**2)
1319 [ + + + + ]: 216594156 : if (usekden==1) tau_updn(1:nrad,1)=tauarr(1:nrad,1)*half
1320 [ + + + + ]: 48759700 : if (uselaplacian==1) lrho_updn(1:nrad,1)=rhonow(1:nrad,1,5)*half
1321 [ + + ]: 111609 : else if (nspden==2) then
1322 [ + + ]: 79736253 : rho_updn(1:nrad,1)=rhonow(1:nrad,2,1)
1323 [ + + ]: 79736253 : rho_updn(1:nrad,2)=rhonow(1:nrad,1,1)-rhonow(1:nrad,2,1)
1324 [ + + ]: 80721 : if (xclevel==2) then
1325 [ + + ]: 6869901 : grho2_updn(1:nrad,1)=rhonow(1:nrad,2,2)**2+rhonow(1:nrad,2,3)**2+rhonow(1:nrad,2,4)**2
1326 : : grho2_updn(1:nrad,2)=(rhonow(1:nrad,1,2)-rhonow(1:nrad,2,2))**2 + &
1327 : : & (rhonow(1:nrad,1,3)-rhonow(1:nrad,2,3))**2 + &
1328 [ + + ]: 6869901 : & (rhonow(1:nrad,1,4)-rhonow(1:nrad,2,4))**2
1329 [ + + ]: 6869901 : grho2_updn(1:nrad,3)=rhonow(1:nrad,1,2)**2+rhonow(1:nrad,1,3)**2+rhonow(1:nrad,1,4)**2
1330 : : end if
1331 [ - + ]: 80721 : if (usekden==1) then
1332 [ # # ]: 0 : tau_updn(1:nrad,1)=tauarr(1:nrad,2)
1333 [ # # ]: 0 : tau_updn(1:nrad,2)=tauarr(1:nrad,1)-tauarr(1:nrad,2)
1334 : : end if
1335 [ - + ]: 80721 : if (uselaplacian==1) then
1336 [ # # ]: 0 : lrho_updn(1:nrad,1)=rhonow(1:nrad,2,5)
1337 [ # # ]: 0 : lrho_updn(1:nrad,2)=rhonow(1:nrad,1,5)-rhonow(1:nrad,2,5)
1338 : : end if
1339 [ + - ]: 30888 : else if (nspden==4) then
1340 : 30888 : mag_ => rhonow(1:nrad,2:4,1)
1341 [ + - + + : 197197416 : mag(1:nrad,ipts,1:3)=mag_(1:nrad,1:3)
+ + + + +
+ ]
1342 [ - + ]: 30888 : call pawxc_rotate_mag(rhonow(:,:,1),rho_updn,mag_,nrad) ! Note : gradients are not computed there
1343 [ + + + + ]: 30888 : if (non_magnetic_xc.and.xclevel==2) then ! In this case grho2_updn is easy to compute
1344 [ + + ]: 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)
1345 [ + + ]: 10329696 : grho2_updn(1:nrad,2)=grho2_updn(1:nrad,1)
1346 [ + + ]: 10329696 : grho2_updn(1:nrad,3)=rhonow(1:nrad,1,2)**2+rhonow(1:nrad,1,3)**2+rhonow(1:nrad,1,4)**2
1347 : : end if
1348 : : end if
1349 : :
1350 : : ! Make the density positive everywhere (but do not care about gradients)
1351 : : ! Critical section (named pawxc_mkdenpos, also used in pawxcm):
1352 : : ! - iwarn is shared by the threads of the angular loop: only the first negative density is reported;
1353 : : ! - pawxc and pawxcm may also run on different atoms at the same time (threaded atom loop of
1354 : : ! pawdenpot): the warning of mkdenpos is then printed by one thread at a time.
1355 : : !$OMP CRITICAL (pawxc_mkdenpos)
1356 : 295147 : call pawxc_mkdenpos_wrapper(iwarn,nrad,nspden_updn,0,rho_updn,xc_denpos)
1357 [ + + ]: 295147 : if (usekden==1) then
1358 : 151022 : call pawxc_mkdenpos_wrapper(iwarn,nrad,nspden_updn,0,tau_updn,my_xc_taupos)
1359 : : end if
1360 : : !$OMP END CRITICAL (pawxc_mkdenpos)
1361 : :
1362 : : ! Call to main XC driver
1363 : : call pawxc_drivexc_wrapper(hyb_mixing,ixc,order,nrad,nspden_updn,&
1364 : : & usegradient,uselaplacian,usekden,rho_updn,exci,tsxci,vxci,&
1365 : : & nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc,el_temp,&
1366 : : & grho2=grho2_updn,vxcgrho=vxci_grho,&
1367 : : & lrho=lrho_updn,vxclrho=vxci_lrho,&
1368 : : & tau=tau_updn,vxctau=vxci_tau,&
1369 : 590294 : & dvxc=dvxci,d2vxc=d2vxci)
1370 : :
1371 : : ! If fake meta-GGA, has to remove the core contribution
1372 : : ! when electronic effective mass has been modified
1373 [ + + - + ]: 295147 : if (usecoretau==1.and.(ixc==31.or.ixc==35)) then
1374 : : if (ixc==31.or.ixc==35) then
1375 : 0 : factor=one-(one/1.01_dp)
1376 [ # # ]: 0 : if (nspden_updn==1) then
1377 : 0 : factor=factor*half
1378 [ # # ]: 0 : do ii=1,nrad
1379 : 0 : exci(ii)=exci(ii)-factor*coretau(ii)/rho_updn(ii,1)
1380 : : end do
1381 : : else
1382 [ # # ]: 0 : do ii=1,nrad
1383 : 0 : exci(ii)=exci(ii)-factor*coretau(ii)/(rho_updn(ii,1)+rho_updn(ii,2))
1384 : : end do
1385 : : end if
1386 : : else
1387 : : msg='MetaGGA ixc=34 is not yet allowed with a core kinetic energy density!'
1388 : : LIBPAW_ERROR(msg)
1389 : : end if
1390 : : end if
1391 : :
1392 : : ! ----------------------------------------------------------------------
1393 : : ! ----- Store XC kernel and its derivative
1394 : : ! ----------------------------------------------------------------------
1395 [ + + + - ]: 295147 : if (nkxc_updn>0.and.ndvxc>0) then
1396 [ + + - + ]: 9520 : if (nkxc_updn==1.and.ndvxc==15) then
1397 [ # # ]: 0 : kxc(1:nrad,ipts,1)=half*(dvxci(1:nrad,1)+dvxci(1:nrad,9)+dvxci(1:nrad,10))
1398 [ + + - + ]: 9520 : else if (nkxc_updn==3.and.ndvxc==15) then
1399 [ # # ]: 0 : kxc(1:nrad,ipts,1)=dvxci(1:nrad,1)+dvxci(1:nrad,9)
1400 [ # # ]: 0 : kxc(1:nrad,ipts,2)=dvxci(1:nrad,10)
1401 [ # # ]: 0 : kxc(1:nrad,ipts,3)=dvxci(1:nrad,2)+dvxci(1:nrad,11)
1402 [ + + - + ]: 9520 : else if (nkxc_updn==7.and.ndvxc==8) then
1403 [ # # ]: 0 : kxc(1:nrad,ipts,1)=half*dvxci(1:nrad,1)
1404 [ # # ]: 0 : kxc(1:nrad,ipts,2)=half*dvxci(1:nrad,3)
1405 [ # # ]: 0 : kxc(1:nrad,ipts,3)=quarter*dvxci(1:nrad,5)
1406 [ # # ]: 0 : kxc(1:nrad,ipts,4)=eighth*dvxci(1:nrad,7)
1407 [ + - ]: 2496 : else if (nkxc_updn==7.and.ndvxc==15) then
1408 [ + + ]: 3072576 : kxc(1:nrad,ipts,1)=half*(dvxci(1:nrad,1)+dvxci(1:nrad,9)+dvxci(1:nrad,10))
1409 [ + + ]: 3072576 : kxc(1:nrad,ipts,2)=half*dvxci(1:nrad,3)+dvxci(1:nrad,12)
1410 [ + + ]: 3072576 : kxc(1:nrad,ipts,3)=quarter*dvxci(1:nrad,5)+dvxci(1:nrad,13)
1411 [ + + ]: 3072576 : kxc(1:nrad,ipts,4)=eighth*dvxci(1:nrad,7)+dvxci(1:nrad,15)
1412 [ + + + - ]: 7024 : else if (nkxc_updn==19.and.ndvxc==15) then
1413 [ + + ]: 133040 : kxc(1:nrad,ipts,1)=dvxci(1:nrad,1)+dvxci(1:nrad,9)
1414 [ + + ]: 133040 : kxc(1:nrad,ipts,2)=dvxci(1:nrad,10)
1415 [ + + ]: 133040 : kxc(1:nrad,ipts,3)=dvxci(1:nrad,2)+dvxci(1:nrad,11)
1416 [ + + ]: 133040 : kxc(1:nrad,ipts,4)=dvxci(1:nrad,3)
1417 [ + + ]: 133040 : kxc(1:nrad,ipts,5)=dvxci(1:nrad,4)
1418 [ + + ]: 133040 : kxc(1:nrad,ipts,6)=dvxci(1:nrad,5)
1419 [ + + ]: 133040 : kxc(1:nrad,ipts,7)=dvxci(1:nrad,6)
1420 [ + + ]: 133040 : kxc(1:nrad,ipts,8)=dvxci(1:nrad,7)
1421 [ + + ]: 133040 : kxc(1:nrad,ipts,9)=dvxci(1:nrad,8)
1422 [ + + ]: 133040 : kxc(1:nrad,ipts,10)=dvxci(1:nrad,12)
1423 [ + + ]: 133040 : kxc(1:nrad,ipts,11)=dvxci(1:nrad,13)
1424 [ + + ]: 133040 : kxc(1:nrad,ipts,12)=dvxci(1:nrad,14)
1425 [ + + ]: 133040 : kxc(1:nrad,ipts,13)=dvxci(1:nrad,15)
1426 : : else ! Other cases
1427 [ + + + + ]: 20746752 : kxc(1:nrad,ipts,1:nkxc)=zero
1428 [ + + + + ]: 20746752 : kxc(1:nrad,ipts,1:min(nkxc,ndvxc))=dvxci(1:nrad,1:min(nkxc,ndvxc))
1429 : : end if
1430 [ + + ]: 9520 : if (nkxc_updn==7) then
1431 [ + + ]: 3072576 : kxc(1:nrad,ipts,5)=rhonow(1:nrad,1,2)
1432 [ + + ]: 3072576 : kxc(1:nrad,ipts,6)=rhonow(1:nrad,1,3)
1433 [ + + ]: 3072576 : kxc(1:nrad,ipts,7)=rhonow(1:nrad,1,4)
1434 [ + + ]: 7024 : else if (nkxc_updn==19) then
1435 [ + + ]: 133040 : kxc(1:nrad,ipts,14)=rhonow(1:nrad,1,2)
1436 [ + + ]: 133040 : kxc(1:nrad,ipts,15)=rhonow(1:nrad,2,2)
1437 [ + + ]: 133040 : kxc(1:nrad,ipts,16)=rhonow(1:nrad,1,3)
1438 [ + + ]: 133040 : kxc(1:nrad,ipts,17)=rhonow(1:nrad,2,3)
1439 [ + + ]: 133040 : kxc(1:nrad,ipts,18)=rhonow(1:nrad,1,4)
1440 [ + + ]: 133040 : kxc(1:nrad,ipts,19)=rhonow(1:nrad,2,4)
1441 : : end if
1442 : : end if
1443 [ - + ]: 295147 : if (nkxc>=nkxc_updn+3) then
1444 [ # # ]: 0 : kxc(1:nrad,ipts,nkxc_updn+1)=rhonow(1:nrad,2,1)
1445 [ # # ]: 0 : kxc(1:nrad,ipts,nkxc_updn+2)=rhonow(1:nrad,3,1)
1446 [ # # ]: 0 : kxc(1:nrad,ipts,nkxc_updn+3)=rhonow(1:nrad,4,1)
1447 : : end if
1448 : :
1449 : : ! kernel derivative :
1450 [ + + + - ]: 295147 : if (nk3xc>0.and.nd2vxc>0) then
1451 [ + + + + ]: 9988368 : k3xc(1:nrad,ipts,1:min(nk3xc,nd2vxc))=d2vxci(1:nrad,1:min(nk3xc,nd2vxc))
1452 : : end if
1453 : :
1454 : : ! ----------------------------------------------------------------------
1455 : : ! ----- Store derivative of Exc wrt kinetic energy density
1456 : : ! ----------------------------------------------------------------------
1457 [ + + ]: 295147 : if (need_vxctau) then
1458 [ + + ]: 302016 : do ispden=1,nspden_updn
1459 [ + + ]: 216684624 : vxctau_(1:nrad,ipts,ispden)=vxci_tau(1:nrad,ispden)
1460 : : end do
1461 : : end if
1462 : :
1463 : : ! ----------------------------------------------------------------------
1464 : : ! ----- Accumulate and store XC potential
1465 : : ! ----------------------------------------------------------------------
1466 : :
1467 [ + + ]: 295147 : if (option/=3.and.option/=4) then
1468 : :
1469 [ + + ]: 701816 : do ispden=1,nspden_updn
1470 [ + + ]: 482247896 : vxc_updn(1:nrad,ipts,ispden)=vxci(1:nrad,ispden)
1471 : : end do
1472 : :
1473 : : ! For GGAs, additional terms appear
1474 [ + + + - ]: 295104 : if (xclevel==2.and.ixc/=13)then
1475 [ + + + + ]: 274447784 : dnexcdn(1:nrad,1:nspden_updn)=vxci(1:nrad,1:nspden_updn)
1476 : : ! Treat explicitely spin up, spin down and total spin for spin-polarized
1477 [ + + ]: 419056 : do ii=1,3
1478 [ + + + + ]: 399176 : if(nspden_updn==1.and.ii>=2)exit !exit when ii=1 is finished if non-spin-polarized
1479 [ + + ]: 291645880 : do ir=1,nrad
1480 : : ! If the norm of the gradient vanishes, then the different terms vanishes
1481 [ - + ]: 291226824 : if(grho2_updn(ir,ii)<1.0d-24) then
1482 : 0 : dnexcdn(ir,ii+nspden_updn)=zero;cycle
1483 : : end if
1484 : : ! Compute the derivative of n.e_xc wrt spin up, spin down, or total density
1485 [ + + ]: 291456232 : if(nspden_updn==1)then
1486 : 239692176 : dnexcdn(ir,ii+nspden_updn)=half*vxci_grho(ir,1) !Definition of vxci_grho changed in v3.3
1487 [ + - ]: 239692176 : if (nvxcgrho==3) dnexcdn(ir,ii+nspden_updn)=dnexcdn(ir,ii+nspden_updn)+vxci_grho(ir,3)
1488 [ + - ]: 51534648 : else if(nspden_updn==2)then
1489 [ + - ]: 51534648 : if (nvxcgrho==3) then
1490 : 51534648 : dnexcdn(ir,ii+nspden_updn)=vxci_grho(ir,ii)
1491 [ # # ]: 0 : else if (ii/=3) then
1492 : 0 : dnexcdn(ir,ii+nspden_updn)=vxci_grho(ir,ii)
1493 : : else if (ii==3) then
1494 : 0 : dnexcdn(ir,ii+nspden_updn)=zero
1495 : : end if
1496 : : end if
1497 : : end do
1498 : : end do
1499 : 189648 : call pawxc_xcmult_wrapper(dnexcdn,nrad,ngrad,nspden_eff,nspgrad,rhonow)
1500 : : ! Store gxc=1/grad(rho).dVxc/dgrad(rho) at this point (its moments are accumulated after the loop)
1501 [ + + ]: 399176 : do ispden=1,nspden_updn
1502 [ + + ]: 1027760 : do ii=1,3
1503 [ + + ]: 822983936 : gxc_pts(1:nrad,ii,ispden,ipts)=rhonow(1:nrad,ispden,1+ii)
1504 : : end do
1505 : : end do
1506 : : end if
1507 : :
1508 : : ! For laplacian-dependent functionals, additional terms appear
1509 [ + + + + ]: 295104 : if (xclevel==2.and.uselaplacian==1) then
1510 : : ! Store lxc=dVxc/dlaplacian(rho) at this point (its moments are accumulated after the loop)
1511 [ + + + + ]: 48642048 : lxc_pts(1:nrad,1:nspden_updn,ipts)=vxci_lrho(1:nrad,1:nspden_updn)
1512 : : end if
1513 : :
1514 : : end if !option
1515 : :
1516 : : ! ----------------------------------------------------------------------
1517 : : ! ----- Accumulate and store XC energy
1518 : : ! ----------------------------------------------------------------------
1519 [ + + ]: 295147 : if (option/=1.and.option/=5) then
1520 [ + + ]: 324607031 : ff(1:nrad)=rhoarr(1:nrad,1)*exci(1:nrad)*pawrad%rad(1:nrad)**2
1521 : 260667 : call simp_gen(enxc_pts(ipts),ff,pawrad)
1522 : : end if
1523 : :
1524 : : ! ----------------------------------------------------------------------
1525 : : ! ----- Accumulate and store XC entropy (for finite-temperature xc functionals)
1526 : : ! ----------------------------------------------------------------------
1527 [ + + ]: 295147 : if (option/=1.and.option/=5) then
1528 [ + + ]: 324607031 : ff(1:nrad)=rhoarr(1:nrad,1)*tsxci(1:nrad)*pawrad%rad(1:nrad)**2
1529 : 260667 : call simp_gen(snxc_pts(ipts),ff,pawrad)
1530 : : end if
1531 : :
1532 : : ! ----------------------------------------------------------------------
1533 : : ! ----- Accumulate integral of |Grad_rho|/Rho (to be used for TB09 XC)
1534 : : ! ----------------------------------------------------------------------
1535 [ - + ]: 299129 : if (need_grho1) then
1536 [ # # ]: 0 : ff(1:nrad)=zero
1537 [ # # ]: 0 : if (nspden_updn==1) then
1538 [ # # ]: 0 : do ir=1,nrad
1539 : 0 : rhotot=two*rho_updn(ir,1)
1540 [ # # ]: 0 : if (abs(rhotot)>tol10) ff(ir)=sqrt(four*grho2_updn(ir,1))/rhotot
1541 : : end do
1542 : : else ! nspden_updn=2
1543 [ # # ]: 0 : do ir=1,nrad
1544 : 0 : rhotot=rho_updn(ir,1)+rho_updn(ir,2)
1545 [ # # ]: 0 : if (abs(rhotot)>tol10) ff(ir)=sqrt(grho2_updn(ir,3))/rhotot
1546 : : end do
1547 : : end if
1548 [ # # ]: 0 : ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2
1549 : 0 : call simp_gen(grho1_pts(ipts),ff,pawrad)
1550 : : end if
1551 : :
1552 : : ! ----------------------------------------------------------------------
1553 : : ! ----- End of the loop on npts (angular part)
1554 : : ! ----------------------------------------------------------------------
1555 : : end do
1556 : : !$OMP END DO
1557 : : end do ! ipass
1558 : :
1559 [ - + ]: 1991 : LIBPAW_DEALLOCATE(rhonow)
1560 [ - + ]: 1991 : LIBPAW_DEALLOCATE(rhoarr)
1561 [ - + ]: 1991 : LIBPAW_DEALLOCATE(tauarr)
1562 [ - + ]: 1991 : LIBPAW_DEALLOCATE(drho)
1563 [ - + ]: 1991 : LIBPAW_DEALLOCATE(d2rho)
1564 [ - + ]: 1991 : LIBPAW_DEALLOCATE(ff)
1565 [ - + ]: 1991 : LIBPAW_DEALLOCATE(exci)
1566 [ - + ]: 1991 : LIBPAW_DEALLOCATE(tsxci)
1567 [ - + ]: 1991 : LIBPAW_DEALLOCATE(vxci)
1568 [ - + ]: 1991 : LIBPAW_DEALLOCATE(rho_updn)
1569 [ - + ]: 1991 : LIBPAW_DEALLOCATE(grho2_updn)
1570 [ - + ]: 1991 : LIBPAW_DEALLOCATE(lrho_updn)
1571 [ - + ]: 1991 : LIBPAW_DEALLOCATE(tau_updn)
1572 [ - + ]: 1991 : LIBPAW_DEALLOCATE(vxci_grho)
1573 [ - + ]: 1991 : LIBPAW_DEALLOCATE(vxci_lrho)
1574 [ - + ]: 1991 : LIBPAW_DEALLOCATE(vxci_tau)
1575 [ - + ]: 1991 : LIBPAW_DEALLOCATE(dvxci)
1576 [ - + ]: 1991 : LIBPAW_DEALLOCATE(d2vxci)
1577 [ - + ]: 1991 : LIBPAW_DEALLOCATE(dnexcdn)
1578 : : !$OMP END PARALLEL
1579 : :
1580 : : ! Accumulate the results of the angular points, in their order
1581 [ + + ]: 1991 : if (option/=1.and.option/=5) then
1582 [ + + ]: 262434 : do ipts=1,npts
1583 [ + + ]: 260667 : if (option/=4) enxc=enxc+enxc_pts(ipts)*pawang%angwgth(ipts)
1584 [ + + ]: 260667 : if (option==4) enxc=enxc+enxc_pts(ipts)
1585 [ + + ]: 260667 : if (option/=4) snxc=snxc+snxc_pts(ipts)*pawang%angwgth(ipts)/el_temp
1586 [ + + ]: 262434 : if (option==4) snxc=snxc+snxc_pts(ipts)/el_temp
1587 : : end do
1588 : : end if
1589 [ - + ]: 1991 : if (need_grho1) then
1590 [ # # ]: 0 : do ipts=1,npts
1591 : 0 : grho1_over_rho1=grho1_over_rho1+grho1_pts(ipts)*four_pi*pawang%angwgth(ipts)
1592 : : end do
1593 : : end if
1594 [ + + ]: 1991 : if (store_gxc) then
1595 [ + + ]: 1272 : factor=one;if (nspden_updn==1) factor=half
1596 [ + - ]: 1272 : if (option/=4.and.option/=5) then
1597 : 1272 : factor=factor*four_pi
1598 : : ! Accumulate moments of gxc=1/grad(rho).dVxc/dgrad(rho), by blocks of radial points
1599 : : !$OMP PARALLEL DO PRIVATE(ir1,ir2) IF(use_omp)
1600 [ + - + + ]: 54970 : do ir1=1,nrad,nrad_blk
1601 : 53698 : ir2=min(ir1+nrad_blk-1,nrad)
1602 : : call pawxc_gxc_moments(ir1,ir2,nrad,npts,nspden_updn,pawang%ylm_size,factor,&
1603 : 54970 : & pawang%ylmr,pawang%angwgth,gxc_pts,gxc)
1604 : : end do
1605 : : else
1606 [ # # ]: 0 : do ispden=1,nspden_updn
1607 [ # # ]: 0 : gxc(1:nrad,1,1,ispden)=factor*gxc_pts(1:nrad,1,ispden,1)
1608 : : end do
1609 : : end if
1610 [ - + ]: 1272 : LIBPAW_DEALLOCATE(gxc_pts)
1611 : : end if
1612 [ + + ]: 1991 : if (store_lxc) then
1613 [ + - ]: 224 : factor=one;if (nspden_updn==1) factor=half
1614 [ + - ]: 224 : if (option/=4.and.option/=5) then
1615 : 224 : factor=factor*four_pi
1616 : : ! Accumulate moments of lxc=dVxc/dlaplacian(rho), by blocks of radial points
1617 : : !$OMP PARALLEL DO PRIVATE(ir1,ir2,ispden,ipts,ilm) IF(use_omp)
1618 [ + - + + ]: 10080 : do ir1=1,nrad,nrad_blk
1619 : 9856 : ir2=min(ir1+nrad_blk-1,nrad)
1620 [ + + ]: 19936 : do ispden=1,nspden_updn
1621 [ + + ]: 1557248 : do ipts=1,npts
1622 [ + + ]: 26147968 : do ilm=1,pawang%ylm_size
1623 : : lxc(ir1:ir2,ilm,ispden)=lxc(ir1:ir2,ilm,ispden)+lxc_pts(ir1:ir2,ispden,ipts) &
1624 [ + + ]: 803292672 : & *pawang%ylmr(ilm,ipts)*pawang%angwgth(ipts)*factor
1625 : : end do
1626 : : end do
1627 : : end do
1628 : : end do
1629 : : else
1630 [ # # ]: 0 : do ispden=1,nspden_updn
1631 [ # # ]: 0 : lxc(1:nrad,1,ispden)=factor*lxc_pts(1:nrad,ispden,1)
1632 : : end do
1633 : : end if
1634 [ - + ]: 224 : LIBPAW_DEALLOCATE(lxc_pts)
1635 : : end if
1636 [ - + ]: 1991 : LIBPAW_DEALLOCATE(enxc_pts)
1637 [ - + ]: 1991 : LIBPAW_DEALLOCATE(snxc_pts)
1638 [ - + ]: 1991 : LIBPAW_DEALLOCATE(grho1_pts)
1639 : :
1640 : : ! Deallocate temporary memory space
1641 [ + + ]: 1991 : if (allocated(drhocore)) then
1642 : 1187 : LIBPAW_DEALLOCATE(drhocore)
1643 : : end if
1644 [ + + ]: 1991 : if (allocated(lrhocore)) then
1645 : 226 : LIBPAW_DEALLOCATE(lrhocore)
1646 : : end if
1647 : :
1648 : : ! ----------------------------------------------------------------------
1649 : : ! ----- If GGA, modify potential with term from density gradient
1650 : : ! ----------------------------------------------------------------------
1651 [ + + + + : 1991 : if (option/=3.and.option/=4.and.xclevel==2.and.ixc/=13) then
+ - ]
1652 : : ! Compute divergence of gxc and substract it from Vxc
1653 [ - + + - : 2544 : LIBPAW_ALLOCATE(dgxc,(nrad))
- + - + ]
1654 : : ! Need to multiply gxc by 2 in the non-polarised case
1655 [ + + ]: 1272 : factor=one;if (nspden_updn==1) factor=two
1656 [ + - ]: 1272 : if (option/=4.and.option/=5) then
1657 : : ! Radial derivative and gxc/r of all the moments, then the sum over them at each angular point
1658 [ - + + - : 5088 : LIBPAW_ALLOCATE(dgxc_lm,(nrad,3,pawang%ylm_size))
- + + - +
- + - - +
- + ]
1659 [ - + + - : 3816 : LIBPAW_ALLOCATE(gxcr_lm,(nrad,3,pawang%ylm_size))
- + + - -
+ - + ]
1660 [ + + ]: 2722 : do ispden=1,nspden_updn
1661 : : !$OMP PARALLEL DO COLLAPSE(2) PRIVATE(ilm,ii) IF(use_omp)
1662 [ + + ]: 44890 : do ilm=1,pawang%ylm_size
1663 [ + + ]: 175210 : do ii=1,3
1664 [ + + ]: 164240496 : gxcr_lm(1:nrad,ii,ilm)=gxc(1:nrad,ii,ilm,ispden)
1665 : 130320 : call nderiv_gen(dgxc_lm(:,ii,ilm),gxcr_lm(:,ii,ilm),pawrad)
1666 [ + + ]: 164110176 : gxcr_lm(2:nrad,ii,ilm)=gxcr_lm(2:nrad,ii,ilm)/pawrad%rad(2:nrad)
1667 : 173760 : call pawrad_deducer0(gxcr_lm(:,ii,ilm),nrad,pawrad)
1668 : : end do
1669 : : end do
1670 : : !$OMP PARALLEL DO PRIVATE(ipts) IF(use_omp)
1671 [ + + ]: 212250 : do ipts=1,npts
1672 : : call pawxc_gxc_divergence(ipts,nrad,npts,pawang%ylm_size,factor,pawang%anginit,&
1673 : 210978 : & pawang%ylmr,dylmdr,dgxc_lm,gxcr_lm,vxc_updn(:,ipts,ispden))
1674 : : end do
1675 : : end do
1676 [ - + ]: 1272 : LIBPAW_DEALLOCATE(dgxc_lm)
1677 [ - + ]: 1272 : LIBPAW_DEALLOCATE(gxcr_lm)
1678 : : else ! option==4 or option==5
1679 [ # # ]: 0 : do ispden=1,nspden_updn
1680 : 0 : call nderiv_gen(dgxc,gxc(:,1,1,ispden),pawrad)
1681 : : vxc_updn(2:nrad,1,ispden)=vxc_updn(2:nrad,1,ispden) &
1682 [ # # ]: 0 : & -factor*(dgxc(2:nrad)+two*gxc(2:nrad,1,1,ispden)/pawrad%rad(2:nrad))
1683 : 0 : call pawrad_deducer0(vxc(:,1,ispden),nrad,pawrad)
1684 : : end do
1685 : : end if
1686 [ - + ]: 1272 : LIBPAW_DEALLOCATE(dgxc)
1687 : : end if ! GGA
1688 : :
1689 : : ! ----------------------------------------------------------------------
1690 : : ! ----- If mGGA, modify potential with term from density laplacian
1691 : : ! ----------------------------------------------------------------------
1692 [ + + + + : 1991 : if (option/=3.and.option/=4.and.xclevel==2.and.uselaplacian==1.and.ixc/=13) then
+ + + - ]
1693 : : ! Compute laplacian of lxc and add it to Vxc
1694 [ - + + - : 672 : LIBPAW_ALLOCATE(dlxc,(nrad))
+ - + - -
+ - + -
+ ]
1695 [ - + + - : 448 : LIBPAW_ALLOCATE(d2lxc,(nrad))
- + - + -
+ ]
1696 : : ! Need to multiply lxc by 2 in the non-polarised case
1697 [ + - ]: 224 : factor=one;if (nspden_updn==1) factor=two
1698 [ + - ]: 224 : if (option/=4.and.option/=5) then
1699 [ - + + - : 448 : LIBPAW_ALLOCATE(ff,(nrad))
- + - + ]
1700 [ + + ]: 448 : do ispden=1,nspden_updn
1701 [ + + ]: 4032 : do ilm=1,pawang%ylm_size
1702 [ + + ]: 4985344 : ff(1:nrad)=lxc(1:nrad,ilm,ispden)
1703 : 3584 : call nderiv_gen(dlxc,ff,pawrad)
1704 : 3584 : call nderiv_gen(d2lxc,dlxc,pawrad)
1705 [ + + ]: 4981760 : ff(2:nrad)=ff(2:nrad)/(pawrad%rad(2:nrad)**2)
1706 : 3584 : call pawrad_deducer0(ff,nrad,pawrad)
1707 [ + + ]: 4981760 : dlxc(2:nrad)=dlxc(2:nrad)/pawrad%rad(2:nrad)
1708 : 3584 : call pawrad_deducer0(dlxc,nrad,pawrad)
1709 [ + + ]: 562912 : do ipts=1,npts
1710 : : vxc_updn(1:nrad,ipts,ispden)=vxc_updn(1:nrad,ipts,ispden) &
1711 : : & +factor*(ff(1:nrad)*ylmlapl(ipts,ilm) &
1712 [ + + ]: 777717248 : & +(d2lxc(1:nrad)+two*dlxc(1:nrad))*pawang%ylmr(ilm,ipts))
1713 : : end do
1714 : : end do
1715 : : end do
1716 [ - + ]: 224 : LIBPAW_DEALLOCATE(ff)
1717 : : else ! option==4 or option==5
1718 [ # # ]: 0 : do ispden=1,nspden_updn
1719 : 0 : call nderiv_gen(dlxc,lxc(:,1,ispden),pawrad)
1720 : 0 : call nderiv_gen(d2lxc,dlxc,pawrad)
1721 : : vxc_updn(2:nrad,1,ispden)=vxc_updn(2:nrad,1,ispden) &
1722 [ # # ]: 0 : & +factor*(d2lxc(2:nrad)+two*dlxc(2:nrad)/pawrad%rad(2:nrad))
1723 : 0 : call pawrad_deducer0(vxc(:,1,ispden),nrad,pawrad)
1724 : : end do
1725 : : end if
1726 [ - + ]: 224 : LIBPAW_DEALLOCATE(dlxc)
1727 [ - + ]: 224 : LIBPAW_DEALLOCATE(d2lxc)
1728 : : end if ! mGGA
1729 : :
1730 : : ! ----------------------------------------------------------------------
1731 : : ! ----- If non-collinear, rotate back potential according to magnetization
1732 : : ! ----------------------------------------------------------------------
1733 [ + + + + ]: 1991 : if (option/=3.and.option/=4.and.nspden==4) then
1734 : : ! Use of C pointers to avoid copies (when ISO C bindings are available)
1735 : : ! %@1$ xlf v15 compiler requires a auxilliary cptr variable
1736 : : #ifdef LIBPAW_ISO_C_BINDING
1737 : 198 : cptr=c_loc(vxc_updn(1,1,1))
1738 : 198 : call c_f_pointer(cptr,vxc_diag,shape=[nrad*npts,nspden_updn])
1739 : 198 : cptr=c_loc(vxc(1,1,1))
1740 : 198 : call c_f_pointer(cptr,vxc_nc,shape=[nrad*npts,nspden])
1741 : 198 : cptr=c_loc(mag(1,1,1))
1742 [ + + ]: 594 : call c_f_pointer(cptr,mag_,shape=[nrad*npts,3])
1743 : : #else
1744 : : LIBPAW_ALLOCATE(vxc_diag,(nrad*npts,nspden_updn))
1745 : : LIBPAW_ALLOCATE(vxc_nc,(nrad*npts,nspden))
1746 : : LIBPAW_ALLOCATE(mag_,(nrad*npts,3))
1747 : : vxc_diag=reshape(vxc_updn,[nrad*npts,nspden_updn])
1748 : : mag_=reshape(mag,[nrad*npts,3])
1749 : : #endif
1750 [ - + ]: 396 : call pawxc_rotate_back_mag(vxc_diag,vxc_nc,mag_,nrad*npts)
1751 : : #ifndef LIBPAW_ISO_C_BINDING
1752 : : vxc=reshape(vxc_nc,[nrad,npts,nspden])
1753 : : LIBPAW_DEALLOCATE(vxc_diag)
1754 : : LIBPAW_DEALLOCATE(mag_)
1755 : : LIBPAW_DEALLOCATE(vxc_nc)
1756 : : #endif
1757 [ - + ]: 198 : LIBPAW_POINTER_DEALLOCATE(vxc_updn)
1758 [ - + ]: 198 : LIBPAW_DEALLOCATE(mag)
1759 : : end if
1760 : :
1761 : : ! ----------------------------------------------------------------------
1762 : : ! ----- Accumulate and store XC double-counting energy
1763 : : ! ----------------------------------------------------------------------
1764 [ + + ]: 1991 : if (option==0.or.option==2) then
1765 [ + + ]: 1724 : if (usexcnhat==0) rho_=>rhor
1766 [ + + ]: 1724 : if (usexcnhat/=0) rho_=>rhohat
1767 [ - + + - : 5172 : LIBPAW_ALLOCATE(vxcrho_pts,(npts))
+ - + - -
+ - + ]
1768 : : !$OMP PARALLEL IF(use_omp) DEFAULT(SHARED) PRIVATE(ipts,ispden,ilm,rhoarr,tauarr,ff)
1769 [ - + + - : 5172 : LIBPAW_ALLOCATE(ff,(nrad))
+ - + - -
+ - + -
+ ]
1770 [ - + + - : 6896 : LIBPAW_ALLOCATE(rhoarr,(nrad,nspden))
- + + - +
- + - - +
- + ]
1771 [ - + + - : 6896 : LIBPAW_ALLOCATE(tauarr,(nrad,nspden*usekden))
+ + + - +
- + + - +
- + ]
1772 : : !$OMP DO SCHEDULE(STATIC)
1773 [ + + ]: 262348 : do ipts=1,npts ! Do loop on the angular part
1774 : : ! Compute density for this (theta,phi)
1775 [ + + + + ]: 492437712 : rhoarr(:,:)=zero
1776 [ + + ]: 685424 : do ispden=1,nspden
1777 [ + + ]: 9485520 : do ilm=1,lm_size_eff
1778 [ + + ]: 9224896 : if (lmselect(ilm)) then
1779 [ + + ]: 7978199920 : rhoarr(1:nrad,ispden)=rhoarr(1:nrad,ispden)+rho_(1:nrad,ilm,ispden)*pawang%ylmr(ilm,ipts)
1780 : : end if
1781 : : end do
1782 : : end do
1783 : : ! Compute kinetic energy density for this (theta,phi)
1784 [ + + ]: 260624 : if (with_taur.and.need_vxctau) then
1785 [ + + + + ]: 190627008 : tauarr(:,:)=zero
1786 [ + + ]: 264576 : do ispden=1,nspden
1787 [ + + ]: 3052608 : do ilm=1,lm_size_eff
1788 : : tauarr(1:nrad,ispden)=tauarr(1:nrad,ispden) &
1789 [ + + ]: 4040457408 : & +tau_(1:nrad,ilm,ispden)*pawang%ylmr(ilm,ipts)
1790 : : end do
1791 : : end do
1792 : : end if
1793 : : ! Compute integral of Vxc*rho
1794 [ + + ]: 260624 : if (nspden/=4) then
1795 [ + + ]: 291673816 : ff(:)=vxc(:,ipts,1)*rhoarr(:,nspden)
1796 [ + + + + ]: 69217144 : if (nspden==2) ff(:)=ff(:)+vxc(:,ipts,2)*(rhoarr(:,1)-rhoarr(:,2))
1797 : : else
1798 : : ff(:)=half*(vxc(:,ipts,1)*(rhoarr(:,1)+rhoarr(:,4)) &
1799 : : +vxc(:,ipts,2)*(rhoarr(:,1)-rhoarr(:,4))) &
1800 [ + + ]: 32861088 : & +vxc(:,ipts,3)*rhoarr(:,2)-vxc(:,ipts,4)*rhoarr(:,3)
1801 : : end if
1802 : : ! Possibly add integral of Vxctau*tau
1803 [ + + ]: 260624 : if (with_taur.and.need_vxctau) then
1804 [ + + ]: 190494720 : ff(:)=ff(:)+vxctau_(:,ipts,1)*tauarr(:,nspden)
1805 [ - + - - ]: 132288 : if (nspden==2) ff(:)=ff(:)+vxctau_(:,ipts,2)*(tauarr(:,1)-tauarr(:,2))
1806 : : end if
1807 [ + + ]: 324534904 : ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2
1808 : 262348 : call simp_gen(vxcrho_pts(ipts),ff,pawrad)
1809 : : end do ! End of the loop on npts (angular part)
1810 : : !$OMP END DO
1811 [ - + ]: 1724 : LIBPAW_DEALLOCATE(ff)
1812 [ - + ]: 1724 : LIBPAW_DEALLOCATE(rhoarr)
1813 [ - + ]: 1724 : LIBPAW_DEALLOCATE(tauarr)
1814 : : !$OMP END PARALLEL
1815 [ + + ]: 262348 : do ipts=1,npts
1816 : 262348 : enxcdc=enxcdc+vxcrho_pts(ipts)*pawang%angwgth(ipts)
1817 : : end do
1818 [ - + ]: 1724 : LIBPAW_DEALLOCATE(vxcrho_pts)
1819 : : end if ! option
1820 : :
1821 : : ! ----------------------------------------------------------------------
1822 : : ! ----- End
1823 : : ! ----------------------------------------------------------------------
1824 : : ! Add the four*pi factor of the Exc, Sxc and Excdc angular integration
1825 [ + + ]: 1991 : if (option/=1.and.option/=5) enxc=enxc*four_pi
1826 [ + + ]: 1991 : if (option/=1.and.option/=5) snxc=snxc*four_pi
1827 [ + + ]: 1991 : if (option==0.or.option==2) enxcdc=enxcdc*four_pi
1828 : :
1829 : : !TESTDEBUG
1830 : : ! Compute difference between fake mGGA=32 Exc=Int[Grad[rho]**2.dr]
1831 : : ! and mGGA=33 Exc=-Int[Laplacian[rho]*rho.dr]
1832 : : ! i.e. contour integral Int_contour[rho.Grad[rho].DS]=rc^2.Sum_L[rho_L(rc)*drho_L(rc)]
1833 : : ! if (option<4) then
1834 : : ! enxcr=zero
1835 : : ! ir=pawrad%int_meshsz
1836 : : ! LIBPAW_ALLOCATE(drho,(nrad))
1837 : : ! LIBPAW_ALLOCATE(ff,(nrad))
1838 : : ! enxcr=zero
1839 : : ! do ilm=1,lm_size_eff
1840 : : ! ff(1:nrad)=rho_(1:nrad,ilm,1)
1841 : : ! call nderiv_gen(drho,ff,pawrad)
1842 : : ! enxcr=enxcr+ff(ir)*drho(ir)
1843 : : ! end do
1844 : : ! LIBPAW_DEALLOCATE(drho)
1845 : : ! LIBPAW_DEALLOCATE(ff)
1846 : : ! enxcr=enxcr*0.01_dp*pawrad%rad(ir)**2
1847 : : ! write(100,*) "Contour integral=",enxcr
1848 : : ! end if
1849 : :
1850 : : ! Final memory deallocation
1851 [ + + ]: 1991 : if (usexcnhat>0) then
1852 [ - + ]: 105 : LIBPAW_DEALLOCATE(rhohat)
1853 : : end if
1854 [ + + ]: 1991 : if (xclevel==2) then
1855 [ - + ]: 1297 : LIBPAW_DEALLOCATE(gxc)
1856 [ - + ]: 1297 : LIBPAW_DEALLOCATE(dylmdr)
1857 [ + + ]: 1297 : if (uselaplacian==1) then
1858 [ - + ]: 226 : LIBPAW_DEALLOCATE(lxc)
1859 [ - + ]: 226 : LIBPAW_DEALLOCATE(ylmlapl)
1860 : : end if
1861 : : end if
1862 [ + + + + : 3982 : if (usekden==1.and.(.not.present(vxctau)).and.(option==0.or.option==2)) then
+ - ]
1863 [ # # ]: 0 : LIBPAW_DEALLOCATE(vxctau_)
1864 : : end if
1865 : :
1866 : : ! ------------------------------------
1867 : : ! End IF a xc part has to be computed
1868 : : end if
1869 : :
1870 [ + - - + : 3982 : end subroutine pawxc
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + ]
1871 : : !!***
1872 : :
1873 : : !----------------------------------------------------------------------
1874 : :
1875 : : !!****f* m_pawxc/pawxc_gxc_moments
1876 : : !! NAME
1877 : : !! pawxc_gxc_moments
1878 : : !!
1879 : : !! FUNCTION
1880 : : !! PRIVATE ROUTINE
1881 : : !! Add to the moments of gxc=1/grad(rho).dVxc/dgrad(rho) the contributions of all the angular points,
1882 : : !! for the radial points ir1 to ir2 (the points are added in their order).
1883 : : !! Kept apart from pawxc so that the loops are compiled outside of an OpenMP region.
1884 : : !!
1885 : : !! INPUTS
1886 : : !! ir1,ir2=first and last radial points
1887 : : !! nrad=size of the radial mesh
1888 : : !! npts=number of angular points
1889 : : !! nspden=number of spin components of gxc
1890 : : !! ylm_size=number of moments
1891 : : !! factor=factor applied to the contributions
1892 : : !! ylmr(ylm_size,npts)=real spherical harmonics at the angular points
1893 : : !! angwgth(npts)=weights of the angular points
1894 : : !! gxc_pts(nrad,3,nspden,npts)=gxc at the angular points
1895 : : !!
1896 : : !! SIDE EFFECTS
1897 : : !! gxc(nrad,3,ylm_size,nspden)=moments of gxc
1898 : : !!
1899 : : !! SOURCE
1900 : :
1901 : 53698 : subroutine pawxc_gxc_moments(ir1,ir2,nrad,npts,nspden,ylm_size,factor,ylmr,angwgth,gxc_pts,gxc)
1902 : :
1903 : : !Arguments ------------------------------------
1904 : : !scalars
1905 : : integer,intent(in) :: ir1,ir2,nrad,npts,nspden,ylm_size
1906 : : real(dp),intent(in) :: factor
1907 : : !arrays
1908 : : real(dp),intent(in) :: ylmr(ylm_size,npts),angwgth(npts),gxc_pts(nrad,3,nspden,npts)
1909 : : real(dp),intent(inout) :: gxc(nrad,3,ylm_size,nspden)
1910 : :
1911 : : !Local variables-------------------------------
1912 : : integer :: ii,ilm,ipts,ispden
1913 : :
1914 : : ! *************************************************************************
1915 : :
1916 [ + + ]: 112338 : do ispden=1,nspden
1917 [ + + ]: 8790418 : do ipts=1,npts
1918 [ + + ]: 262210800 : do ilm=1,ylm_size
1919 [ + + ]: 1022574400 : do ii=1,3
1920 : : gxc(ir1:ir2,ii,ilm,ispden)=gxc(ir1:ir2,ii,ilm,ispden)+gxc_pts(ir1:ir2,ii,ispden,ipts) &
1921 [ + + ]: 25025135424 : & *ylmr(ilm,ipts)*angwgth(ipts)*factor
1922 : : end do
1923 : : end do
1924 : : end do
1925 : : end do
1926 : :
1927 : 53698 : end subroutine pawxc_gxc_moments
1928 : : !!***
1929 : :
1930 : : !----------------------------------------------------------------------
1931 : :
1932 : : !!****f* m_pawxc/pawxc_gxc_divergence
1933 : : !! NAME
1934 : : !! pawxc_gxc_divergence
1935 : : !!
1936 : : !! FUNCTION
1937 : : !! PRIVATE ROUTINE
1938 : : !! Subtract from Vxc, at the angular point ipts, the divergence of gxc=1/grad(rho).dVxc/dgrad(rho),
1939 : : !! from the radial derivatives of its moments and the moments divided by r.
1940 : : !! Kept apart from pawxc so that the loops are compiled outside of an OpenMP region.
1941 : : !!
1942 : : !! INPUTS
1943 : : !! ipts=angular point
1944 : : !! nrad=size of the radial mesh
1945 : : !! npts=number of angular points
1946 : : !! ylm_size=number of moments
1947 : : !! factor=factor applied to the divergence
1948 : : !! anginit(3,npts)=angular points (unit vectors)
1949 : : !! ylmr(ylm_size,npts)=real spherical harmonics at the angular points
1950 : : !! dylmdr(3,npts,ylm_size)=cartesian derivatives of the spherical harmonics (for r=1)
1951 : : !! dgxc_lm(nrad,3,ylm_size)=radial derivatives of the moments of gxc
1952 : : !! gxcr_lm(nrad,3,ylm_size)=moments of gxc divided by r
1953 : : !!
1954 : : !! SIDE EFFECTS
1955 : : !! vxc(nrad)=XC potential at the angular point ipts
1956 : : !!
1957 : : !! SOURCE
1958 : :
1959 : 209528 : subroutine pawxc_gxc_divergence(ipts,nrad,npts,ylm_size,factor,anginit,ylmr,dylmdr,dgxc_lm,gxcr_lm,vxc)
1960 : :
1961 : : !Arguments ------------------------------------
1962 : : !scalars
1963 : : integer,intent(in) :: ipts,nrad,npts,ylm_size
1964 : : real(dp),intent(in) :: factor
1965 : : !arrays
1966 : : real(dp),intent(in) :: anginit(3,npts),ylmr(ylm_size,npts),dylmdr(3,npts,ylm_size)
1967 : : real(dp),intent(in) :: dgxc_lm(nrad,3,ylm_size),gxcr_lm(nrad,3,ylm_size)
1968 : : real(dp),intent(inout) :: vxc(nrad)
1969 : :
1970 : : !Local variables-------------------------------
1971 : : integer :: ii,ilm
1972 : :
1973 : : ! *************************************************************************
1974 : :
1975 [ + + ]: 6385976 : do ilm=1,ylm_size
1976 [ + + ]: 24915320 : do ii=1,3
1977 : : vxc(1:nrad)=vxc(1:nrad) &
1978 : : & -factor*(dgxc_lm(1:nrad,ii,ilm)*anginit(ii,ipts)*ylmr(ilm,ipts) &
1979 [ + + ]: 24035944896 : & +gxcr_lm(1:nrad,ii,ilm)*dylmdr(ii,ipts,ilm))
1980 : : end do
1981 : : end do
1982 : :
1983 : 209528 : end subroutine pawxc_gxc_divergence
1984 : : !!***
1985 : :
1986 : : !----------------------------------------------------------------------
1987 : :
1988 : : !!****f* m_pawxc/pawxcpositron
1989 : : !! NAME
1990 : : !! pawxcpositron
1991 : : !!
1992 : : !! FUNCTION
1993 : : !! Compute electron-positron correlation potential and energies inside a PAW sphere
1994 : : !! LDA ONLY - USE THE DENSITY OVER A WHOLE SPHERICAL GRID (r,theta,phi)
1995 : : !! Driver of XC functionals.
1996 : : !!
1997 : : !! INPUTS
1998 : : !! calctype=type of electronpositron calculation:
1999 : : !! calctype=1 : positron in electronic density
2000 : : !! calctype=2 : electrons in positronic density
2001 : : !! corexc(nrad)=electron core density on radial grid
2002 : : !! ixcpositron=choice of electron-positron XC scheme
2003 : : !! lm_size=size of density array rhor (see below)
2004 : : !! lmselect (lm_size)=select the non-zero LM-moments of input density rhor (see below)
2005 : : !! lmselect_ep(lm_size)=select the non-zero LM-moments of input density rhor_ep (see below)
2006 : : !! nhat (nrad,lm_size,nspden)=compensation density corresponding to rhor
2007 : : !! nhat_ep(nrad,lm_size,nspden)=compensation density corresponding to rhor_ep
2008 : : !! nrad=size of radial mesh for densities/potentials (might be different from pawrad%mesh_size)
2009 : : !! nspden=number of spin-density components
2010 : : !! option=0 compute both XC energies (direct+double-counting) and potential
2011 : : !! 1 compute only XC potential
2012 : : !! 2 compute only XC energies (direct+double-counting)
2013 : : !! 3 compute only XC energy by direct scheme
2014 : : !! 4 compute only XC energy by direct scheme for spherical part of the density
2015 : : !! pawang <type(pawang_type)>=paw angular mesh and related data
2016 : : !! pawrad <type(pawrad_type)>=paw radial mesh and related data
2017 : : !! posdensity0_limit=True if we are in the zero positron density limit
2018 : : !! rhor(nrad,lm_size,nspden)=electron (or positron) density in real space
2019 : : !! (total in 1st half and spin-up in 2nd half if nspden=2)
2020 : : !! Contents depends on calctype value:
2021 : : !! calctype=1: rhor is the positronic density
2022 : : !! calctype=2: rhor is the electronic density
2023 : : !! rhor_ep(nrad,lm_size,nspden)=electron (or positron) density in real space
2024 : : !! (total in 1st half and spin-up in 2nd half if nspden=2)
2025 : : !! Contents depends on calctype value:
2026 : : !! calctype=1: rhor_ep is the electronic density
2027 : : !! calctype=2: rhor_ep is the positronic density
2028 : : !! usecore= 1 if core density has to be used in Exc/Vxc for the electronic density ; 0 otherwise
2029 : : !! usexcnhat= 0 if compensation density does not have to be used
2030 : : !! 1 if compensation density has to be used in double counting energy term only
2031 : : !! 2 if compensation density (nhat) has to be used in Exc/Vxc and double counting energy term
2032 : : !! xc_denpos= lowest allowed density (usually for the computation of the XC functionals)
2033 : : !!
2034 : : !! OUTPUT
2035 : : !! == if option==0, 2, 3, or 4 ==
2036 : : !! enxc=returned exchange and correlation energy (hartree)
2037 : : !! == if option==0 or 2 ==
2038 : : !! enxcdc=returned exchange-cor. contribution to double-counting energy
2039 : : !! == if option==0 or 1 ==
2040 : : !! vxc(nrad,pawang%angl_size,nspden)=xc potential
2041 : : !! (spin up in 1st half and spin-down in 2nd half if nspden=2)
2042 : : !!
2043 : : !! SIDE EFFECTS
2044 : : !! electronpositron <type(electronpositron_type)>=quantities for the electron-positron annihilation
2045 : : !!
2046 : : !! SOURCE
2047 : :
2048 : 0 : subroutine pawxcpositron(calctype,corexc,enxc,enxcdc,ixcpositron,lm_size,lmselect,lmselect_ep,&
2049 : 0 : & nhat,nhat_ep,nrad,nspden,option,pawang,pawrad,posdensity0_limit,&
2050 : 0 : & rhor,rhor_ep,usecore,usexcnhat,vxc,xc_denpos)
2051 : :
2052 : : !Arguments ------------------------------------
2053 : : !scalars
2054 : : integer,intent(in) :: calctype,ixcpositron,lm_size,nrad,nspden,option,usecore,usexcnhat
2055 : : logical,intent(in) :: posdensity0_limit
2056 : : real(dp),intent(in) :: xc_denpos
2057 : : real(dp),intent(out) :: enxc,enxcdc
2058 : : type(pawang_type),intent(in) :: pawang
2059 : : type(pawrad_type),intent(in) :: pawrad
2060 : : !arrays
2061 : : logical,intent(in) :: lmselect(lm_size),lmselect_ep(lm_size)
2062 : : real(dp),intent(in) :: corexc(nrad)
2063 : : real(dp),intent(in) :: nhat(nrad,lm_size,nspden*((usexcnhat+1)/2))
2064 : : real(dp),intent(in) :: nhat_ep(nrad,lm_size,nspden*((usexcnhat+1)/2))
2065 : : real(dp),intent(in) :: rhor(nrad,lm_size,nspden)
2066 : : real(dp),intent(in) :: rhor_ep(nrad,lm_size,nspden)
2067 : : real(dp),intent(out) :: vxc(nrad,pawang%angl_size,nspden)
2068 : :
2069 : : !Local variables-------------------------------
2070 : : !scalars
2071 : : integer :: ilm,ipts,iwarn,iwarnp,ngr,ngrad,npts,order
2072 : : real(dp) :: enxcr,vxcrho
2073 : : character(len=500) :: msg
2074 : : !arrays
2075 : 0 : real(dp),allocatable :: ff(:),fxci(:),grho2(:),rhoarr(:),rhoarr_ep(:),rhoarrdc(:),vxci(:),vxci_ep(:),vxcigr(:)
2076 : :
2077 : : ! *************************************************************************
2078 : :
2079 : : !----- Check options
2080 [ # # ]: 0 : if(ixcpositron==3.or.ixcpositron==31) then
2081 : 0 : msg='GGA is not implemented (use pawxcdev/=0)!'
2082 : 0 : LIBPAW_ERROR(msg)
2083 : : end if
2084 [ # # ]: 0 : if(calctype/=1.and.calctype/=2) then
2085 : 0 : msg='Invalid value for calctype!'
2086 : 0 : LIBPAW_BUG(msg)
2087 : : end if
2088 [ # # ]: 0 : if(pawang%angl_size==0) then
2089 : 0 : msg='pawang%angl_size=0!'
2090 : 0 : LIBPAW_BUG(msg)
2091 : : end if
2092 [ # # ]: 0 : if(.not.allocated(pawang%ylmr)) then
2093 : 0 : msg='pawang%ylmr must be allocated!'
2094 : 0 : LIBPAW_BUG(msg)
2095 : : end if
2096 [ # # ]: 0 : if (option/=1) then
2097 [ # # ]: 0 : if (nrad<pawrad%int_meshsz) then
2098 : 0 : msg='When option=0,2,3,4, nrad must be greater than pawrad%int_meshsz!'
2099 : 0 : LIBPAW_BUG(msg)
2100 : : end if
2101 : : end if
2102 : :
2103 : : !----------------------------------------------------------------------
2104 : : !----- Initializations
2105 : : !----------------------------------------------------------------------
2106 : :
2107 : : !Initialization and constants
2108 : 0 : iwarn=0;iwarnp=1
2109 : 0 : npts=pawang%angl_size
2110 : 0 : order=1;ngr=0;ngrad=1 ! only LDA here !
2111 : :
2112 : : !Initializations of output arrays
2113 [ # # ]: 0 : if (option/=1) enxc=zero
2114 [ # # ]: 0 : if (option==0.or.option==2) enxcdc=zero
2115 [ # # # # : 0 : if (option<3) vxc(:,:,:)=zero
# # # # ]
2116 : :
2117 [ # # ]: 0 : if (ixcpositron==0) then ! No xc at all is applied (usually for testing)
2118 : 0 : msg = 'Note that no xc is applied (ixcpositron=0). Returning'
2119 : 0 : LIBPAW_WARNING(msg)
2120 : 0 : return
2121 : : end if
2122 : :
2123 : : !Allocations
2124 [ # # # # : 0 : LIBPAW_ALLOCATE(fxci,(nrad))
# # # # #
# # # ]
2125 [ # # # # : 0 : LIBPAW_ALLOCATE(vxci,(nrad))
# # # # ]
2126 [ # # # # : 0 : LIBPAW_ALLOCATE(rhoarr,(nrad))
# # # # ]
2127 [ # # # # : 0 : LIBPAW_ALLOCATE(rhoarr_ep,(nrad))
# # # # ]
2128 [ # # ]: 0 : if (option==0.or.option==2) then
2129 [ # # # # : 0 : LIBPAW_ALLOCATE(rhoarrdc,(nrad))
# # # # ]
2130 : : end if
2131 : :
2132 : : !----------------------------------------------------------------------
2133 : : !----- Loop on the angular part
2134 [ # # ]: 0 : do ipts=1,npts
2135 : :
2136 : : ! ----------------------------------------------------------------------
2137 : : ! ----- Build several densities
2138 : : ! ----------------------------------------------------------------------
2139 : :
2140 : : ! Eventually add compensation density to input density
2141 [ # # # # ]: 0 : rhoarr=zero;rhoarr_ep=zero
2142 [ # # ]: 0 : if (usexcnhat==2) then
2143 [ # # ]: 0 : do ilm=1,lm_size
2144 [ # # ]: 0 : if (lmselect(ilm)) &
2145 [ # # ]: 0 : & rhoarr(:)=rhoarr(:)+(rhor(:,ilm,1)+nhat(:,ilm,1))*pawang%ylmr(ilm,ipts)
2146 : : end do
2147 [ # # ]: 0 : do ilm=1,lm_size
2148 [ # # ]: 0 : if (lmselect_ep(ilm)) &
2149 [ # # ]: 0 : & rhoarr_ep(:)=rhoarr_ep(:)+(rhor_ep(:,ilm,1)+nhat_ep(:,ilm,1))*pawang%ylmr(ilm,ipts)
2150 : : end do
2151 : : else
2152 [ # # ]: 0 : do ilm=1,lm_size
2153 [ # # # # ]: 0 : if (lmselect(ilm)) rhoarr(:)=rhoarr(:)+rhor(:,ilm,1)*pawang%ylmr(ilm,ipts)
2154 : : end do
2155 [ # # ]: 0 : do ilm=1,lm_size
2156 [ # # # # ]: 0 : if (lmselect_ep(ilm)) rhoarr_ep(:)=rhoarr_ep(:)+rhor_ep(:,ilm,1)*pawang%ylmr(ilm,ipts)
2157 : : end do
2158 : : end if
2159 : :
2160 : : ! Store density for use in double-counting term
2161 [ # # # # ]: 0 : if (option==0.or.option==2) rhoarrdc(:)=rhoarr(:)
2162 : :
2163 : : ! Eventually add core density
2164 [ # # ]: 0 : if (usecore==1) then
2165 [ # # # # ]: 0 : if (calctype==1) rhoarr_ep(:)=rhoarr_ep(:)+corexc(:)
2166 [ # # # # ]: 0 : if (calctype==2) rhoarr (:)=rhoarr (:)+corexc(:)
2167 : : end if
2168 : :
2169 : : ! Make the densities positive
2170 [ # # ]: 0 : if (calctype==1) then
2171 [ # # ]: 0 : if (.not.posdensity0_limit) then
2172 : 0 : call pawxc_mkdenpos_wrapper(iwarnp,nrad,1,1,rhoarr,xc_denpos)
2173 : : end if
2174 : 0 : call pawxc_mkdenpos_wrapper(iwarn ,nrad,1,1,rhoarr_ep,xc_denpos)
2175 [ # # ]: 0 : else if (calctype==2) then
2176 : 0 : call pawxc_mkdenpos_wrapper(iwarn ,nrad,1,1,rhoarr,xc_denpos)
2177 [ # # ]: 0 : if (.not.posdensity0_limit) then
2178 : 0 : call pawxc_mkdenpos_wrapper(iwarnp,nrad,1,1,rhoarr_ep,xc_denpos)
2179 : : end if
2180 : : end if
2181 : :
2182 : : ! ----------------------------------------------------------------------
2183 : : ! ----- Compute XC data
2184 : : ! ----------------------------------------------------------------------
2185 : :
2186 : : ! electron-positron correlation for the positron
2187 [ # # # # : 0 : LIBPAW_ALLOCATE(vxci_ep,(nrad))
# # # # ]
2188 [ # # # # : 0 : LIBPAW_ALLOCATE(vxcigr,(ngr))
# # # # #
# # # ]
2189 [ # # # # : 0 : LIBPAW_ALLOCATE(grho2,(ngr))
# # # # ]
2190 [ # # ]: 0 : if (calctype==1) then
2191 : 0 : call pawxc_xcpositron_wrapper(fxci,grho2,ixcpositron,ngr,nrad,posdensity0_limit,rhoarr_ep,rhoarr,vxci_ep,vxcigr,vxci)
2192 [ # # ]: 0 : else if (calctype==2) then
2193 : 0 : call pawxc_xcpositron_wrapper(fxci,grho2,ixcpositron,ngr,nrad,posdensity0_limit,rhoarr,rhoarr_ep,vxci,vxcigr,vxci_ep)
2194 : : end if
2195 [ # # ]: 0 : LIBPAW_DEALLOCATE(vxci_ep)
2196 [ # # ]: 0 : LIBPAW_DEALLOCATE(vxcigr)
2197 [ # # ]: 0 : LIBPAW_DEALLOCATE(grho2)
2198 : :
2199 : : ! ----------------------------------------------------------------------
2200 : : ! ----- Accumulate and store XC potential
2201 : : ! ----------------------------------------------------------------------
2202 [ # # ]: 0 : if (option<3) then
2203 [ # # ]: 0 : vxc(:,ipts,1)=vxci(:)
2204 [ # # # # ]: 0 : if (nspden>=2) vxc(:,ipts,2)=vxci(:)
2205 [ # # # # : 0 : if (nspden==4) vxc(:,ipts,3:4)=zero
# # ]
2206 : : end if
2207 : :
2208 : : ! ----------------------------------------------------------------------
2209 : : ! ----- Accumulate and store XC energies
2210 : : ! ----------------------------------------------------------------------
2211 : :
2212 : : ! ----- Calculate Exc term
2213 [ # # ]: 0 : if (option/=1) then
2214 [ # # # # : 0 : LIBPAW_ALLOCATE(ff,(nrad))
# # # # #
# ]
2215 [ # # ]: 0 : ff(1:nrad)=fxci(1:nrad)*pawrad%rad(1:nrad)**2
2216 : 0 : call simp_gen(enxcr,ff,pawrad)
2217 [ # # ]: 0 : LIBPAW_DEALLOCATE(ff)
2218 [ # # ]: 0 : if (option/=4) enxc=enxc+enxcr*pawang%angwgth(ipts)
2219 [ # # ]: 0 : if (option==4) enxc=enxc+enxcr
2220 : : end if
2221 : :
2222 : : ! ----- Calculate Excdc double counting term
2223 [ # # ]: 0 : if (option==0.or.option==2) then
2224 [ # # ]: 0 : if (usexcnhat==1) then
2225 [ # # ]: 0 : do ilm=1,lm_size
2226 [ # # ]: 0 : if (lmselect(ilm)) then
2227 [ # # ]: 0 : rhoarrdc(:)=rhoarrdc(:)+nhat(:,ilm,1)*pawang%ylmr(ilm,ipts)
2228 : : end if
2229 : : end do
2230 : : end if
2231 [ # # # # : 0 : LIBPAW_ALLOCATE(ff,(nrad))
# # # # #
# ]
2232 [ # # ]: 0 : ff(1:nrad)=vxci(1:nrad)*rhoarrdc(1:nrad)*pawrad%rad(1:nrad)**2
2233 : 0 : call simp_gen(vxcrho,ff,pawrad)
2234 [ # # ]: 0 : LIBPAW_DEALLOCATE(ff)
2235 : 0 : enxcdc=enxcdc+vxcrho*pawang%angwgth(ipts)
2236 : : end if
2237 : :
2238 : : ! ---------------------------------------------------
2239 : : ! ----- End of the loop on npts (angular part)
2240 : : end do
2241 : :
2242 : : !Add the four*pi factor of the angular integration
2243 [ # # ]: 0 : if (option/=1) enxc=enxc*four_pi
2244 [ # # ]: 0 : if (option==0.or.option==2) enxcdc=enxcdc*four_pi
2245 : :
2246 : : !Deallocations
2247 [ # # ]: 0 : LIBPAW_DEALLOCATE(fxci)
2248 [ # # ]: 0 : LIBPAW_DEALLOCATE(vxci)
2249 [ # # ]: 0 : LIBPAW_DEALLOCATE(rhoarr)
2250 [ # # ]: 0 : LIBPAW_DEALLOCATE(rhoarr_ep)
2251 [ # # ]: 0 : if (option==0.or.option==2) then
2252 [ # # ]: 0 : LIBPAW_DEALLOCATE(rhoarrdc)
2253 : : end if
2254 : :
2255 [ # # # # ]: 0 : end subroutine pawxcpositron
2256 : : !!***
2257 : :
2258 : : !----------------------------------------------------------------------
2259 : :
2260 : : !!****f* m_pawxc/pawxc_dfpt
2261 : : !! NAME
2262 : : !! pawxc_dfpt
2263 : : !!
2264 : : !! FUNCTION
2265 : : !! Compute first-order change of XC potential and contribution to
2266 : : !! 2nd-order change of XC energy inside a PAW sphere.
2267 : : !! LDA+GGA - USE THE DENSITY OVER A WHOLE SPHERICAL GRID (r,theta,phi)
2268 : : !!
2269 : : !! INPUTS
2270 : : !! corexc1(cplex_den*nrad)=first-order change of core density on radial grid
2271 : : !! cplex_den= if 1, 1st-order densities are REAL, if 2, COMPLEX
2272 : : !! cplex_vxc= if 1, 1st-order XC potential is complex, if 2, COMPLEX
2273 : : !! ixc= choice of exchange-correlation scheme
2274 : : !! kxc(nrad,pawang%angl_size,nkxc)=GS xc kernel
2275 : : !! lm_size=size of density array rhor (see below)
2276 : : !! lmselect(lm_size)=select the non-zero LM-moments of input density rhor1
2277 : : !! nhat1(cplex_den*nrad,lm_size,nspden)=first-order change of compensation density
2278 : : !! (total in 1st half and spin-up in 2nd half if nspden=2)
2279 : : !! nkxc=second dimension of the kxc array
2280 : : !! non_magnetic_xc= if true, handle density/potential as non-magnetic (even if it is)
2281 : : !! nrad=size of radial mesh for densities/potentials (might be different from pawrad%mesh_size)
2282 : : !! nspden=number of spin-density components
2283 : : !! option=0 compute both 2nd-order XC energy and 1st-order potential
2284 : : !! 1 compute only 1st-order XC potential
2285 : : !! 2 compute only 2nd-order XC energy, XC potential is temporary computed here
2286 : : !! 3 compute only 2nd-order XC energy, XC potential is input in vxc1(:)
2287 : : !! pawang <type(pawang_type)>=paw angular mesh and related data
2288 : : !! pawrad <type(pawrad_type)>=paw radial mesh and related data
2289 : : !! rhor1(cplex_den*nrad,lm_size,nspden)=first-order change of density
2290 : : !! usecore= 1 if core density has to be used in Exc/Vxc ; 0 otherwise
2291 : : !! usexcnhat= 0 if compensation density does not have to be used
2292 : : !! 1 if compensation density has to be used in d2Exc only
2293 : : !! 2 if compensation density (nhat) has to be used in d2Exc and Vxc1
2294 : : !! vxc(nrad,pawang%angl_size,nspden)=GS xc potential
2295 : : !! xclevel= XC functional level
2296 : : !!
2297 : : !! OUTPUT
2298 : : !! == if option=0 or 2 or 3 ==
2299 : : !! d2enxc =returned exchange-cor. contribution to 2nd-order XC energy
2300 : : !! d2enxc_im=returned IMAGINARY PART of exchange-cor. contribution to 2nd-order XC energy
2301 : : !! (optional argument)
2302 : : !!
2303 : : !! SIDE EFFECTS
2304 : : !! vxc1(cplex_vxc*nrad,pawang%angl_size,nspden)=1st-order XC potential
2305 : : !! Output if option==0 or 1
2306 : : !! Unused if option==2
2307 : : !! Input if option==3
2308 : : !!
2309 : : !! NOTES
2310 : : !! Content of Kxc array:
2311 : : !! ===== if LDA
2312 : : !! if nspden==1: kxc(:,1)= d2Exc/drho2
2313 : : !! (kxc(:,2)= d2Exc/drho_up drho_dn)
2314 : : !! if nspden>=2: kxc(:,1)= d2Exc/drho_up drho_up
2315 : : !! kxc(:,2)= d2Exc/drho_up drho_dn
2316 : : !! kxc(:,3)= d2Exc/drho_dn drho_dn
2317 : : !! if nspden==4: kxc(:,4:6)= (m_x, m_y, m_z) (magnetization)
2318 : : !! ===== if GGA
2319 : : !! if nspden==1:
2320 : : !! kxc(:,1)= d2Exc/drho2
2321 : : !! kxc(:,2)= 1/|grad(rho)| dExc/d|grad(rho)|
2322 : : !! kxc(:,3)= 1/|grad(rho)| d2Exc/d|grad(rho)| drho
2323 : : !! kxc(:,4)= 1/|grad(rho)| * d/d|grad(rho)| ( 1/|grad(rho)| dExc/d|grad(rho)| )
2324 : : !! kxc(:,5)= gradx(rho)
2325 : : !! kxc(:,6)= grady(rho)
2326 : : !! kxc(:,7)= gradz(rho)
2327 : : !! if nspden>=2:
2328 : : !! kxc(:,1)= d2Exc/drho_up drho_up
2329 : : !! kxc(:,2)= d2Exc/drho_up drho_dn
2330 : : !! kxc(:,3)= d2Exc/drho_dn drho_dn
2331 : : !! kxc(:,4)= 1/|grad(rho_up)| dEx/d|grad(rho_up)|
2332 : : !! kxc(:,5)= 1/|grad(rho_dn)| dEx/d|grad(rho_dn)|
2333 : : !! kxc(:,6)= 1/|grad(rho_up)| d2Ex/d|grad(rho_up)| drho_up
2334 : : !! kxc(:,7)= 1/|grad(rho_dn)| d2Ex/d|grad(rho_dn)| drho_dn
2335 : : !! kxc(:,8)= 1/|grad(rho_up)| * d/d|grad(rho_up)| ( 1/|grad(rho_up)| dEx/d|grad(rho_up)| )
2336 : : !! kxc(:,9)= 1/|grad(rho_dn)| * d/d|grad(rho_dn)| ( 1/|grad(rho_dn)| dEx/d|grad(rho_dn)| )
2337 : : !! kxc(:,10)=1/|grad(rho)| dEc/d|grad(rho)|
2338 : : !! kxc(:,11)=1/|grad(rho)| d2Ec/d|grad(rho)| drho_up
2339 : : !! kxc(:,12)=1/|grad(rho)| d2Ec/d|grad(rho)| drho_dn
2340 : : !! kxc(:,13)=1/|grad(rho)| * d/d|grad(rho)| ( 1/|grad(rho)| dEc/d|grad(rho)| )
2341 : : !! kxc(:,14)=gradx(rho_up)
2342 : : !! kxc(:,15)=gradx(rho_dn)
2343 : : !! kxc(:,16)=grady(rho_up)
2344 : : !! kxc(:,17)=grady(rho_dn)
2345 : : !! kxc(:,18)=gradz(rho_up)
2346 : : !! kxc(:,19)=gradz(rho_dn)
2347 : : !! if nspden==4:
2348 : : !! kxc(:,20:22)= (m_x, m_y, m_z) (magnetization)
2349 : : !!
2350 : : !! SOURCE
2351 : :
2352 : 7752 : subroutine pawxc_dfpt(corexc1,cplex_den,cplex_vxc,d2enxc,ixc,kxc,lm_size,lmselect,nhat1,&
2353 : 7752 : & nkxc,non_magnetic_xc,nrad,nspden,option,pawang,pawrad,rhor1,&
2354 : 7752 : & usecore,usexcnhat,vxc,vxc1,xclevel,&
2355 : : & d2enxc_im) ! optional
2356 : :
2357 : : !Arguments ------------------------------------
2358 : : !scalars
2359 : : integer,intent(in) :: cplex_den,cplex_vxc,ixc,lm_size,nkxc,nrad,nspden,option
2360 : : integer,intent(in) :: usecore,usexcnhat,xclevel
2361 : : logical,intent(in) :: non_magnetic_xc
2362 : : real(dp),intent(out) :: d2enxc
2363 : : real(dp),intent(out),optional :: d2enxc_im
2364 : : type(pawang_type),intent(in) :: pawang
2365 : : type(pawrad_type),intent(in) :: pawrad
2366 : : !arrays
2367 : : logical,intent(in) :: lmselect(lm_size)
2368 : : real(dp),intent(in) :: corexc1(cplex_den*nrad)
2369 : : real(dp),intent(in) :: nhat1(cplex_den*nrad,lm_size,nspden*((usexcnhat+1)/2))
2370 : : real(dp),intent(in),target :: kxc(nrad,pawang%angl_size,nkxc)
2371 : : real(dp),intent(in),target :: vxc(nrad,pawang%angl_size,nspden)
2372 : : real(dp),intent(in),target :: rhor1(cplex_den*nrad,lm_size,nspden)
2373 : : real(dp),intent(inout),target :: vxc1(cplex_vxc*nrad,pawang%angl_size,nspden)
2374 : :
2375 : : !Local variables-------------------------------
2376 : : !scalars
2377 : : integer :: ii,ilm,ipts,ir,ispden,jr,kr,lm_size_eff,nkxc_cur,npts,nspden_updn
2378 : : logical :: need_impart
2379 : : real(dp),parameter :: tol24=tol12*tol12
2380 : : real(dp) :: coeff_grho,coeff_grho_corr,coeff_grho_dn,coeff_grho_up
2381 : : real(dp) :: coeff_grhoim,coeff_grhoim_corr,coeff_grhoim_dn,coeff_grhoim_up
2382 : : real(dp) :: dylmdr_ii,factor,factor_ang_intg,ylm_ii
2383 : : real(dp) :: grho_grho1,grho_grho1_up,grho_grho1_dn
2384 : : real(dp) :: grho_grho1im,grho_grho1im_up,grho_grho1im_dn
2385 : : real(dp) :: rho1_dn,rho1_up,rho1im_dn,rho1im_up
2386 : : real(dp) :: ro11i,ro11r,ro12i,ro12r,ro21i,ro21r,ro22i,ro22r
2387 : : real(dp) :: v11i,v11r,v12i,v12r,v21i,v21r,v22i,v22r,vxcrho
2388 : : character(len=500) :: msg
2389 : : !arrays
2390 : : real(dp) :: g0(3),g0_dn(3),g0_up(3),g1(3),g1_dn(3),g1_up(3)
2391 : : real(dp) :: g1im(3),g1im_dn(3),g1im_up(3)
2392 : : real(dp) :: gxc1i(3,2),gxc1r(3,2)
2393 : 7752 : real(dp),allocatable :: dgxc1(:),drho1(:,:),drho1core(:,:),dylmdr(:,:,:)
2394 : 7752 : real(dp),allocatable :: ff(:),gg(:),grho1arr(:,:,:),gxc1(:,:,:,:)
2395 : 7752 : real(dp),allocatable,target :: rhohat1(:,:,:),rho1arr(:,:)
2396 : 7752 : real(dp), LIBPAW_CONTIGUOUS pointer :: kxc_(:,:),mag(:,:)
2397 : 7752 : real(dp), LIBPAW_CONTIGUOUS pointer :: rho1_(:,:,:),rho1_nc(:,:),rho1_updn(:,:)
2398 : 7752 : real(dp), LIBPAW_CONTIGUOUS pointer :: vxc_(:,:),vxc1_(:,:,:),vxc1_diag(:,:)
2399 : 7752 : real(dp), LIBPAW_CONTIGUOUS pointer :: vxc1_nc(:,:),vxc1_updn(:,:,:)
2400 : : #ifdef LIBPAW_ISO_C_BINDING
2401 : : type(C_PTR) :: cptr
2402 : : #endif
2403 : :
2404 : : ! *************************************************************************
2405 : :
2406 : : !----------------------------------------------------------------------
2407 : : !----- Check options
2408 : : !----------------------------------------------------------------------
2409 : :
2410 : 7752 : if(option<0.or.option>3) then
2411 : 0 : msg='wrong option!'
2412 : 0 : LIBPAW_BUG(msg)
2413 : : end if
2414 [ + + ]: 7752 : if(option/=3) then
2415 : 6288 : call pawxc_get_nkxc(nkxc_cur,nspden,xclevel)
2416 [ - + ]: 6288 : if (nkxc/=nkxc_cur) then
2417 : 0 : msg='Wrong dimension for array kxc!'
2418 : 0 : LIBPAW_BUG(msg)
2419 : : end if
2420 [ + + - + ]: 6288 : if(xclevel==2.and.nspden==4) then
2421 : 0 : msg='PAW non-collinear magnetism not compatible with GGA!'
2422 : 0 : LIBPAW_ERROR(msg)
2423 : : end if
2424 : : end if
2425 [ - + ]: 7752 : if(pawang%angl_size==0) then
2426 : 0 : msg='pawang%angl_size=0!'
2427 : 0 : LIBPAW_BUG(msg)
2428 : : end if
2429 [ - + ]: 7752 : if(.not.allocated(pawang%ylmr)) then
2430 : 0 : msg='pawang%ylmr must be allocated!'
2431 : 0 : LIBPAW_BUG(msg)
2432 : : end if
2433 [ + + - + ]: 7752 : if(xclevel==2.and.(.not.allocated(pawang%ylmrgr))) then
2434 : 0 : msg='pawang%ylmrgr must be allocated!'
2435 : 0 : LIBPAW_BUG(msg)
2436 : : end if
2437 [ + + ]: 7752 : if (option/=1) then
2438 [ - + ]: 4052 : if (nrad<pawrad%int_meshsz) then
2439 : 0 : msg='When option=0,2, nrad must be greater than pawrad%int_meshsz!'
2440 : 0 : LIBPAW_BUG(msg)
2441 : : end if
2442 : : end if
2443 : :
2444 : : !----------------------------------------------------------------------
2445 : : !----- Initializations / allocations
2446 : : !----------------------------------------------------------------------
2447 : :
2448 : 7752 : npts=pawang%angl_size
2449 : 7752 : lm_size_eff=min(lm_size,pawang%ylm_size)
2450 : 7752 : nspden_updn=min(nspden,2)
2451 : :
2452 : 7752 : need_impart=present(d2enxc_im)
2453 [ + + ]: 7752 : if (option/=1) then
2454 : 4052 : d2enxc=zero
2455 [ + + ]: 4052 : if (need_impart) d2enxc_im=zero
2456 : : end if
2457 [ + + + + : 1304662996 : if (option<=1) vxc1(:,:,:)=zero
+ + + + ]
2458 : :
2459 : : !Special case: no XC applied
2460 [ + - + + : 7752 : if (ixc==0.or.(nkxc==0.and.option/=3)) then
- + ]
2461 : 0 : msg='Note that no xc is applied (ixc=0). Returning'
2462 : 0 : LIBPAW_WARNING(msg)
2463 : 0 : return
2464 : : end if
2465 : :
2466 [ - + + - : 31008 : LIBPAW_ALLOCATE(rho1arr,(cplex_den*nrad,nspden))
- + + - +
- + - - +
- + ]
2467 [ + + ]: 7752 : if (usexcnhat>0) then
2468 [ - + + - : 100 : LIBPAW_ALLOCATE(rhohat1,(cplex_den*nrad,lm_size,nspden))
- + + - -
+ + - + -
+ - - + -
+ ]
2469 [ + + + + : 1189060 : rhohat1(:,:,:)=rhor1(:,:,:)+nhat1(:,:,:)
+ + ]
2470 : : end if
2471 : :
2472 [ + + ]: 7752 : if (option==2) then
2473 [ - + + - : 12940 : LIBPAW_POINTER_ALLOCATE(vxc1_,(cplex_vxc*nrad,npts,nspden))
- + + - -
+ + - + -
+ - - + -
+ ]
2474 : : else
2475 : 5164 : vxc1_ => vxc1
2476 : : end if
2477 : :
2478 : : !Need gradients and additional allocations in case of GGA
2479 [ + + + + ]: 7752 : if (xclevel==2.and.option/=3) then
2480 [ - + + - : 6420 : LIBPAW_ALLOCATE(gxc1,(cplex_vxc*nrad,3,pawang%ylm_size,nspden))
- + + - -
+ + - + -
+ - - + -
+ ]
2481 [ + + + + : 146534400 : gxc1=zero
+ + + + ]
2482 [ - + ]: 1284 : if (usecore==1) then
2483 [ # # # # : 0 : LIBPAW_ALLOCATE(drho1core,(nrad,cplex_den))
# # # # #
# # # # #
# # ]
2484 [ # # ]: 0 : if (cplex_den==1) then
2485 : 0 : call nderiv_gen(drho1core(:,1),corexc1,pawrad)
2486 : : else
2487 [ # # # # : 0 : LIBPAW_ALLOCATE(ff,(nrad))
# # # # #
# # # ]
2488 [ # # # # : 0 : LIBPAW_ALLOCATE(gg,(nrad))
# # # # ]
2489 [ # # ]: 0 : do ir=1,nrad
2490 : 0 : ff(ir)=corexc1(2*ir-1)
2491 : 0 : gg(ir)=corexc1(2*ir )
2492 : : end do
2493 : 0 : call nderiv_gen(drho1core(:,1),ff,pawrad)
2494 : 0 : call nderiv_gen(drho1core(:,2),gg,pawrad)
2495 [ # # ]: 0 : LIBPAW_DEALLOCATE(ff)
2496 [ # # ]: 0 : LIBPAW_DEALLOCATE(gg)
2497 : : end if
2498 : : end if
2499 : : ! Convert Ylm derivatives from normalized to standard cartesian coordinates
2500 : : ! dYlm/dr_i = { dYlm/dr_i^hat - Sum_j[ dYlm/dr_j^hat (r_j/r)] } * (1/r)
2501 [ - + + - : 5136 : LIBPAW_ALLOCATE(dylmdr,(3,npts,pawang%ylm_size))
- + + - +
- + - - +
- + ]
2502 [ + + ]: 22948 : do ilm=1,pawang%ylm_size
2503 [ + + ]: 3168676 : do ipts=1,npts
2504 [ + + ]: 12582912 : factor=sum(pawang%ylmrgr(1:3,ilm,ipts)*pawang%anginit(1:3,ipts))
2505 [ + + ]: 12604576 : dylmdr(1:3,ipts,ilm)=pawang%ylmrgr(1:3,ilm,ipts)-factor*pawang%anginit(1:3,ipts)
2506 : : end do
2507 : : end do
2508 : : end if
2509 : :
2510 : : !----------------------------------------------------------------------
2511 : : !----- Accumulate and store 1st-order change of XC potential
2512 : : !----------------------------------------------------------------------
2513 : :
2514 [ + + ]: 7752 : if (option/=3) then
2515 : :
2516 [ + - ]: 6288 : if (nspden/=4) then
2517 : 6288 : rho1_updn => rho1arr
2518 : 6288 : vxc1_updn => vxc1_
2519 : : else
2520 [ # # # # : 0 : LIBPAW_POINTER_ALLOCATE(rho1_updn,(cplex_den*nrad,nspden_updn))
# # # # #
# # # # #
# # ]
2521 [ # # # # : 0 : LIBPAW_POINTER_ALLOCATE(vxc1_updn,(cplex_vxc*nrad,npts,nspden_updn))
# # # # #
# # # # #
# # # # #
# ]
2522 [ # # # # : 0 : LIBPAW_POINTER_ALLOCATE(rho1_nc,(cplex_den*nrad*npts,nspden))
# # # # #
# # # # #
# # ]
2523 [ # # # # : 0 : LIBPAW_POINTER_ALLOCATE(mag,(nrad,3))
# # # # #
# # # ]
2524 : : end if
2525 : :
2526 : : ! Do loop on the angular part (theta,phi)
2527 [ + + ]: 980720 : do ipts=1,npts
2528 : :
2529 : : ! Copy the input 1st-order density for this (theta,phi)
2530 [ + + + + ]: 2202865328 : rho1arr(:,:)=zero
2531 [ + + ]: 974432 : if (usexcnhat< 2) rho1_=>rhor1
2532 [ + + ]: 974432 : if (usexcnhat==2) rho1_=>rhohat1
2533 [ + + ]: 2619408 : do ispden=1,nspden
2534 [ + + ]: 17495872 : do ilm=1,lm_size_eff
2535 [ + + ]: 14876464 : if (lmselect(ilm)) rho1arr(:,ispden)=rho1arr(:,ispden) &
2536 [ + - + + : 39810599856 : & +rho1_(:,ilm,ispden)*pawang%ylmr(ilm,ipts)
+ + ]
2537 : : end do
2538 : : end do
2539 [ - + ]: 974432 : if (usecore==1) then
2540 [ # # ]: 0 : rho1arr(:,1)=rho1arr(:,1)+corexc1(:)
2541 [ # # # # ]: 0 : if (nspden==2) rho1arr(:,2)=rho1arr(:,2)+half*corexc1(:)
2542 : : end if
2543 : :
2544 : : ! Optionally suppress magnetic part
2545 [ - + ]: 974432 : if(non_magnetic_xc) then
2546 [ # # # # ]: 0 : if(nspden==2) rho1arr(:,2)=rho1arr(:,1)*half
2547 [ # # # # : 0 : if(nspden==4) rho1arr(:,2:4)=zero
# # ]
2548 : : endif
2549 : :
2550 : : ! Non-collinear magnetism: rotate magnetization and get a collinear density
2551 [ - + ]: 974432 : if (nspden==4) then
2552 : : !Store non rotated rho^(1) for future use
2553 : 0 : ii=(ipts-1)*cplex_den*nrad
2554 [ # # ]: 0 : do ispden=1,nspden
2555 [ # # # # : 0 : rho1_nc(ii+1:ii+cplex_den*nrad,ispden)=rho1arr(1:cplex_den*nrad,ispden)
# # ]
2556 : : end do
2557 : : !Extract magnetization from kxc
2558 [ # # ]: 0 : do ii=1,3
2559 [ # # # # : 0 : mag(1:nrad,ii)=kxc(:,ipts,ii)
# # ]
2560 : : end do
2561 : : !Rotate rhoarr1 -> rhoarr1_
2562 : : !Should use cplex_den
2563 : 0 : call pawxc_rotate_mag(rho1arr,rho1_updn,mag,nrad,rho_out_format=2)
2564 : : end if
2565 : :
2566 : : ! =======================================================================
2567 : : ! ======================= LDA ===========================================
2568 : : ! =======================================================================
2569 [ + + - + ]: 980720 : if (xclevel==1.or.ixc==13) then
2570 : :
2571 : : ! Non-spin-polarized
2572 [ + + ]: 780624 : if (nspden_updn==1) then
2573 [ + - ]: 112320 : if (cplex_vxc==1) then
2574 [ + - ]: 112320 : if (cplex_den==1) then ! cplex_vxc==1 and cplex_den==1
2575 [ + - + + : 276419520 : vxc1_updn(1:nrad,ipts,1)=kxc(1:nrad,ipts,1)*rho1_updn(1:nrad,1)
+ + ]
2576 : : else ! cplex_vxc==1 and cplex_den==2
2577 [ # # ]: 0 : do ir=1,nrad
2578 : 0 : vxc1_updn(ir,ipts,1)=kxc(ir,ipts,1)*rho1_updn(2*ir-1,1)
2579 : : end do
2580 : : end if
2581 : : else
2582 [ # # ]: 0 : if (cplex_den==1) then ! cplex_vxc==2 and cplex_den==1
2583 [ # # ]: 0 : do ir=1,nrad
2584 : 0 : vxc1_updn(2*ir-1,ipts,1)=kxc(ir,ipts,1)*rho1_updn(ir,1)
2585 : 0 : vxc1_updn(2*ir ,ipts,1)=zero
2586 : : end do
2587 : : else ! cplex_vxc==2 and cplex_den==2
2588 [ # # ]: 0 : do ir=1,nrad
2589 : 0 : vxc1_updn(2*ir-1,ipts,1)=kxc(ir,ipts,1)*rho1_updn(2*ir-1,1)
2590 : 0 : vxc1_updn(2*ir ,ipts,1)=kxc(ir,ipts,1)*rho1_updn(2*ir ,1)
2591 : : end do
2592 : : end if
2593 : : end if
2594 : :
2595 : : ! Spin-polarized
2596 : : else
2597 [ + - ]: 668304 : if (cplex_vxc==1) then
2598 [ + - ]: 668304 : if (cplex_den==1) then ! cplex_vxc==1 and cplex_den==1
2599 [ + + ]: 822682224 : do ir=1,nrad
2600 : 822013920 : rho1_up=rho1_updn(ir,2);rho1_dn=rho1_updn(ir,1)-rho1_up
2601 : 822013920 : vxc1_updn(ir,ipts,1)=kxc(ir,ipts,1)*rho1_up+kxc(ir,ipts,2)*rho1_dn
2602 : 822682224 : vxc1_updn(ir,ipts,2)=kxc(ir,ipts,2)*rho1_up+kxc(ir,ipts,3)*rho1_dn
2603 : : end do
2604 : : else ! cplex_vxc==1 and cplex_den==2
2605 [ # # ]: 0 : do ir=1,nrad
2606 : 0 : jr=2*ir-1
2607 : 0 : rho1_up=rho1_updn(jr,2);rho1_dn=rho1_updn(jr,1)-rho1_up
2608 : 0 : vxc1_updn(ir,ipts,1)=kxc(ir,ipts,1)*rho1_up+kxc(ir,ipts,2)*rho1_dn
2609 : 0 : vxc1_updn(ir,ipts,2)=kxc(ir,ipts,2)*rho1_up+kxc(ir,ipts,3)*rho1_dn
2610 : : end do
2611 : : end if
2612 : : else
2613 [ # # ]: 0 : if (cplex_den==1) then ! cplex_vxc==2 and cplex_den==1
2614 [ # # ]: 0 : do ir=1,nrad
2615 : 0 : jr=2*ir-1
2616 : 0 : rho1_up=rho1_updn(ir,2);rho1_dn=rho1_updn(ir,1)-rho1_up
2617 : 0 : vxc1_updn(jr,ipts,1)=kxc(ir,ipts,1)*rho1_up+kxc(ir,ipts,2)*rho1_dn
2618 : 0 : vxc1_updn(jr,ipts,2)=kxc(ir,ipts,2)*rho1_up+kxc(ir,ipts,3)*rho1_dn
2619 : : end do
2620 : : else ! cplex_vxc==2 and cplex_den==2
2621 [ # # ]: 0 : do ir=1,nrad
2622 : 0 : jr=2*ir
2623 : 0 : rho1_up =rho1_updn(jr-1,2);rho1_dn =rho1_updn(jr-1,1)-rho1_up
2624 : 0 : rho1im_up=rho1_updn(jr ,2);rho1im_dn=rho1_updn(jr ,1)-rho1im_up
2625 : 0 : vxc1_updn(jr-1,ipts,1)=kxc(ir,ipts,1)*rho1_up +kxc(ir,ipts,2)*rho1_dn
2626 : 0 : vxc1_updn(jr ,ipts,1)=kxc(ir,ipts,1)*rho1im_up+kxc(ir,ipts,2)*rho1im_dn
2627 : 0 : vxc1_updn(jr-1,ipts,2)=kxc(ir,ipts,2)*rho1_up +kxc(ir,ipts,3)*rho1_dn
2628 : 0 : vxc1_updn(jr ,ipts,2)=kxc(ir,ipts,2)*rho1im_up+kxc(ir,ipts,3)*rho1im_dn
2629 : : end do
2630 : : end if
2631 : : end if
2632 : : end if
2633 : :
2634 : : else
2635 : : ! =======================================================================
2636 : : ! ======================= GGA ===========================================
2637 : : ! =======================================================================
2638 : :
2639 : : ! Compute the gradient of the first-order density
2640 [ - + + - : 775232 : LIBPAW_ALLOCATE(drho1,(nrad,cplex_den))
- + + - +
- + - - +
- + ]
2641 [ - + + - : 969040 : LIBPAW_ALLOCATE(grho1arr,(cplex_den*nrad,nspden,3))
- + + - +
- + - + -
- + - + ]
2642 [ + + + + : 1255556816 : grho1arr(:,:,1:3)=zero
+ + ]
2643 [ + + ]: 193808 : if (cplex_den==1) then
2644 [ - + + - : 147888 : LIBPAW_ALLOCATE(ff,(nrad))
+ - + - -
+ - + -
+ ]
2645 [ + + ]: 98592 : do ispden=1,nspden_updn
2646 [ + + ]: 542256 : do ilm=1,lm_size_eff
2647 [ + - ]: 492960 : if (lmselect(ilm)) then
2648 [ + + ]: 546150384 : ff(1:nrad)=rho1_(1:nrad,ilm,ispden)
2649 : 443664 : call nderiv_gen(drho1(:,1),ff,pawrad)
2650 [ + + ]: 545706720 : ff(2:nrad)=ff(2:nrad)/pawrad%rad(2:nrad)
2651 : 443664 : call pawrad_deducer0(ff,nrad,pawrad)
2652 [ + + ]: 1774656 : do ii=1,3
2653 : 1330992 : ylm_ii=pawang%ylmr(ilm,ipts)*pawang%anginit(ii,ipts)
2654 : 1330992 : dylmdr_ii=dylmdr(ii,ipts,ilm)
2655 : : grho1arr(1:nrad,ispden,ii)=grho1arr(1:nrad,ispden,ii) &
2656 [ + + ]: 1638894816 : & +drho1(1:nrad,1)*ylm_ii+ff(1:nrad)*dylmdr_ii
2657 : : end do
2658 : : end if
2659 : : end do
2660 : : end do
2661 [ - + ]: 49296 : LIBPAW_DEALLOCATE(ff)
2662 : : else
2663 [ - + + - : 433536 : LIBPAW_ALLOCATE(ff,(nrad))
+ - + - -
+ - + -
+ ]
2664 [ - + + - : 289024 : LIBPAW_ALLOCATE(gg,(nrad))
- + - + -
+ ]
2665 [ + + ]: 291264 : do ispden=1,nspden_updn
2666 [ + + ]: 1683712 : do ilm=1,lm_size_eff
2667 [ + + ]: 1539200 : if (lmselect(ilm)) then
2668 [ + + ]: 1664570048 : do ir=1,nrad
2669 : 1663183360 : ff(ir)=rho1_(2*ir-1,ilm,ispden)
2670 : 1664570048 : gg(ir)=rho1_(2*ir ,ilm,ispden)
2671 : : end do
2672 : 1386688 : call nderiv_gen(drho1(:,1),ff,pawrad)
2673 : 1386688 : call nderiv_gen(drho1(:,2),gg,pawrad)
2674 [ + + ]: 1663183360 : ff(2:nrad)=ff(2:nrad)/pawrad%rad(2:nrad)
2675 [ + + ]: 1663183360 : gg(2:nrad)=gg(2:nrad)/pawrad%rad(2:nrad)
2676 : 1386688 : call pawrad_deducer0(ff,nrad,pawrad)
2677 : 1386688 : call pawrad_deducer0(gg,nrad,pawrad)
2678 [ + + ]: 5546752 : do ii=1,3
2679 : 4160064 : ylm_ii=pawang%ylmr(ilm,ipts)*pawang%anginit(ii,ipts)
2680 : 4160064 : dylmdr_ii=dylmdr(ii,ipts,ilm)
2681 [ + + ]: 4990936768 : do ir=2,nrad
2682 : 4985390016 : jr=2*ir
2683 : : grho1arr(jr-1,ispden,ii)=grho1arr(jr-1,ispden,ii) &
2684 : 4985390016 : & +drho1(ir,1)*ylm_ii+ff(ir)*dylmdr_ii
2685 : : grho1arr(jr ,ispden,ii)=grho1arr(jr ,ispden,ii) &
2686 : 4989550080 : & +drho1(ir,2)*ylm_ii+gg(ir)*dylmdr_ii
2687 : : end do
2688 : : end do
2689 : : end if
2690 : : end do
2691 : : end do
2692 [ - + ]: 144512 : LIBPAW_DEALLOCATE(ff)
2693 [ - + ]: 144512 : LIBPAW_DEALLOCATE(gg)
2694 : : end if
2695 [ - + ]: 193808 : if (usecore==1) then
2696 [ # # ]: 0 : factor=one;if (nspden_updn==2) factor=half
2697 [ # # ]: 0 : if (cplex_den==1) then
2698 [ # # ]: 0 : do ispden=1,nspden_updn
2699 [ # # ]: 0 : do ii=1,3
2700 : : grho1arr(1:nrad,ispden,ii)=grho1arr(1:nrad,ispden,ii) &
2701 [ # # ]: 0 : & +factor*drho1core(1:nrad,1)*pawang%anginit(ii,ipts)
2702 : : end do
2703 : : end do
2704 : : else
2705 [ # # ]: 0 : do ispden=1,nspden_updn
2706 [ # # ]: 0 : do ii=1,3
2707 [ # # ]: 0 : do ir=1,nrad
2708 : 0 : jr=2*ir
2709 : : grho1arr(jr-1,ispden,ii)=grho1arr(jr-1,ispden,ii) &
2710 : 0 : & +factor*drho1core(ir,1)*pawang%anginit(ii,ipts)
2711 : : grho1arr(jr ,ispden,ii)=grho1arr(jr ,ispden,ii) &
2712 : 0 : & +factor*drho1core(ir,2)*pawang%anginit(ii,ipts)
2713 : : end do
2714 : : end do
2715 : : end do
2716 : : end if
2717 : : end if
2718 [ - + ]: 193808 : LIBPAW_DEALLOCATE(drho1)
2719 : :
2720 : : ! Optionally suppress magnetic part
2721 [ - + ]: 193808 : if(non_magnetic_xc) then
2722 [ # # ]: 0 : do ii=1,3
2723 [ # # # # ]: 0 : if(nspden==2) grho1arr(:,2,ii)=grho1arr(:,1,ii)*half
2724 [ # # # # : 0 : if(nspden==4) grho1arr(:,2:4,ii)=zero
# # ]
2725 : : end do
2726 : : endif
2727 : :
2728 : : ! Apply XC kernel
2729 : : ! Will compute Vxc^(1) as: vxc1 - Nabla .dot. gxc1
2730 : :
2731 : : ! Scaling factor for angular integrals: four_pi x spin_factor
2732 [ + + ]: 193808 : factor_ang_intg=four_pi;if (nspden_updn==1) factor_ang_intg=two_pi
2733 : :
2734 : : ! A- NON POLARIZED SYSTEMS
2735 : : if (nspden_updn==1) then
2736 : :
2737 [ + + ]: 235820208 : do ir=1,nrad
2738 : 235628640 : jr=cplex_den*(ir-1)+1 ; kr=cplex_vxc*(ir-1)+1
2739 : :
2740 [ + + + + ]: 1649400480 : g0(:)=kxc(ir,ipts,5:7) ; g1(:)=grho1arr(jr,1,1:3)
2741 [ + + ]: 942514560 : grho_grho1=dot_product(g0,g1)
2742 : 235628640 : coeff_grho=kxc(ir,ipts,3)*rho1_updn(jr,1)+kxc(ir,ipts,4)*grho_grho1
2743 : 235628640 : vxc1_updn(kr,ipts,1)=kxc(ir,ipts,1)*rho1_updn(jr,1)+kxc(ir,ipts,3)*grho_grho1
2744 [ + + ]: 942514560 : gxc1r(:,1)=g1(:)*kxc(ir,ipts,2)+g0(:)*coeff_grho
2745 : : !Accumulate gxc1_lm moments as Intg[gxc1(omega).Ylm(omega).d_omega]
2746 [ + + ]: 4005686880 : do ilm=1,pawang%ylm_size
2747 : 3770058240 : ylm_ii=pawang%ylmr(ilm,ipts)*pawang%angwgth(ipts)*factor_ang_intg
2748 [ + + ]: 15315861600 : do ii=1,3
2749 : 15080232960 : gxc1(kr,ii,ilm,1)=gxc1(ir,ii,ilm,1)+gxc1r(ii,1)*ylm_ii
2750 : : end do
2751 : : end do
2752 [ + + ]: 235820208 : if (cplex_vxc==2) then
2753 [ + - ]: 174994560 : if (cplex_den==2) then
2754 [ + + ]: 699978240 : g1im(:)=grho1arr(jr+1,1,1:3)
2755 [ + + ]: 699978240 : grho_grho1im=dot_product(g0,g1im)
2756 : 174994560 : coeff_grhoim=kxc(ir,ipts,3)*rho1_updn(jr+1,1)+kxc(ir,ipts,4)*grho_grho1im
2757 : 174994560 : vxc1_updn(kr+1,ipts,1)=kxc(ir,ipts,1)*rho1_updn(jr+1,1)+kxc(ir,ipts,3)*grho_grho1im
2758 [ + + ]: 699978240 : gxc1i(:,1)=g1im(:)*kxc(ir,ipts,2)+g0(:)*coeff_grhoim
2759 : : !Accumulate gxc1_lm moments as Intg[gxc1(omega).Ylm(omega).d_omega]
2760 [ + + ]: 2974907520 : do ilm=1,pawang%ylm_size
2761 : 2799912960 : ylm_ii=pawang%ylmr(ilm,ipts)*pawang%angwgth(ipts)*factor_ang_intg
2762 [ + + ]: 11374646400 : do ii=1,3
2763 : 11199651840 : gxc1(kr+1,ii,ilm,1)=gxc1(kr+1,ii,ilm,1)+gxc1i(ii,1)*ylm_ii
2764 : : end do
2765 : : end do
2766 : : else
2767 [ # # ]: 0 : vxc1_updn(kr+1,ipts,1)=zero ; gxc1i(:,1)=zero
2768 : : end if
2769 : : end if
2770 : : end do ! ir
2771 : :
2772 : : ! B- POLARIZED SYSTEMS (COLLINEAR)
2773 : : else ! nspden_updn==2
2774 : :
2775 [ + + ]: 1862560 : do ir=1,nrad
2776 : 1860320 : jr=cplex_den*(ir-1)+1 ; kr=cplex_vxc*(ir-1)+1
2777 : :
2778 : 1860320 : rho1_up=rho1_updn(jr,2);rho1_dn=rho1_updn(jr,1)-rho1_up
2779 : 1860320 : g0_up(1)=kxc(ir,ipts,15);g0_dn(1)=kxc(ir,ipts,14)-kxc(ir,ipts,15)
2780 : 1860320 : g0_up(2)=kxc(ir,ipts,17);g0_dn(2)=kxc(ir,ipts,16)-kxc(ir,ipts,17)
2781 : 1860320 : g0_up(3)=kxc(ir,ipts,19);g0_dn(3)=kxc(ir,ipts,18)-kxc(ir,ipts,19)
2782 [ + + + + ]: 13022240 : g1_up(:)=grho1arr(jr,2,:);g1_dn(:)=grho1arr(jr,1,:)-grho1arr(jr,2,:)
2783 [ + + + + ]: 13022240 : g0(:)=g0_up(:)+g0_dn(:);g1(:)=g1_up(:)+g1_dn(:)
2784 [ + + ]: 7441280 : grho_grho1_up=dot_product(g0_up,g1_up)
2785 [ + + ]: 7441280 : grho_grho1_dn=dot_product(g0_dn,g1_dn)
2786 [ + + ]: 7441280 : grho_grho1 =dot_product(g0,g1)
2787 : : coeff_grho_corr=kxc(ir,ipts,11)*rho1_up &
2788 : : & +kxc(ir,ipts,12)*rho1_dn &
2789 : 1860320 : & +kxc(ir,ipts,13)*grho_grho1
2790 : : coeff_grho_up=kxc(ir,ipts,6)*rho1_up &
2791 : 1860320 : & +kxc(ir,ipts,8)*grho_grho1_up
2792 : : coeff_grho_dn=kxc(ir,ipts,7)*rho1_dn &
2793 : 1860320 : & +kxc(ir,ipts,9)*grho_grho1_dn
2794 : : vxc1_updn(kr,ipts,1)=kxc(ir,ipts, 1)*rho1_up &
2795 : : & +kxc(ir,ipts, 2)*rho1_dn &
2796 : : & +kxc(ir,ipts, 6)*grho_grho1_up &
2797 : 1860320 : & +kxc(ir,ipts,11)*grho_grho1
2798 : : vxc1_updn(kr,ipts,2)=kxc(ir,ipts, 3)*rho1_dn &
2799 : : & +kxc(ir,ipts, 2)*rho1_up &
2800 : : & +kxc(ir,ipts, 7)*grho_grho1_dn &
2801 : 1860320 : & +kxc(ir,ipts,12)*grho_grho1
2802 : : gxc1r(:,1)=(kxc(ir,ipts,4)+kxc(ir,ipts,10))*g1_up(:) &
2803 : : & +kxc(ir,ipts,10) *g1_dn(:) &
2804 : : & +coeff_grho_up *g0_up(:) &
2805 [ + + ]: 7441280 : & +coeff_grho_corr *g0(:)
2806 : : gxc1r(:,2)=(kxc(ir,ipts,5)+kxc(ir,ipts,10))*g1_dn(:) &
2807 : : & +kxc(ir,ipts,10) *g1_up(:) &
2808 : : & +coeff_grho_dn *g0_dn(:) &
2809 [ + + ]: 7441280 : & +coeff_grho_corr *g0(:)
2810 : : !Accumulate gxc1_lm moments as Intg[gxc1(omega).Ylm(omega).d_omega]
2811 [ + + ]: 5580960 : do ispden=1,nspden_updn
2812 [ + + ]: 139524000 : do ilm=1,pawang%ylm_size
2813 : 133943040 : ylm_ii=pawang%ylmr(ilm,ipts)*pawang%angwgth(ipts)*factor_ang_intg
2814 [ + + ]: 539492800 : do ii=1,3
2815 : 535772160 : gxc1(kr,ii,ilm,ispden)=gxc1(kr,ii,ilm,ispden)+gxc1r(ii,ispden)*ylm_ii
2816 : : end do
2817 : : end do
2818 : : end do
2819 : :
2820 [ + - ]: 1862560 : if (cplex_vxc==2) then
2821 [ + - ]: 1860320 : if (cplex_den==2) then
2822 : 1860320 : rho1im_up=rho1_updn(jr+1,2);rho1im_dn=rho1_updn(jr+1,1)-rho1im_up
2823 [ + + + + ]: 13022240 : g1im_up(:)=grho1arr(jr+1,2,:);g1im_dn(:)=grho1arr(jr+1,1,:)-grho1arr(jr+1,2,:)
2824 [ + + ]: 7441280 : g1im(:)=g1im_up(:)+g1im_dn(:)
2825 [ + + ]: 7441280 : grho_grho1im_up=dot_product(g0_up,g1im_up)
2826 [ + + ]: 7441280 : grho_grho1im_dn=dot_product(g0_dn,g1im_dn)
2827 [ + + ]: 7441280 : grho_grho1im =dot_product(g0,g1im)
2828 : : coeff_grhoim_corr=kxc(ir,ipts,11)*rho1im_up &
2829 : : & +kxc(ir,ipts,12)*rho1im_dn &
2830 : 1860320 : & +kxc(ir,ipts,13)*grho_grho1im
2831 : : coeff_grhoim_up=kxc(ir,ipts,6)*rho1im_up &
2832 : 1860320 : & +kxc(ir,ipts,8)*grho_grho1im_up
2833 : : coeff_grhoim_dn=kxc(ir,ipts,7)*rho1im_dn &
2834 : 1860320 : & +kxc(ir,ipts,9)*grho_grho1im_dn
2835 : : vxc1_updn(kr+1,ipts,1)=kxc(ir,ipts, 1)*rho1im_up &
2836 : : & +kxc(ir,ipts, 2)*rho1im_dn &
2837 : : & +kxc(ir,ipts, 6)*grho_grho1im_up &
2838 : 1860320 : & +kxc(ir,ipts,11)*grho_grho1im
2839 : : vxc1_updn(kr+1,ipts,2)=kxc(ir,ipts, 3)*rho1im_dn &
2840 : : & +kxc(ir,ipts, 2)*rho1im_up &
2841 : : & +kxc(ir,ipts, 7)*grho_grho1im_dn &
2842 : 1860320 : & +kxc(ir,ipts,12)*grho_grho1im
2843 : : gxc1i(:,1)=(kxc(ir,ipts,4)+kxc(ir,ipts,10))*g1im_up(:) &
2844 : : & +kxc(ir,ipts,10) *g1im_dn(:) &
2845 : : & +coeff_grhoim_up *g0_up(:) &
2846 [ + + ]: 7441280 : & +coeff_grhoim_corr *g0(:)
2847 : : gxc1i(:,2)=(kxc(ir,ipts,5)+kxc(ir,ipts,10))*g1im_dn(:) &
2848 : : & +kxc(ir,ipts,10) *g1im_up(:) &
2849 : : & +coeff_grhoim_dn *g0_dn(:) &
2850 [ + + ]: 7441280 : & +coeff_grhoim_corr *g0(:)
2851 : : !Accumulate gxc1_lm moments as Intg[gxc1(omega).Ylm(omega).d_omega]
2852 [ + + ]: 5580960 : do ispden=1,nspden_updn
2853 [ + + ]: 139524000 : do ilm=1,pawang%ylm_size
2854 : 133943040 : ylm_ii=pawang%ylmr(ilm,ipts)*pawang%angwgth(ipts)*factor_ang_intg
2855 [ + + ]: 539492800 : do ii=1,3
2856 : 535772160 : gxc1(kr+1,ii,ilm,ispden)=gxc1(kr+1,ii,ilm,ispden)+gxc1i(ii,ispden)*ylm_ii
2857 : : end do
2858 : : end do
2859 : : end do
2860 : : else
2861 [ # # ]: 0 : vxc1_updn(kr+1,ipts,1:2)=zero ; gxc1i(:,1:2)=zero
2862 : : end if
2863 : : end if
2864 : :
2865 : : end do ! ir
2866 : :
2867 : : end if ! nspden_updn
2868 : :
2869 [ - + ]: 193808 : LIBPAW_DEALLOCATE(grho1arr)
2870 : :
2871 : : end if ! LDA or GGA
2872 : :
2873 : : ! ----- End of the loop on npts (angular part)
2874 : : end do
2875 : :
2876 : : ! Deallocate memory
2877 [ + + - + ]: 6288 : if (xclevel==2.and.usecore==1) then
2878 [ # # ]: 0 : LIBPAW_DEALLOCATE(drho1core)
2879 : : end if
2880 [ - + ]: 6288 : if (nspden==4) then
2881 [ # # ]: 0 : LIBPAW_POINTER_DEALLOCATE(rho1_updn)
2882 [ # # ]: 0 : LIBPAW_POINTER_DEALLOCATE(mag)
2883 : : end if
2884 : :
2885 : : end if ! option/=3
2886 : :
2887 : : !----------------------------------------------------------------------
2888 : : !----- If GGA, modify 1st-order potential with term from density gradient
2889 : : !----------------------------------------------------------------------
2890 [ + + + - : 7752 : if (xclevel==2.and.ixc/=13.and.option/=3) then
+ + ]
2891 : : ! Compute divergence of gxc1 and substract it from Vxc1
2892 : :
2893 : : ! Need to multiply gxc1 by 2 in the non-polarised case
2894 [ + + ]: 1284 : factor=one;if (nspden_updn==1) factor=two
2895 : :
2896 [ - + + - : 3852 : LIBPAW_ALLOCATE(dgxc1,(nrad))
+ - + - -
+ - + ]
2897 [ - + + - : 2568 : LIBPAW_ALLOCATE(gg,(nrad))
- + - + -
+ ]
2898 [ + + ]: 2624 : do ispden=1,nspden_updn
2899 [ + + ]: 26304 : do ilm=1,pawang%ylm_size
2900 [ + + ]: 96060 : do ii=1,3
2901 [ + + ]: 82617888 : do ir=1,nrad
2902 : 82546848 : jr=cplex_vxc*(ir-1)+1
2903 : 82617888 : gg(ir)=gxc1(jr,ii,ilm,ispden)
2904 : : end do
2905 : 71040 : call nderiv_gen(dgxc1,gg,pawrad)
2906 [ + + ]: 82546848 : gg(2:nrad)=gg(2:nrad)/pawrad%rad(2:nrad)
2907 : 71040 : call pawrad_deducer0(gg,nrad,pawrad)
2908 [ + + ]: 9773824 : do ipts=1,npts
2909 : 9679104 : ylm_ii=pawang%ylmr(ilm,ipts)*pawang%anginit(ii,ipts)
2910 : 9679104 : dylmdr_ii=dylmdr(ii,ipts,ilm)
2911 [ + + ]: 11721753984 : do ir=1,nrad
2912 : 11712003840 : jr=cplex_vxc*(ir-1)+1
2913 : : vxc1_(jr,ipts,ispden)=vxc1_(jr,ipts,ispden) &
2914 : 11721682944 : & -factor*(dgxc1(ir)*ylm_ii+gg(ir)*dylmdr_ii)
2915 : : end do
2916 : : end do ! ipts
2917 : : end do ! ii
2918 : : end do ! ilm
2919 : : end do ! ispden
2920 [ + + ]: 1284 : if (cplex_vxc==2) then
2921 [ + + ]: 1992 : do ispden=1,nspden_updn
2922 [ + + ]: 20616 : do ilm=1,pawang%ylm_size
2923 [ + + ]: 75520 : do ii=1,3
2924 [ + + ]: 63946080 : do ir=1,nrad
2925 : 63946080 : gg(ir)=gxc1(2*ir,ii,ilm,ispden)
2926 : : end do
2927 : 55872 : call nderiv_gen(dgxc1,gg,pawrad)
2928 [ + + ]: 63890208 : gg(2:nrad)=gg(2:nrad)/pawrad%rad(2:nrad)
2929 : 55872 : call pawrad_deducer0(gg,nrad,pawrad)
2930 [ + + ]: 7387392 : do ipts=1,npts
2931 : 7312896 : ylm_ii=pawang%ylmr(ilm,ipts)*pawang%anginit(ii,ipts)
2932 : 7312896 : dylmdr_ii=dylmdr(ii,ipts,ilm)
2933 [ + + ]: 8808936768 : do ir=1,nrad
2934 : : vxc1_(2*ir,ipts,ispden)=vxc1_(2*ir,ipts,ispden) &
2935 : 8808880896 : & -factor*(dgxc1(ir)*ylm_ii+gg(ir)*dylmdr_ii)
2936 : : end do
2937 : : end do ! ipts
2938 : : end do ! ii
2939 : : end do ! ilm
2940 : : end do ! ispden
2941 : : end if ! cplex_vxc
2942 [ - + ]: 1284 : LIBPAW_DEALLOCATE(dgxc1)
2943 [ - + ]: 1284 : LIBPAW_DEALLOCATE(gg)
2944 : :
2945 : : end if ! GGA
2946 : :
2947 : : ! ----------------------------------------------------------------------
2948 : : ! ----- If non-collinear, rotate back potential according to magnetization
2949 : : ! ----------------------------------------------------------------------
2950 [ + + - + ]: 7752 : if (option/=3.and.nspden==4) then
2951 : : ! Use of C pointers to avoid copies (when ISO C bindings are available)
2952 : : ! %@1$ xlf v15 compiler requires a auxilliary cptr variable
2953 : : #ifdef LIBPAW_ISO_C_BINDING
2954 : 0 : cptr=c_loc(vxc1_updn(1,1,1))
2955 [ # # ]: 0 : call c_f_pointer(cptr,vxc1_diag,shape=[cplex_vxc*nrad*npts,nspden_updn])
2956 : 0 : cptr=c_loc(vxc1_(1,1,1))
2957 [ # # ]: 0 : call c_f_pointer(cptr,vxc1_nc,shape=[cplex_vxc*nrad*npts,nspden])
2958 : 0 : cptr=c_loc(vxc(1,1,1))
2959 [ # # ]: 0 : call c_f_pointer(cptr,vxc_,shape=[nrad*npts,nspden])
2960 : 0 : cptr=c_loc(kxc(1,1,1))
2961 [ # # ]: 0 : call c_f_pointer(cptr,kxc_,shape=[nrad*npts,3])
2962 : 0 : cptr=c_loc(kxc(1,1,nkxc-2))
2963 [ # # ]: 0 : call c_f_pointer(cptr,mag,shape=[nrad*npts,3])
2964 : : #else
2965 : : LIBPAW_ALLOCATE(vxc1_diag,(cplex_vxc*nrad*npts,nspden_updn))
2966 : : LIBPAW_ALLOCATE(vxc1_nc,(cplex_vxc*nrad*npts,nspden))
2967 : : LIBPAW_ALLOCATE(vxc_,(nrad*npts,nspden))
2968 : : LIBPAW_ALLOCATE(kxc_,(nrad*npts,3))
2969 : : LIBPAW_ALLOCATE(mag,(nrad*npts,3))
2970 : : vxc1_diag=reshape(vxc1_updn,[cplex_vxc*nrad*npts,nspden_updn])
2971 : : vxc_=reshape(vxc(1:cplex_vxc*nrad,1:npts,1:nspden),[cplex_vxc*nrad*npts,nspden])
2972 : : kxc_=reshape(kxc(1:nrad,1:npts,1:3),[nrad*npts,3])
2973 : : mag=reshape(kxc(1:nrad,1:npts,nkxc-2:nkxc),[nrad*npts,3])
2974 : : #endif
2975 : : !Should use cplex_den and cplex_vxc
2976 : 0 : call pawxc_rotate_back_mag_dfpt(vxc1_diag,vxc1_nc,vxc_,kxc_,rho1_nc,mag,nrad*npts)
2977 : : #ifndef LIBPAW_ISO_C_BINDING
2978 : : vxc1_=reshape(vxc1_nc,[cplex_vxc*nrad,npts,nspden])
2979 : : LIBPAW_DEALLOCATE(vxc1_diag)
2980 : : LIBPAW_DEALLOCATE(vxc1_nc)
2981 : : LIBPAW_DEALLOCATE(vxc_)
2982 : : LIBPAW_DEALLOCATE(kxc_)
2983 : : LIBPAW_DEALLOCATE(mag)
2984 : : #endif
2985 [ # # ]: 0 : LIBPAW_POINTER_DEALLOCATE(rho1_nc)
2986 [ # # ]: 0 : LIBPAW_POINTER_DEALLOCATE(vxc1_updn)
2987 : : end if
2988 : :
2989 : : !----------------------------------------------------------------------
2990 : : !----- Accumulate and store 2nd-order change of XC energy
2991 : : !----------------------------------------------------------------------
2992 [ + + ]: 7752 : if (option/=1) then
2993 : :
2994 : : ! Do loop on the angular part (theta,phi)
2995 [ + + ]: 630596 : do ipts=1,npts
2996 : :
2997 : : ! Copy the input 1st-order density for this (theta,phi)
2998 [ + + + + ]: 1394178096 : rho1arr(:,:)=zero
2999 [ + + ]: 626544 : if (usexcnhat< 1) rho1_=>rhor1
3000 [ + + ]: 626544 : if (usexcnhat>=1) rho1_=>rhohat1
3001 [ + + ]: 1658736 : do ispden=1,nspden
3002 [ + + ]: 11009904 : do ilm=1,lm_size_eff
3003 [ + + ]: 9351168 : if (lmselect(ilm)) rho1arr(:,ispden)=rho1arr(:,ispden) &
3004 [ + - + + : 23941433616 : & +rho1_(:,ilm,ispden)*pawang%ylmr(ilm,ipts)
+ + ]
3005 : : end do
3006 : : end do
3007 [ - + ]: 626544 : if (usecore==1) then
3008 [ # # ]: 0 : rho1arr(:,1)=rho1arr(:,1)+corexc1(:)
3009 [ # # # # ]: 0 : if (nspden==2) rho1arr(:,2)=rho1arr(:,2)+half*corexc1(:)
3010 : : end if
3011 : :
3012 : : ! ----- Calculate d2Exc=Int[Vxc^(1)^*(r).n^(1)(r).dr]
3013 [ - + + - : 1879632 : LIBPAW_ALLOCATE(ff,(nrad))
+ - + - -
+ - + -
+ ]
3014 [ + + ]: 626544 : if (need_impart) then
3015 [ - + + - : 451200 : LIBPAW_ALLOCATE(gg,(nrad))
- + - + -
+ ]
3016 : : end if
3017 : :
3018 : : ! COLLINEAR MAGNETISM
3019 [ + - ]: 626544 : if (nspden/=4) then
3020 [ + + + - ]: 626544 : if (cplex_vxc==1.and.cplex_den==1) then ! cplex_vxc==1 and cplex_den==1
3021 [ + + ]: 647545392 : ff(:)=vxc1_(:,ipts,1)*rho1arr(:,nspden)
3022 [ + + + + ]: 497111472 : if (nspden==2) ff(:)=ff(:)+vxc1_(:,ipts,2)*(rho1arr(:,1)-rho1arr(:,2))
3023 [ + + + + ]: 239992272 : if (need_impart) gg(:)=zero
3024 [ + - - + ]: 100512 : else if (cplex_vxc==2.and.cplex_den==2) then ! cplex_vxc==2 and cplex_den==2
3025 [ + + ]: 100512 : if (.not.need_impart) then ! Real part only
3026 [ + + ]: 85294080 : do ir=1,nrad
3027 : 85224480 : jr=2*ir;v11r=vxc1_(jr-1,ipts,1);v11i=vxc1_(jr,ipts,1)
3028 : 85224480 : ro11r=rho1arr(jr-1,nspden);ro11i=rho1arr(jr,nspden)
3029 : 85294080 : ff(ir)=v11r*ro11r+v11i*ro11i
3030 : : end do
3031 [ + + ]: 69600 : if (nspden==2) then
3032 [ + + ]: 798240 : do ir=1,nrad
3033 : 797280 : jr=2*ir;v22r=vxc1_(jr-1,ipts,2);v22i=vxc1_(jr,ipts,2)
3034 : 797280 : ro22r=rho1arr(jr-1,1)-rho1arr(jr-1,2)
3035 : 797280 : ro22i=rho1arr(jr ,1)-rho1arr(jr ,2)
3036 : 798240 : ff(ir)=ff(ir)+v22r*ro22r+v22i*ro22i
3037 : : end do
3038 : : end if
3039 : : else
3040 [ + + ]: 37669152 : do ir=1,nrad ! Real and imaginary parts
3041 : 37638240 : jr=2*ir;v11r=vxc1_(jr-1,ipts,1);v11i=vxc1_(jr,ipts,1)
3042 : 37638240 : ro11r=rho1arr(jr-1,nspden);ro11i=rho1arr(jr,nspden)
3043 : 37638240 : ff(ir)=v11r*ro11r+v11i*ro11i
3044 : 37669152 : gg(ir)=v11r*ro11i-v11i*ro11r
3045 : : end do
3046 [ + + ]: 30912 : if (nspden==2) then
3047 [ + + ]: 798240 : do ir=1,nrad
3048 : 797280 : jr=2*ir;v22r=vxc1_(jr-1,ipts,2);v22i=vxc1_(jr,ipts,2)
3049 : 797280 : ro22r=rho1arr(jr-1,1)-rho1arr(jr-1,2)
3050 : 797280 : ro22i=rho1arr(jr ,1)-rho1arr(jr ,2)
3051 : 797280 : ff(ir)=ff(ir)+v22r*ro22r+v22i*ro22i
3052 : 798240 : gg(ir)=gg(ir)+v22r*ro22i-v22i*ro22r
3053 : : end do
3054 : : end if
3055 : : end if
3056 : : else ! other cases for cplex_vxc and cplex_den
3057 : : v11i=zero;ro11i=zero
3058 [ # # ]: 0 : do ir=1,nrad
3059 : 0 : jr=cplex_den*(ir-1)+1 ; kr=cplex_vxc*(ir-1)+1
3060 [ # # ]: 0 : ro11r=rho1arr(jr,nspden);if (cplex_den==2) ro11i=rho1arr(jr+1,nspden)
3061 [ # # ]: 0 : v11r=vxc1_(kr,ipts,1);if (cplex_vxc==2) v11i=vxc1_(kr+1,ipts,1)
3062 : 0 : ff(ir)=v11r*ro11r+v11i*ro11i
3063 [ # # ]: 0 : if (need_impart) gg(ir)=v11r*ro11i-v11i*ro11r
3064 : : end do
3065 [ # # ]: 0 : if (nspden==2) then
3066 : : v22i=zero;ro22i=zero
3067 [ # # ]: 0 : do ir=1,nrad
3068 : 0 : jr=cplex_den*(ir-1)+1 ; kr=cplex_vxc*(ir-1)+1
3069 : 0 : ro22r=rho1arr(jr,1)-rho1arr(jr,2)
3070 [ # # ]: 0 : if (cplex_den==2) ro22i=rho1arr(jr+1,1)-rho1arr(jr+1,2)
3071 [ # # ]: 0 : v22r=vxc1_(kr,ipts,2);if (cplex_vxc==2) v22i=vxc1_(kr+1,ipts,2)
3072 : 0 : ff(ir)=ff(ir)+v22r*ro22r+v22i*ro22i
3073 : 0 : gg(ir)=gg(ir)+v22r*ro22i-v22i*ro22r
3074 : : end do
3075 : : end if
3076 : : end if ! cplex_vxc and cplex_den
3077 : :
3078 : : ! NON-COLLINEAR MAGNETISM
3079 : : else
3080 [ # # # # ]: 0 : if (cplex_vxc==1.and.cplex_den==1) then ! cplex_vxc==1 and cplex_den==1
3081 : : ff(:)=half*(vxc1_(:,ipts,1)*(rho1arr(:,1)+rho1arr(:,4)) &
3082 : : & +vxc1_(:,ipts,2)*(rho1arr(:,1)-rho1arr(:,4))) &
3083 : : & +vxc1_(:,ipts,3)*rho1arr(:,2) &
3084 [ # # ]: 0 : & -vxc1_(:,ipts,4)*rho1arr(:,3)
3085 [ # # # # ]: 0 : if (need_impart) gg(:)=zero
3086 : : else ! other cases for cplex_vxc and cplex_den
3087 : :
3088 : : ! V is stored as : v^11, v^22, V^12, i.V^21 (each are complex)
3089 : : ! N is stored as : n, m_x, m_y, mZ (each are complex)
3090 [ # # ]: 0 : do ir=1,nrad
3091 : 0 : jr=cplex_den*(ir-1)+1 ; kr=cplex_vxc*(ir-1)+1
3092 : 0 : ro11r= rho1arr(jr,1)+rho1arr(jr,4)
3093 : 0 : ro22r= rho1arr(jr,1)-rho1arr(jr,4)
3094 : 0 : ro12r= rho1arr(jr,2);ro12i=-rho1arr(jr,3)
3095 : 0 : ro21r= rho1arr(jr,2);ro21i= rho1arr(jr,3)
3096 [ # # ]: 0 : if (cplex_den==2) then
3097 : 0 : ro11i=rho1arr(jr+1,1)+rho1arr(jr+1,4)
3098 : 0 : ro22i=rho1arr(jr+1,1)-rho1arr(jr+1,4)
3099 : 0 : ro12r=ro12r+rho1arr(jr+1,3);ro12i=ro12i+rho1arr(jr+1,2)
3100 : 0 : ro21r=ro21r-rho1arr(jr+1,3);ro21i=ro21i+rho1arr(jr+1,2)
3101 : : else
3102 : : ro11i=zero;ro22i=zero
3103 : : end if
3104 : 0 : v11r= vxc1_(kr,ipts,1);v22r= vxc1_(kr,ipts,2)
3105 : 0 : v12r= vxc1_(kr,ipts,3);v21i=-vxc1_(kr,ipts,1)
3106 [ # # ]: 0 : if (cplex_vxc==2) then
3107 : 0 : v11i= vxc1_(kr+1,ipts,1);v22i= vxc1_(kr+1,ipts,2)
3108 : 0 : v12i= vxc1_(kr+1,ipts,3);v21r= vxc1_(kr+1,ipts,1)
3109 : : else
3110 : : v11i=zero;v22i=zero
3111 : : v12i=zero;v21i=zero
3112 : : end if
3113 : : ! Real part
3114 : : ff(ir)=half*(v11r*ro11r+v11i*ro11i+v22r*ro22r+v22i*ro22i &
3115 : 0 : & +v12r*ro12r+v12i*ro12i+v21r*ro21r+v21i*ro21i)
3116 : : ! Imaginary part
3117 [ # # ]: 0 : if (need_impart) &
3118 : : & gg(ir)=half*(v11r*ro11i-v11i*ro11r+v22r*ro22i-v22i*ro22r &
3119 : 0 : & +v12r*ro12i-v12i*ro12r+v21r*ro21i-v21i*ro21r)
3120 : : end do
3121 : : end if ! cplex_vxc and cplex_den
3122 : : end if ! nspden
3123 : :
3124 [ + + ]: 770508624 : ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2
3125 : 626544 : call simp_gen(vxcrho,ff,pawrad)
3126 : 626544 : d2enxc=d2enxc+vxcrho*pawang%angwgth(ipts)
3127 [ - + ]: 626544 : LIBPAW_DEALLOCATE(ff)
3128 : :
3129 [ + + ]: 1257140 : if (need_impart) then
3130 [ + + ]: 277330080 : gg(1:nrad)=gg(1:nrad)*pawrad%rad(1:nrad)**2
3131 : 225600 : call simp_gen(vxcrho,gg,pawrad)
3132 : 225600 : d2enxc_im=d2enxc_im+vxcrho*pawang%angwgth(ipts)
3133 [ - + ]: 225600 : LIBPAW_DEALLOCATE(gg)
3134 : : end if
3135 : :
3136 : : ! ----- End of the loop on npts (angular part)
3137 : : end do
3138 : :
3139 : : end if ! option/=1
3140 : :
3141 : : !Add the four*pi factor of the angular integration
3142 [ + + ]: 7752 : if (option/=1) then
3143 : 4052 : d2enxc=d2enxc*four_pi
3144 [ + + ]: 4052 : if (need_impart) d2enxc_im=d2enxc_im*four_pi
3145 : : end if
3146 : :
3147 : : !Free memory
3148 [ + + ]: 7752 : if (usexcnhat>0) then
3149 [ - + ]: 20 : LIBPAW_DEALLOCATE(rhohat1)
3150 : : end if
3151 [ - + ]: 7752 : LIBPAW_DEALLOCATE(rho1arr)
3152 [ + + ]: 7752 : if (option==2) then
3153 [ - + ]: 2588 : LIBPAW_POINTER_DEALLOCATE(vxc1_)
3154 : : end if
3155 [ + + + + ]: 7752 : if (xclevel==2.and.option/=3) then
3156 [ - + ]: 1284 : LIBPAW_DEALLOCATE(gxc1)
3157 [ - + ]: 1284 : LIBPAW_DEALLOCATE(dylmdr)
3158 : : end if
3159 : :
3160 [ - + - + : 15504 : end subroutine pawxc_dfpt
- + - + -
+ - + - +
- + ]
3161 : : !!***
3162 : :
3163 : : !----------------------------------------------------------------------
3164 : :
3165 : : !!****f* m_pawxc/pawxcsph
3166 : : !! NAME
3167 : : !! pawxcsph
3168 : : !!
3169 : : !! FUNCTION
3170 : : !! Compute XC energy and potential for a spherical density rho(r) given as (up,dn)
3171 : : !! Driver of XC functionals. Only treat collinear spins. LDA and GGA
3172 : : !!
3173 : : !! INPUTS
3174 : : !! exexch= choice of <<<local>>> exact exchange. Active if exexch>0 (only for GGA)
3175 : : !! el_temp=electronic temperature (hartree)
3176 : : !! ixc= choice of exchange-correlation scheme (see above and below)
3177 : : !! nkxc= size of kxc(nrad,nkxc) (XC kernel)
3178 : : !! nrad= dimension of the radial mesh
3179 : : !! nspden=number of spin-density components
3180 : : !! pawrad <type(pawrad_type)>=paw radial mesh and related data
3181 : : !! rho_updn(nrad,lm_size,nspden)=electron density in real space
3182 : : !! up (ispden=1) and down (ispden=2) parts
3183 : : !! If nspden=1, rho_updn(:,:,1) contains (1/2).rho_total
3184 : : !! xclevel= XC functional level
3185 : : !!
3186 : : !! OUTPUT
3187 : : !! exc(nrad)= XC energy density
3188 : : !! tsxc(nrad)= XC entropy energy density
3189 : : !! vxc((nrad,nspden)= XC potential
3190 : : !! === Only if nkxc>0 ===
3191 : : !! kxc(nrad,nkxc)=exchange and correlation kernel (returned only if nkxc/=0)
3192 : : !! Content of Kxc array:
3193 : : !! ===== if LDA
3194 : : !! if nspden==1: kxc(:,1)= d2Exc/drho2
3195 : : !! (kxc(:,2)= d2Exc/drho_up drho_dn)
3196 : : !! if nspden>=2: kxc(:,1)=d2Exc/drho_up drho_up
3197 : : !! kxc(:,2)=d2Exc/drho_up drho_dn
3198 : : !! kxc(:,3)=d2Exc/drho_dn drho_dn
3199 : : !!
3200 : : !! SOURCE
3201 : :
3202 : 243586 : subroutine pawxcsph(exc,tsxc,exexch,el_temp,hyb_mixing,ixc,kxc,nkxc,nrad,nspden,pawrad,rho_updn,vxc,xclevel)
3203 : :
3204 : : !Arguments ------------------------------------
3205 : : !scalars
3206 : : integer,intent(in) :: exexch,ixc,nkxc,nrad,nspden,xclevel
3207 : : real(dp),intent(in) :: el_temp,hyb_mixing
3208 : : type(pawrad_type),intent(in) :: pawrad
3209 : : !arrays
3210 : : real(dp),intent(in) :: rho_updn(nrad,nspden)
3211 : : real(dp),intent(out) :: exc(nrad),tsxc(nrad),kxc(nrad,nkxc),vxc(nrad,nspden)
3212 : :
3213 : : !Local variables-------------------------------
3214 : : !scalars
3215 : : integer :: ir,ispden,ndvxc,nspgrad,nvxcdgr,order
3216 : : integer :: usegradient,uselaplacian,usekden
3217 : : real(dp),parameter :: tol24=tol12*tol12
3218 : : real(dp) :: coeff,grho_tot,grho_up,fact
3219 : : character(len=500) :: msg
3220 : : !arrays
3221 : : real(dp) :: d2vxc(1,1)
3222 : 243586 : real(dp),allocatable :: dff(:),dnexcdn(:,:),dvxcdgr(:,:),dvxci(:,:)
3223 : 243586 : real(dp),allocatable :: grho2(:,:),grho_updn(:,:)
3224 : :
3225 : : ! *************************************************************************
3226 : :
3227 [ - + ]: 243586 : if(nspden>2)then
3228 : : write(msg, '(a,a,a,i0)' )&
3229 : 0 : & 'Only non-spin-polarised or collinear spin-densities are allowed,',ch10,&
3230 : 0 : & 'while the argument nspden=',nspden
3231 : 0 : LIBPAW_BUG(msg)
3232 : : end if
3233 [ - + ]: 243586 : if(nkxc>3)then
3234 : 0 : msg='nkxc>3 not allowed (GGA)!'
3235 : 0 : LIBPAW_ERROR(msg)
3236 : : end if
3237 [ - + ]: 243586 : if(nrad>pawrad%mesh_size)then
3238 : 0 : msg='nrad > mesh size!'
3239 : 0 : LIBPAW_BUG(msg)
3240 : : end if
3241 : :
3242 : : !Compute sizes of arrays and flags
3243 [ + + ]: 243586 : order=1;if (nkxc>0) order=2
3244 [ + + ]: 243586 : nspgrad=0;if (xclevel==2) nspgrad=3*nspden-1
3245 : : call pawxc_size_dvxc_wrapper(ixc,order,nspden,&
3246 : 243586 : & usegradient=usegradient,nvxcgrho=nvxcdgr,ndvxc=ndvxc)
3247 : 243586 : uselaplacian=0 ; usekden=0 !metaGGA contributions are not taken into account here
3248 : :
3249 : : !--------------------------------------------------------------------------
3250 : : !-------------- GGA: computation of the gradient of the density
3251 : : !--------------------------------------------------------------------------
3252 : :
3253 [ - + + - : 974344 : LIBPAW_ALLOCATE(grho2,(nrad,(2*nspden-1)*usegradient))
+ + + - +
- + + - +
- + ]
3254 [ + + ]: 243586 : if (xclevel==2) then
3255 : :
3256 : : ! grho_updn contains the gradient of the radial part
3257 : : ! grho2(:,1:3) contains the squared norm of this gradient (up, dn and total)
3258 [ - + + - : 301496 : LIBPAW_ALLOCATE(grho_updn,(nrad,nspden))
- + + - +
- + - - +
- + ]
3259 : :
3260 : : ! Gradient of radial part of density
3261 [ - + + - : 226122 : LIBPAW_ALLOCATE(dff,(nrad))
+ - + - -
+ - + ]
3262 [ + + ]: 184834 : do ispden=1,nspden
3263 : 109460 : call nderiv_gen(dff,rho_updn(:,ispden),pawrad)
3264 [ + + ]: 114048946 : grho_updn(:,ispden)=dff(:)
3265 : : end do
3266 [ - + ]: 75374 : LIBPAW_DEALLOCATE(dff)
3267 : :
3268 : : ! Squared norm of the gradient
3269 [ + + ]: 81117233 : grho2(:,1)=grho_updn(:,1)**2
3270 [ + + ]: 75374 : if (nspden==2) then
3271 [ + + ]: 32856339 : grho2(:,2)=grho_updn(:,2)**2
3272 [ + + ]: 32856339 : grho2(:,3)=(grho_updn(:,1)+grho_updn(:,2))**2
3273 : : end if
3274 : :
3275 : : end if
3276 : :
3277 : : !--------------------------------------------------------------------------
3278 : : !-------------- Computation of Exc, Vxc (and Kxc)
3279 : : !--------------------------------------------------------------------------
3280 : :
3281 : : !Allocate arrays
3282 [ - + + - : 974344 : LIBPAW_ALLOCATE(dvxci,(nrad,ndvxc))
+ + + - +
- + + - +
- + ]
3283 [ - + + - : 974344 : LIBPAW_ALLOCATE(dvxcdgr,(nrad,nvxcdgr))
+ + + - +
- + + - +
- + ]
3284 : :
3285 : : !Call to main XC driver
3286 : : call pawxc_drivexc_wrapper(hyb_mixing,ixc,order,nrad,nspden,&
3287 : : & usegradient,uselaplacian,usekden,rho_updn,exc,tsxc,vxc,&
3288 : : & nvxcdgr,0,0,ndvxc,0,el_temp,grho2=grho2,vxcgrho=dvxcdgr,&
3289 : 487172 : & dvxc=dvxci,d2vxc=d2vxc,exexch=exexch)
3290 : :
3291 : : !Transfer the XC kernel
3292 [ + + + - ]: 243586 : if (nkxc>0.and.ndvxc>0) then
3293 [ + + - + ]: 418 : if (nkxc==1.and.ndvxc==15) then
3294 [ # # ]: 0 : kxc(1:nrad,1)=half*(dvxci(1:nrad,1)+dvxci(1:nrad,9)+dvxci(1:nrad,10))
3295 [ + + - + ]: 418 : else if (nkxc==3.and.ndvxc==15) then
3296 [ # # ]: 0 : kxc(1:nrad,1)=dvxci(1:nrad,1)+dvxci(1:nrad,9)
3297 [ # # ]: 0 : kxc(1:nrad,2)=dvxci(1:nrad,10)
3298 [ # # ]: 0 : kxc(1:nrad,3)=dvxci(1:nrad,2)+dvxci(1:nrad,11)
3299 [ - + - - ]: 418 : else if (nkxc==7.and.ndvxc==8) then
3300 [ # # ]: 0 : kxc(1:nrad,1)=half*dvxci(1:nrad,1)
3301 [ # # ]: 0 : kxc(1:nrad,2)=half*dvxci(1:nrad,3)
3302 [ # # ]: 0 : kxc(1:nrad,3)=quarter*dvxci(1:nrad,5)
3303 [ # # ]: 0 : kxc(1:nrad,4)=eighth*dvxci(1:nrad,7)
3304 [ - + - - ]: 418 : else if (nkxc==7.and.ndvxc==15) then
3305 [ # # ]: 0 : kxc(1:nrad,1)=half*(dvxci(1:nrad,1)+dvxci(1:nrad,9)+dvxci(1:nrad,10))
3306 [ # # ]: 0 : kxc(1:nrad,2)=half*dvxci(1:nrad,3)+dvxci(1:nrad,12)
3307 [ # # ]: 0 : kxc(1:nrad,3)=quarter*dvxci(1:nrad,5)+dvxci(1:nrad,13)
3308 [ # # ]: 0 : kxc(1:nrad,4)=eighth*dvxci(1:nrad,7)+dvxci(1:nrad,15)
3309 [ - + - - ]: 418 : else if (nkxc==19.and.ndvxc==15) then
3310 [ # # ]: 0 : kxc(1:nrad,1)=dvxci(1:nrad,1)+dvxci(1:nrad,9)
3311 [ # # ]: 0 : kxc(1:nrad,2)=dvxci(1:nrad,10)
3312 [ # # ]: 0 : kxc(1:nrad,3)=dvxci(1:nrad,2)+dvxci(1:nrad,11)
3313 [ # # ]: 0 : kxc(1:nrad,4)=dvxci(1:nrad,3)
3314 [ # # ]: 0 : kxc(1:nrad,5)=dvxci(1:nrad,4)
3315 [ # # ]: 0 : kxc(1:nrad,6)=dvxci(1:nrad,5)
3316 [ # # ]: 0 : kxc(1:nrad,7)=dvxci(1:nrad,6)
3317 [ # # ]: 0 : kxc(1:nrad,8)=dvxci(1:nrad,7)
3318 [ # # ]: 0 : kxc(1:nrad,9)=dvxci(1:nrad,8)
3319 [ # # ]: 0 : kxc(1:nrad,10)=dvxci(1:nrad,12)
3320 [ # # ]: 0 : kxc(1:nrad,11)=dvxci(1:nrad,13)
3321 [ # # ]: 0 : kxc(1:nrad,12)=dvxci(1:nrad,14)
3322 [ # # ]: 0 : kxc(1:nrad,13)=dvxci(1:nrad,15)
3323 : : else ! Other cases
3324 [ + + + + ]: 299596 : kxc(1:nrad,1:nkxc)=zero
3325 [ + + + + ]: 299596 : kxc(1:nrad,1:min(nkxc,ndvxc))=dvxci(1:nrad,1:min(nkxc,ndvxc))
3326 : : end if
3327 [ - + ]: 418 : if (nkxc==7) then
3328 [ # # ]: 0 : kxc(1:nrad,5)=grho_updn(1:nrad,1) ! Not correct
3329 [ # # ]: 0 : kxc(1:nrad,6)=grho_updn(1:nrad,1) ! Not correct
3330 [ # # ]: 0 : kxc(1:nrad,7)=grho_updn(1:nrad,1) ! Not correct
3331 [ - + ]: 418 : else if (nkxc==19) then
3332 [ # # ]: 0 : kxc(1:nrad,14)=grho_updn(1:nrad,1) ! Not correct
3333 [ # # ]: 0 : kxc(1:nrad,15)=grho_updn(1:nrad,2) ! Not correct
3334 [ # # ]: 0 : kxc(1:nrad,16)=grho_updn(1:nrad,1) ! Not correct
3335 [ # # ]: 0 : kxc(1:nrad,17)=grho_updn(1:nrad,2) ! Not correct
3336 [ # # ]: 0 : kxc(1:nrad,18)=grho_updn(1:nrad,1) ! Not correct
3337 [ # # ]: 0 : kxc(1:nrad,19)=grho_updn(1:nrad,2) ! Not correct
3338 : : end if
3339 : : end if
3340 [ - + ]: 243586 : LIBPAW_DEALLOCATE(dvxci)
3341 : :
3342 : : !--------------------------------------------------------------------------
3343 : : !-------------- GGA: gardient corrections
3344 : : !--------------------------------------------------------------------------
3345 : :
3346 [ + + + - ]: 243586 : if (xclevel==2.and.ixc/=13) then
3347 : :
3348 : : ! Compute the derivative of Exc with respect to the (spin-)density,
3349 : : ! or to the norm of the gradient of the (spin-)density,
3350 : : ! Further divided by the norm of the gradient of the (spin-)density
3351 : : ! The different components of dnexcdn will be
3352 : : ! for nspden=1, dnexcdn(:,1)=d(n.exc)/d(n)
3353 : : ! and if xclevel=2, dnexcdn(:,2)=1/2*1/|grad n_up|*d(n.exc)/d(|grad n_up|)
3354 : : ! + 1/|grad n|*d(n.exc)/d(|grad n|)
3355 : : ! (do not forget : |grad n| /= |grad n_up| + |grad n_down|
3356 : : ! for nspden=2, dnexcdn(:,1)=d(n.exc)/d(n_up)
3357 : : ! dnexcdn(:,2)=d(n.exc)/d(n_down)
3358 : : ! and if xclevel=2, dnexcdn(:,3)=1/|grad n_up|*d(n.exc)/d(|grad n_up|)
3359 : : ! dnexcdn(:,4)=1/|grad n_down|*d(n.exc)/d(|grad n_down|)
3360 : : ! dnexcdn(:,5)=1/|grad n|*d(n.exc)/d(|grad n|)
3361 [ - + + - : 301496 : LIBPAW_ALLOCATE(dnexcdn,(nrad,nspgrad))
- + + - +
- + - - +
+ - ]
3362 : : ! LDA term
3363 [ + + + + ]: 114048946 : dnexcdn(:,1:nspden)=vxc(:,1:nspden)
3364 : : ! Additional GGA terms
3365 [ + + ]: 81117233 : do ir=1,nrad
3366 [ + + ]: 227803598 : do ispden=1,3 ! spin_up, spin_down and total spin density
3367 [ + + + + ]: 194905971 : if (nspden==1.and.ispden>=2) exit
3368 : : ! If the norm of the gradient vanishes, then the different terms
3369 : : ! vanishes, but the inverse of the gradient diverges,
3370 : : ! so skip the update.
3371 [ + + ]: 146686365 : if(grho2(ir,ispden)<tol24) then
3372 : 132280 : dnexcdn(ir,ispden+nspden)=zero;cycle
3373 : : end if
3374 : : ! Compute the derivative of n.e_xc wrt the spin up, spin down,
3375 : : ! or total density. In the non-spin-polarized case take the coeff.
3376 : : ! that will be multiplied by the gradient of the total density.
3377 [ + - ]: 146554085 : if (nvxcdgr/=0) then
3378 [ + + ]: 146554085 : if (nspden==1) then
3379 : : ! Definition of dvxcdgr changed in v3.3
3380 [ + - ]: 48150623 : if (nvxcdgr==3) then
3381 : 48150623 : coeff=half*dvxcdgr(ir,1)+dvxcdgr(ir,3)
3382 : : else
3383 : 0 : coeff=half*dvxcdgr(ir,1)
3384 : : end if
3385 [ + - ]: 98403462 : else if (nspden==2)then
3386 [ + - ]: 98403462 : if (nvxcdgr==3) then
3387 : 98403462 : coeff=dvxcdgr(ir,ispden)
3388 [ # # ]: 0 : else if (ispden/=3) then
3389 : 0 : coeff=dvxcdgr(ir,ispden)
3390 : : else if (ispden==3) then
3391 : : coeff=zero
3392 : : end if
3393 : : end if
3394 : : end if
3395 : 227595944 : dnexcdn(ir,ispden+nspden)=coeff
3396 : : end do
3397 : : end do
3398 : :
3399 : : ! Calculate grad(rho)*dnexcdn and put it in grho_updn(:,:)
3400 [ + - ]: 75374 : if (nvxcdgr/=0) then
3401 [ + + ]: 75374 : if(nspden==1)then
3402 [ + + ]: 48260894 : grho_updn(:,1)=grho_updn(:,1)*dnexcdn(:,2)
3403 : : else
3404 [ + + ]: 32856339 : do ir=1,nrad
3405 : 32822253 : grho_up=grho_updn(ir,1);grho_tot=grho_up+grho_updn(ir,2)
3406 : 32822253 : grho_updn(ir,1)=grho_up*dnexcdn(ir,3)+grho_tot*dnexcdn(ir,5)
3407 : 32856339 : grho_updn(ir,2)=(grho_tot-grho_up)*dnexcdn(ir,4)+grho_tot*dnexcdn(ir,5)
3408 : : end do
3409 : : end if
3410 : : end if
3411 [ - + ]: 75374 : LIBPAW_DEALLOCATE(dnexcdn)
3412 : :
3413 : : ! Compute Vxc
3414 [ - + + - : 226122 : LIBPAW_ALLOCATE(dff,(nrad))
+ - + - -
+ - + -
+ ]
3415 [ + + ]: 75374 : fact=one;if (nspden==1) fact=two
3416 [ + + ]: 184834 : do ispden=1,nspden
3417 : 109460 : call nderiv_gen(dff,grho_updn(:,ispden),pawrad)
3418 [ + + ]: 113864112 : vxc(2:nrad,ispden)=vxc(2:nrad,ispden)-fact*(dff(2:nrad)+two*grho_updn(2:nrad,ispden)/pawrad%rad(2:nrad))
3419 : 184834 : call pawrad_deducer0(vxc(:,ispden),nrad,pawrad)
3420 : : end do
3421 [ - + ]: 75374 : LIBPAW_DEALLOCATE(dff)
3422 : :
3423 : : end if ! xclevel==2
3424 : :
3425 : : !--------------------------------------------------------------------------
3426 : : !-------------- Deallocations
3427 : : !--------------------------------------------------------------------------
3428 : :
3429 [ - + ]: 243586 : LIBPAW_DEALLOCATE(grho2)
3430 [ - + ]: 243586 : LIBPAW_DEALLOCATE(dvxcdgr)
3431 [ + + ]: 243586 : if (xclevel==2) then
3432 [ - + ]: 75374 : LIBPAW_DEALLOCATE(grho_updn)
3433 : : end if
3434 : :
3435 [ - + - + ]: 487172 : end subroutine pawxcsph
3436 : : !!***
3437 : :
3438 : : !----------------------------------------------------------------------
3439 : :
3440 : : !!****f* m_pawxc/pawxcsph_dfpt
3441 : : !! NAME
3442 : : !! pawxcsph_dfpt
3443 : : !!
3444 : : !! FUNCTION
3445 : : !! Compute XC 1st-order potential for a 1st-order spherical density rho1(r)
3446 : : !! associated to a spherical density, both given as (up,dn)
3447 : : !! Driver of XC functionals. Only treat collinear spins. LDA and GGA
3448 : : !!
3449 : : !! INPUTS
3450 : : !! cplex_den= if 1, 1st-order densities are REAL, if 2, COMPLEX
3451 : : !! cplex_vxc= if 1, 1st-order XC potential is complex, if 2, COMPLEX
3452 : : !! el_temp=electronic temperature (hartree)
3453 : : !! ixc= choice of exchange-correlation scheme (see above and below)
3454 : : !! nrad= dimension of the radial mesh
3455 : : !! nspden=number of spin-density components
3456 : : !! pawrad <type(pawrad_type)>=paw radial mesh and related data
3457 : : !! rho_updn(nrad,lm_size,nspden)=electron density in real space
3458 : : !! up (ispden=1) and down (ispden=2) parts
3459 : : !! If nspden=1, rho_updn(:,:,1) contains (1/2).rho_total
3460 : : !! rho1_updn(nrad,lm_size,nspden)=electron 1st-order density in real space
3461 : : !! up (ispden=1) and down (ispden=2) parts
3462 : : !! If nspden=1, rho_updn(:,:,1) contains (1/2).rho1_total
3463 : : !! xclevel= XC functional level
3464 : : !!
3465 : : !! OUTPUT
3466 : : !! vxc1((nrad,nspden)= XC 1st-order potential
3467 : : !!
3468 : : !! SOURCE
3469 : :
3470 : :
3471 : : subroutine pawxcsph_dfpt(cplex_den,cplex_vxc,el_temp,ixc,nrad,nspden,pawrad,rho_updn,rho1_updn,vxc1,xclevel)
3472 : :
3473 : : !Arguments ------------------------------------
3474 : : !scalars
3475 : : integer,intent(in) :: cplex_den,cplex_vxc,ixc,nrad,nspden,xclevel
3476 : : type(pawrad_type),intent(in) :: pawrad
3477 : : real(dp),intent(in) :: el_temp
3478 : : !arrays
3479 : : real(dp),intent(in) :: rho_updn(nrad,nspden),rho1_updn(cplex_den*nrad,nspden)
3480 : : real(dp),intent(out) :: vxc1(cplex_vxc*nrad,nspden)
3481 : :
3482 : : !Local variables-------------------------------
3483 : : !scalars
3484 : : integer :: ii,ir,ispden,ivxc,jr,kr,ndvxc,ngrad,nkxc,nvxcdgr,order,usegradient
3485 : : real(dp),parameter :: tol24=tol12*tol12
3486 : : !real(dp) :: coeff_grho_corr,coeff_grho_dn,coeff_grho_up,fact
3487 : : !real(dp) :: grho_grho1,grho_grho1_dn,grho_grho1_up
3488 : : character(len=500) :: msg
3489 : : real(dp),parameter :: hyb_mixing_ = 0.0_dp
3490 : : !arrays
3491 : : integer,parameter :: ikxc(4)=(/1,2,2,3/),irho(4)=(/1,2,1,2/)
3492 : : real(dp),allocatable :: dff(:),dgg(:),dvxcdgr(:,:),dvxc(:,:),exc(:),tsxc(:),ff(:),gg(:)
3493 : : real(dp),allocatable :: grho_updn(:,:),grho1_updn(:,:),grho2(:,:)
3494 : : real(dp),allocatable :: kxc(:,:),vxc(:,:)
3495 : : !real(dp),allocatable :: gxc1i(:,:),gxc1r(:,:),vxc1i(:,:),vxc1r(:,:)
3496 : :
3497 : : ! *************************************************************************
3498 : :
3499 : : if(nspden>2)then
3500 : : write(msg, '(a,a,a,i0)' )&
3501 : : & 'Only non-spin-polarised or collinear spin-densities are allowed,',ch10,&
3502 : : & 'while the argument nspden=',nspden
3503 : : LIBPAW_BUG(msg)
3504 : : end if
3505 : : if(nrad>pawrad%mesh_size)then
3506 : : msg='nrad > mesh size!'
3507 : : LIBPAW_BUG(msg)
3508 : : end if
3509 : :
3510 : : !Compute sizes of arrays and flags
3511 : : order=2 ! We need Kxc
3512 : : ngrad=1;if (xclevel==2) ngrad=2 ! ngrad=1 is for LDAs or LSDs; ngrad=2 is for GGAs
3513 : : nkxc=2*nspden-1;if (xclevel==2) nkxc=15 ! Not correct for nspden=1
3514 : : call pawxc_size_dvxc_wrapper(ixc,order,nspden,usegradient=usegradient,nvxcgrho=nvxcdgr,ndvxc=ndvxc)
3515 : :
3516 : : !--------------------------------------------------------------------------
3517 : : !-------------- GGA: computation of the gradients of the densities
3518 : : !--------------------------------------------------------------------------
3519 : :
3520 : : LIBPAW_ALLOCATE(grho2,(nrad,(2*nspden-1)*usegradient))
3521 : : if (ngrad==2) then
3522 : :
3523 : : LIBPAW_ALLOCATE(grho_updn,(nrad,nspden))
3524 : : LIBPAW_ALLOCATE(grho1_updn,(cplex_den*nrad,nspden))
3525 : :
3526 : : ! Gradient of density
3527 : : LIBPAW_ALLOCATE(dff,(nrad))
3528 : : do ispden=1,nspden
3529 : : call nderiv_gen(dff,rho_updn(:,ispden),pawrad)
3530 : : grho_updn(:,ispden)=dff(:)
3531 : : end do
3532 : : ! Gradient of 1st-order density
3533 : : if (cplex_den==1) then
3534 : : do ispden=1,nspden
3535 : : call nderiv_gen(dff,rho1_updn(:,ispden),pawrad)
3536 : : grho1_updn(:,ispden)=dff(:)
3537 : : end do
3538 : : else
3539 : : LIBPAW_ALLOCATE(ff,(nrad))
3540 : : LIBPAW_ALLOCATE(gg,(nrad))
3541 : : LIBPAW_ALLOCATE(dgg,(nrad))
3542 : : do ispden=1,nspden
3543 : : do ir=1,nrad
3544 : : ff(ir)=rho1_updn(2*ir-1,ispden)
3545 : : gg(ir)=rho1_updn(2*ir ,ispden)
3546 : : end do
3547 : : call nderiv_gen(dff,ff,pawrad)
3548 : : call nderiv_gen(dgg,gg,pawrad)
3549 : : do ir=1,nrad
3550 : : grho1_updn(2*ir-1,ispden)=dff(ir)
3551 : : grho1_updn(2*ir ,ispden)=dgg(ir)
3552 : : end do
3553 : : end do
3554 : : LIBPAW_DEALLOCATE(ff)
3555 : : LIBPAW_DEALLOCATE(gg)
3556 : : LIBPAW_DEALLOCATE(dgg)
3557 : : end if
3558 : : LIBPAW_DEALLOCATE(dff)
3559 : :
3560 : : ! Squared norm of the gradient
3561 : : grho2(:,1)=grho_updn(:,1)**2
3562 : : if (nspden==2) then
3563 : : grho2(:,2)=grho_updn(:,2)**2
3564 : : grho2(:,3)=(grho_updn(:,1)+grho_updn(:,2))**2
3565 : : end if
3566 : :
3567 : : end if
3568 : :
3569 : : !--------------------------------------------------------------------------
3570 : : !-------------- Computation of Kxc (and Exc, Vxc)
3571 : : !--------------------------------------------------------------------------
3572 : :
3573 : : LIBPAW_ALLOCATE(exc,(nrad))
3574 : : LIBPAW_ALLOCATE(tsxc,(nrad))
3575 : : LIBPAW_ALLOCATE(vxc,(nrad,nspden))
3576 : : LIBPAW_ALLOCATE(dvxc,(nrad,ndvxc))
3577 : : LIBPAW_ALLOCATE(dvxcdgr,(nrad,nvxcdgr))
3578 : :
3579 : : !Call to main XC driver
3580 : : call pawxc_drivexc_wrapper(hyb_mixing_,ixc,order,nrad,nspden,usegradient,0,0,&
3581 : : & rho_updn,exc,tsxc,vxc,nvxcdgr,0,0,ndvxc,0,el_temp,&
3582 : : & grho2=grho2,vxcgrho=dvxcdgr,dvxc=dvxc)
3583 : :
3584 : : !Transfer the XC kernel
3585 : : LIBPAW_ALLOCATE(kxc,(nrad,nkxc))
3586 : : if (nkxc>0.and.ndvxc>0) then
3587 : : if (nkxc==1.and.ndvxc==15) then
3588 : : kxc(1:nrad,1)=half*(dvxc(1:nrad,1)+dvxc(1:nrad,9)+dvxc(1:nrad,10))
3589 : : else if (nkxc==3.and.ndvxc==15) then
3590 : : kxc(1:nrad,1)=dvxc(1:nrad,1)+dvxc(1:nrad,9)
3591 : : kxc(1:nrad,2)=dvxc(1:nrad,10)
3592 : : kxc(1:nrad,3)=dvxc(1:nrad,2)+dvxc(1:nrad,11)
3593 : : else if (nkxc==7.and.ndvxc==8) then
3594 : : kxc(1:nrad,1)=half*dvxc(1:nrad,1)
3595 : : kxc(1:nrad,2)=half*dvxc(1:nrad,3)
3596 : : kxc(1:nrad,3)=quarter*dvxc(1:nrad,5)
3597 : : kxc(1:nrad,4)=eighth*dvxc(1:nrad,7)
3598 : : else if (nkxc==7.and.ndvxc==15) then
3599 : : kxc(1:nrad,1)=half*(dvxc(1:nrad,1)+dvxc(1:nrad,9)+dvxc(1:nrad,10))
3600 : : kxc(1:nrad,2)=half*dvxc(1:nrad,3)+dvxc(1:nrad,12)
3601 : : kxc(1:nrad,3)=quarter*dvxc(1:nrad,5)+dvxc(1:nrad,13)
3602 : : kxc(1:nrad,4)=eighth*dvxc(1:nrad,7)+dvxc(1:nrad,15)
3603 : : else if (nkxc==19.and.ndvxc==15) then
3604 : : kxc(1:nrad,1)=dvxc(1:nrad,1)+dvxc(1:nrad,9)
3605 : : kxc(1:nrad,2)=dvxc(1:nrad,10)
3606 : : kxc(1:nrad,3)=dvxc(1:nrad,2)+dvxc(1:nrad,11)
3607 : : kxc(1:nrad,4)=dvxc(1:nrad,3)
3608 : : kxc(1:nrad,5)=dvxc(1:nrad,4)
3609 : : kxc(1:nrad,6)=dvxc(1:nrad,5)
3610 : : kxc(1:nrad,7)=dvxc(1:nrad,6)
3611 : : kxc(1:nrad,8)=dvxc(1:nrad,7)
3612 : : kxc(1:nrad,9)=dvxc(1:nrad,8)
3613 : : kxc(1:nrad,10)=dvxc(1:nrad,12)
3614 : : kxc(1:nrad,11)=dvxc(1:nrad,13)
3615 : : kxc(1:nrad,12)=dvxc(1:nrad,14)
3616 : : kxc(1:nrad,13)=dvxc(1:nrad,15)
3617 : : else ! Other cases
3618 : : kxc(1:nrad,1:nkxc)=zero
3619 : : kxc(1:nrad,1:min(nkxc,ndvxc))=dvxc(1:nrad,1:min(nkxc,ndvxc))
3620 : : end if
3621 : : if (nkxc==7) then
3622 : : kxc(1:nrad,5)=zero ! Not correct
3623 : : kxc(1:nrad,6)=zero ! Not correct
3624 : : kxc(1:nrad,7)=zero ! Not correct
3625 : : else if (nkxc==19) then
3626 : : kxc(1:nrad,14)=zero ! Not correct
3627 : : kxc(1:nrad,15)=zero ! Not correct
3628 : : kxc(1:nrad,16)=zero ! Not correct
3629 : : kxc(1:nrad,17)=zero ! Not correct
3630 : : kxc(1:nrad,18)=zero ! Not correct
3631 : : kxc(1:nrad,19)=zero ! Not correct
3632 : : end if
3633 : : end if
3634 : :
3635 : : LIBPAW_DEALLOCATE(exc)
3636 : : LIBPAW_DEALLOCATE(tsxc)
3637 : : LIBPAW_DEALLOCATE(vxc)
3638 : : LIBPAW_DEALLOCATE(dvxc)
3639 : : LIBPAW_DEALLOCATE(dvxcdgr)
3640 : :
3641 : : !--------------------------------------------------------------------------
3642 : : !-------------- LDA
3643 : : !--------------------------------------------------------------------------
3644 : : if (ngrad==1.or.ixc==13) then
3645 : :
3646 : : do ispden=1,3*nspden-2
3647 : : ivxc=1;if (ispden>2) ivxc=2
3648 : : if (cplex_vxc==1.and.cplex_den==1) then
3649 : : vxc1(:,ivxc)=vxc1(:,ivxc)+kxc(:,ikxc(ii))*rho1_updn(:,irho(ii))
3650 : : else
3651 : : do ir=1,nrad
3652 : : jr=cplex_den*(ir-1);kr=cplex_vxc*(ir-1)
3653 : : do ii=1,1+(cplex_den*cplex_vxc)/4
3654 : : jr=jr+1;kr=kr+1
3655 : : vxc1(kr,ivxc)=vxc1(kr,ivxc)+kxc(ir,ikxc(ii))*rho1_updn(jr,irho(ii))
3656 : : end do
3657 : : end do
3658 : : end if
3659 : : end do
3660 : :
3661 : : ! --------------------------------------------------------------------------
3662 : : ! -------------- GGA
3663 : : ! --------------------------------------------------------------------------
3664 : : else
3665 : :
3666 : : ! FOR NSPDEN=1, should eliminate computation of gxc1i(...), vxc1i(...)
3667 : :
3668 : : ! LIBPAW_ALLOCATE(vxc1r,(nrad,2))
3669 : : ! LIBPAW_ALLOCATE(vxc1i,(nrad,2))
3670 : : ! LIBPAW_ALLOCATE(gxc1r,(nrad,2))
3671 : : ! LIBPAW_ALLOCATE(gxc1i,(nrad,2))
3672 : : ! do ir=1,nrad
3673 : : ! if (cplex_vxc==1) then ! cplex_vxc==1 and (cplex_den==1 or cplex_den=2)
3674 : : ! jr=cplex_den*(ir-1)+1
3675 : : ! grho_grho1_up=grho_updn(ir,1)*grho1_updn(jr,1)
3676 : : ! grho_grho1_dn=grho_updn(ir,2)*grho1_updn(jr,2)
3677 : : ! vxc1r(ir,1)=(kxc(ir, 1)+kxc(ir, 9))*rho1_updn(jr,1)+kxc(ir,10)*rho1_updn(jr,2) &
3678 : : ! & +kxc(ir, 5)*grho_grho1_up+kxc(ir,13)*grho_grho1
3679 : : ! vxc1r(ir,2)=(kxc(ir, 2)+kxc(ir,11))*rho1_updn(jr,2)+kxc(ir,10)*rho1_updn(jr,1) &
3680 : : ! & +kxc(ir, 6)*grho_grho1_dn+kxc(ir,14)*grho_grho1
3681 : : ! coeff_grho_corr=kxc(ir,13)*rho1_updn(jr,1)+kxc(ir,14)*rho1_updn(jr,2)+kxc(ir,15)*grho_grho1
3682 : : ! coeff_grho_up =kxc(ir, 5)*rho1_updn(jr,1)+kxc(ir, 7)*grho_grho1_up
3683 : : ! coeff_grho_dn =kxc(ir, 6)*rho1_updn(jr,2)+kxc(ir, 8)*grho_grho1_dn
3684 : : ! gxc1r(ir,1)=(kxc(ir, 3)+kxc(ir,12))*grho1_updn(jr,1)+kxc(ir,12)*grho1_updn(jr,2) &
3685 : : ! & +coeff_grho_up*grho_updn(jr,1)+coeff_grho_corr*(grho_updn(jr,1)+grho_updn(jr,2))
3686 : : ! gxc1r(ir,2)=(kxc(ir, 4)+kxc(ir,12))*grho1_updn(jr,2)+kxc(ir,12)*grho1_updn(jr,1) &
3687 : : ! & +coeff_grho_dn*grho_updn(jr,2)+coeff_grho_corr*(grho_updn(jr,1)+grho_updn(jr,2))
3688 : : ! end if
3689 : : ! if (grho2(ir,1)<tol24) gxc1r(ir,:)=zero ! ???
3690 : : ! end do
3691 : : !
3692 : : ! ! Apply divergence
3693 : : ! fact=one;if (nspden==1) fact=two ! Is it true ? we force nspden=2 for gxc...
3694 : : ! if (cplex_vxc==1) then
3695 : : ! LIBPAW_ALLOCATE(dff,(nrad))
3696 : : ! do ispden=1,nspden
3697 : : ! call nderiv_gen(dff,gxc1r(:,ispden),pawrad)
3698 : : ! vxc1(2:nrad,ispden)=vxc1r(2:nrad,ispden)-fact*(dff(2:nrad)+two*gxc1r(2:nrad,ispden)/pawrad%rad(2:nrad))
3699 : : ! call pawrad_deducer0(vxc1(:,ispden),nrad,pawrad)
3700 : : ! end do
3701 : : ! LIBPAW_DEALLOCATE(dff)
3702 : : ! else
3703 : : ! LIBPAW_ALLOCATE(dff,(nrad))
3704 : : ! LIBPAW_ALLOCATE(dgg,(nrad))
3705 : : ! LIBPAW_ALLOCATE(ff,(nrad))
3706 : : ! LIBPAW_ALLOCATE(gg,(nrad))
3707 : : ! do ispden=1,nspden
3708 : : ! call nderiv_gen(dff,gxc1r(:,ispden),pawrad)
3709 : : ! call nderiv_gen(dgg,gxc1i(:,ispden),pawrad)
3710 : : ! ff(2:nrad)=vxc1r(2:nrad,ispden)-fact*(dff(2:nrad)+two*gxc1r(2:nrad,ispden)/pawrad%rad(2:nrad))
3711 : : ! gg(2:nrad)=vxc1i(2:nrad,ispden)-fact*(dgg(2:nrad)+two*gxc1i(2:nrad,ispden)/pawrad%rad(2:nrad))
3712 : : ! call pawrad_deducer0(ff,nrad,pawrad)
3713 : : ! call pawrad_deducer0(gg,nrad,pawrad)
3714 : : ! do ir=1,nrad
3715 : : ! vxc1(2*ir-1,ispden)=ff(ir)
3716 : : ! vxc1(2*ir ,ispden)=gg(ir)
3717 : : ! end do
3718 : : ! end do
3719 : : ! LIBPAW_DEALLOCATE(dff)
3720 : : ! LIBPAW_DEALLOCATE(dgg)
3721 : : ! LIBPAW_DEALLOCATE(ff)
3722 : : ! LIBPAW_DEALLOCATE(gg)
3723 : : ! end if
3724 : : !
3725 : : ! LIBPAW_DEALLOCATE(vxc1r)
3726 : : ! LIBPAW_DEALLOCATE(vxc1i)
3727 : : ! LIBPAW_DEALLOCATE(gxc1r)
3728 : : ! LIBPAW_DEALLOCATE(gxc1i)
3729 : :
3730 : : end if ! ngrad==2
3731 : :
3732 : : !--------------------------------------------------------------------------
3733 : : !-------------- Deallocations
3734 : : !--------------------------------------------------------------------------
3735 : :
3736 : : LIBPAW_DEALLOCATE(grho2)
3737 : : LIBPAW_DEALLOCATE(kxc)
3738 : : if (ngrad==2) then
3739 : : LIBPAW_DEALLOCATE(grho_updn)
3740 : : LIBPAW_DEALLOCATE(grho1_updn)
3741 : : end if
3742 : :
3743 : : end subroutine pawxcsph_dfpt
3744 : : !!***
3745 : :
3746 : : !----------------------------------------------------------------------
3747 : :
3748 : : !!****f* m_pawxc/pawxcsphpositron
3749 : : !! NAME
3750 : : !! pawxcsphpositron
3751 : : !!
3752 : : !! FUNCTION
3753 : : !! Compute electron-positron XC energy and potential for spherical densities rho_el(r) rho_pos(r)
3754 : : !! Driver of XC functionals. LDA and GGA
3755 : : !!
3756 : : !! INPUTS
3757 : : !! calctype=type of electron-positron calculation:
3758 : : !! calctype=1 : positron in electronic density
3759 : : !! calctype=2 : electrons in positronic density
3760 : : !! ixcpositron= choice of elctron-positron exchange-correlation scheme
3761 : : !! nrad= dimension of the radial mesh
3762 : : !! pawrad <type(pawrad_type)>=paw radial mesh and related data
3763 : : !! posdensity0_limit=True if we are in the zero positron density limit
3764 : : !! rho(nrad,lm_size)=electron (or positron) density in real space
3765 : : !! Contents depends on calctype value:
3766 : : !! calctype=1: rho is the positronic density
3767 : : !! calctype=2: rho is the electronic density
3768 : : !! rho_ep(nrad,lm_size)=electron (or positron) density in real space
3769 : : !! Contents depends on calctype value:
3770 : : !! calctype=1: rho_ep is the electronic density
3771 : : !! calctype=2: rho_ep is the positronic density
3772 : : !!
3773 : : !! OUTPUT
3774 : : !! fxc(nrad)= electron-positron XC energy per unit volume
3775 : : !! vxce(nrad)= electron-positron XC potential for the electron
3776 : : !! vxcp(nrad)= electron-positron XC potential for the positron
3777 : : !!
3778 : : !! SOURCE
3779 : :
3780 : 58760 : subroutine pawxcsphpositron(calctype,fxc,ixcpositron,nrad,pawrad,posdensity0_limit,rho,rho_ep,vxce,vxcp)
3781 : :
3782 : : !Arguments ------------------------------------
3783 : : !scalars
3784 : : integer,intent(in) :: calctype,ixcpositron,nrad
3785 : : logical,intent(in) :: posdensity0_limit
3786 : : type(pawrad_type),intent(in) :: pawrad
3787 : : !arrays
3788 : : real(dp),intent(in) :: rho(nrad),rho_ep(nrad)
3789 : : real(dp),intent(out) :: fxc(nrad),vxce(nrad),vxcp(nrad)
3790 : :
3791 : : !Local variables-------------------------------
3792 : : !scalars
3793 : : integer :: ngr
3794 : : character(len=500) :: msg
3795 : : !arrays
3796 : 58760 : real(dp),allocatable :: dff(:),rhograd(:),rhograd2(:),vxcegr(:)
3797 : :
3798 : : ! *************************************************************************
3799 : :
3800 [ - + ]: 58760 : if(nrad>pawrad%mesh_size)then
3801 : 0 : msg='nrad > mesh size!'
3802 : 0 : LIBPAW_BUG(msg)
3803 : : end if
3804 : :
3805 : : !Need gradient of density for GGA
3806 [ - + ]: 58760 : ngr=0;if (ixcpositron==3.or.ixcpositron==31) ngr=nrad
3807 [ + - - - : 176280 : LIBPAW_ALLOCATE(rhograd,(ngr))
+ - - + -
+ - + ]
3808 [ + - - - : 117520 : LIBPAW_ALLOCATE(rhograd2,(ngr))
- + - + ]
3809 [ + - - - : 117520 : LIBPAW_ALLOCATE(vxcegr,(ngr))
- + - + ]
3810 [ - + ]: 58760 : if (ngr==nrad) then
3811 [ # # ]: 0 : if (calctype==1) then
3812 : 0 : call nderiv_gen(rhograd,rho_ep,pawrad)
3813 [ # # ]: 0 : else if (calctype==2) then
3814 : 0 : call nderiv_gen(rhograd,rho,pawrad)
3815 : : end if
3816 [ # # ]: 0 : rhograd2(:)=rhograd(:)**2
3817 : : end if
3818 : :
3819 : : !---- Computation of Fxc and Vxc for the positron
3820 : : !rho is the positronic density
3821 : : !rho_ep is the electronic density
3822 [ + + ]: 58760 : if (calctype==1) then
3823 : 23910 : call pawxc_xcpositron_wrapper(fxc,rhograd2,ixcpositron,ngr,nrad,posdensity0_limit,rho_ep,rho,vxce,vxcegr,vxcp)
3824 : :
3825 : : ! ---- Computation of Exc and Vxc for the electron
3826 : : ! rho is the electronic density
3827 : : ! rho_ep is the positronic density
3828 [ + - ]: 34850 : else if (calctype==2) then
3829 : 34850 : call pawxc_xcpositron_wrapper(fxc,rhograd2,ixcpositron,ngr,nrad,posdensity0_limit,rho,rho_ep,vxce,vxcegr,vxcp)
3830 : : end if
3831 : :
3832 [ - + ]: 58760 : LIBPAW_DEALLOCATE(rhograd2)
3833 : :
3834 : : !---- GGA - gradient corrections
3835 [ - + ]: 58760 : if (ngr==nrad) then
3836 [ # # # # : 0 : LIBPAW_ALLOCATE(dff,(nrad))
# # # # #
# # # ]
3837 [ # # ]: 0 : vxcegr(1:nrad)=vxcegr(1:nrad)*rhograd(1:nrad)
3838 : 0 : call nderiv_gen(dff,vxcegr,pawrad)
3839 [ # # ]: 0 : vxcp(2:nrad)=vxcp(2:nrad)-(dff(2:nrad)+two*vxcegr(2:nrad)/pawrad%rad(2:nrad))
3840 : 0 : call pawrad_deducer0(vxcp,nrad,pawrad)
3841 [ # # ]: 0 : LIBPAW_DEALLOCATE(dff)
3842 : : end if
3843 : :
3844 [ - + ]: 58760 : LIBPAW_DEALLOCATE(vxcegr)
3845 [ - + ]: 58760 : LIBPAW_DEALLOCATE(rhograd)
3846 : :
3847 [ - + ]: 58760 : end subroutine pawxcsphpositron
3848 : : !!***
3849 : :
3850 : : !----------------------------------------------------------------------
3851 : :
3852 : : !!****f* m_pawxc/pawxcsum
3853 : : !! NAME
3854 : : !! pawxcsum
3855 : : !!
3856 : : !! FUNCTION
3857 : : !! Compute useful sums of moments of densities needed to compute on-site contributions to XC energy and potential
3858 : : !! First order sums:
3859 : : !! Sum1(1)=Sum_L{Rho1_L(r)**2}
3860 : : !! Sum1(2)=Sum_L{Rho1_L(r)*Rho2_L(r)}
3861 : : !! Sum1(3)=Sum_L{Rho2_L(r)**2}
3862 : : !! With L>0
3863 : : !! Second order sums:
3864 : : !! Sum2(L,1)=Sum_L1_L2{Rho1_L1(r)*Rho1_L1(r)*Gaunt_(L,L1,L2)}
3865 : : !! Sum2(L,2)=Sum_L1_L2{Rho1_L1(r)*Rho2_L2(r)*Gaunt_(L,L1,L2)}
3866 : : !! Sum2(L,3)=Sum_L1_L2{Rho2_L2(r)*Rho2_L2(r)*Gaunt_(L,L1,L2)}
3867 : : !! With L1>0, L2>0
3868 : : !!
3869 : : !! INPUTS
3870 : : !! cplex1=if 1, density Rho1 is REAL, if 2, COMPLEX
3871 : : !! cplex2=if 1, density Rho2 is REAL, if 2, COMPLEX
3872 : : !! cplexsum=if 1, output sums (Sum1 and Sum2) are REAL, if 2, COMPLEX
3873 : : !! lmselect1(lm_size)=select the non-zero LM-moments of input density Rho1
3874 : : !! lmselect2(lm_size)=select the non-zero LM-moments of input density Rho2
3875 : : !! lm_size=number of moments of the density
3876 : : !! nrad=number of radial points
3877 : : !! nsums=number of sums to compute:
3878 : : !! if nsums=1, computes only
3879 : : !! Sum1(1)=Sum_L{Rho1_L(r)*Rho2_L(r)}
3880 : : !! Sum2(L,1)=Sum_L1_L2{Rho1_L1(r)*Rho2_L2(r)*Gaunt_(L,L1,L2)}
3881 : : !! if nsums=3, computes all sums (Sum1(1:3), Sum2(1:3)
3882 : : !! option= 1: compute first order sums
3883 : : !! 2: compute first and second order sums
3884 : : !! pawang <type(pawang_type)>=paw angular mesh and related data
3885 : : !! rho1(cplex1*nrad,lm_size)=moments of first density on each radial point
3886 : : !! rho2(cplex2*nrad,lm_size)=moments of 2nd density on each radial point
3887 : : !!
3888 : : !! OUTPUT
3889 : : !! sum1(cplexsum*nrad,nsums)=first order sums
3890 : : !! === if option>=2
3891 : : !! sum2(cplexsum*nrad,lm_size,nsums)=second order sums
3892 : : !!
3893 : : !! SOURCE
3894 : :
3895 : 106063 : subroutine pawxcsum(cplex1,cplex2,cplexsum,lmselect1,lmselect2,lm_size,nrad,nsums,&
3896 : 106063 : & option,pawang,rho1,rho2,sum1,sum2)
3897 : :
3898 : : !Arguments ------------------------------------
3899 : : !scalars
3900 : : integer,intent(in) :: cplex1,cplex2,cplexsum,lm_size,nrad,nsums,option
3901 : : !arrays
3902 : : logical,intent(in) :: lmselect1(lm_size),lmselect2(lm_size)
3903 : : real(dp),intent(in) :: rho1(cplex1*nrad,lm_size),rho2(cplex2*nrad,lm_size)
3904 : : real(dp),intent(out) :: sum1(cplexsum*nrad,nsums),sum2(cplexsum*nrad,lm_size,nsums*(option/2))
3905 : : type(pawang_type),intent(in) :: pawang
3906 : :
3907 : : !Local variables-------------------------------
3908 : : !scalars
3909 : : integer :: ilm,ilm1,ilm2,ir,i1r,i2r,i3r,isel
3910 : : real(dp) :: fact,ro1i,ro1r,ro2i,ro2r
3911 : : character(len=500) :: msg
3912 : : !arrays
3913 : :
3914 : : !************************************************************************
3915 : :
3916 [ - + ]: 106063 : if(nsums/=1.and.nsums/=3) then
3917 : 0 : msg='nsums must be 1 or 3!'
3918 : 0 : LIBPAW_BUG(msg)
3919 : : end if
3920 [ - + ]: 106063 : if(pawang%gnt_option==0) then
3921 : 0 : msg='pawang%gnt_option=0!'
3922 : 0 : LIBPAW_BUG(msg)
3923 : : end if
3924 : :
3925 [ + - ]: 106063 : if (option>=1) then
3926 : :
3927 : : ! SUM1(r)= Sum_L{Rho1_L(r)*Rho2_L(r)} (L>0)
3928 : : ! --------------------------------------------------
3929 [ + + + + ]: 180767806 : sum1=zero
3930 : :
3931 : : ! ===== All input/output densities are REAL ====
3932 [ + - + + : 106063 : if (cplex1==1.and.cplex2==1.and.cplexsum==1) then
+ - ]
3933 : : ! One sum to compute
3934 [ + + ]: 104671 : if (nsums==1) then
3935 [ + + ]: 684523 : do ilm=2,lm_size
3936 [ + + + - ]: 684523 : if (lmselect1(ilm).and.lmselect2(ilm)) then
3937 [ + + ]: 397181981 : sum1(:,1)=sum1(:,1)+rho1(:,ilm)*rho2(:,ilm)
3938 : : end if
3939 : : end do
3940 : : ! Three sums to compute
3941 : : else
3942 [ + + ]: 408382 : do ilm=2,lm_size
3943 [ + + ]: 381650 : if (lmselect1(ilm)) then
3944 [ + + ]: 234582406 : sum1(:,1)=sum1(:,1)+rho1(:,ilm)**2
3945 [ + + + + ]: 229769610 : if (lmselect2(ilm)) sum1(:,2)=sum1(:,2)+rho1(:,ilm)*rho2(:,ilm)
3946 : : end if
3947 [ + + + + ]: 233400432 : if (lmselect2(ilm)) sum1(:,3)=sum1(:,3)+rho2(:,ilm)**2
3948 : : end do
3949 : : end if
3950 : :
3951 : : ! ===== At least one of Rho1 and Rho2 is COMPLEX ====
3952 : : else
3953 : : ! One sum to compute
3954 [ - + ]: 1392 : if (nsums==1) then
3955 [ + + ]: 12528 : do ilm=2,lm_size
3956 [ + + + - ]: 12528 : if (lmselect1(ilm).and.lmselect2(ilm)) then
3957 [ + + ]: 4749120 : do ir=1,nrad
3958 : 4739328 : i1r=cplex1*(ir-1)+1;i2r=cplex2*(ir-1)+1;i3r=cplexsum*(ir-1)+1
3959 [ - + ]: 4739328 : ro1r=rho1(i1r,ilm);ro1i=zero;if (cplex1==2) ro1i=rho1(i1r+1,ilm)
3960 [ + - ]: 4739328 : ro2r=rho2(i2r,ilm);ro2i=zero;if (cplex2==2) ro2i=rho2(i2r+1,ilm)
3961 : 4739328 : sum1(i3r,1)=sum1(i3r,1)+ro1r*ro2r-ro1i*ro2i
3962 [ + - ]: 4749120 : if (cplexsum==2) sum1(i3r+1,1)=sum1(i3r+1,1)+ro1r*ro2i+ro1i*ro2r
3963 : : end do
3964 : : end if
3965 : : end do
3966 : : ! Three sums to compute
3967 : : else
3968 [ # # ]: 0 : do ilm=2,lm_size
3969 [ # # ]: 0 : do ir=1,nrad
3970 : 0 : i1r=cplex1*(ir-1)+1;i2r=cplex2*(ir-1)+1;i3r=cplexsum*(ir-1)+1
3971 [ # # ]: 0 : ro1r=rho1(i1r,ilm);ro1i=zero;if (cplex1==2) ro1i=rho1(i1r+1,ilm)
3972 [ # # ]: 0 : ro2r=rho2(i2r,ilm);ro2i=zero;if (cplex2==2) ro2i=rho2(i2r+1,ilm)
3973 [ # # ]: 0 : if (lmselect1(ilm)) then
3974 : 0 : sum1(i3r,1)=sum1(i3r,1)+ro1r**2-ro1i**2
3975 [ # # ]: 0 : if (lmselect2(ilm)) sum1(i3r,2)=sum1(i3r,2)+ro1r*ro2r-ro1i*ro2i
3976 : : end if
3977 [ # # ]: 0 : if (lmselect2(ilm)) sum1(i3r,3)=sum1(i3r,3)+ro2r**2-ro2i**2
3978 [ # # ]: 0 : if (cplexsum==2) then
3979 [ # # ]: 0 : if (lmselect1(ilm)) then
3980 : 0 : sum1(i3r+1,1)=sum1(i3r+1,1)+two*ro1r*ro1i
3981 [ # # ]: 0 : if (lmselect2(ilm)) sum1(i3r+1,2)=sum1(i3r+1,2)+ro1r*ro2i+ro1i*ro2r
3982 : : end if
3983 [ # # ]: 0 : if (lmselect2(ilm)) sum1(i3r+1,3)=sum1(i3r+1,3)+two*ro2r*ro2i
3984 : : end if
3985 : : end do
3986 : : end do
3987 : : end if ! nsums
3988 : : end if ! cplex
3989 : :
3990 : : end if !option
3991 : :
3992 [ + + ]: 106063 : if (option>=2) then
3993 : :
3994 : : ! SUM2(r,L)= Sum_L1_L2{Rho1_L1(r)*Rho2_L2(r)*Gaunt_(L,L1,L2)} (L1>0, L2>0)
3995 : : ! --------------------------------------------------
3996 [ + + + + : 139762426 : sum2=zero
+ + ]
3997 : : ! ===== All input/output densities are REAL ====
3998 [ + - + + : 20338 : if (cplex1==1.and.cplex2==1.and.cplexsum==1) then
+ - ]
3999 : : ! One sum to compute
4000 [ + + ]: 18946 : if (nsums==1) then
4001 [ + + ]: 209968 : do ilm=1,lm_size
4002 [ + + ]: 2331856 : do ilm1=2,lm_size
4003 [ + + ]: 2313224 : if (lmselect1(ilm1)) then
4004 [ + + ]: 12990862 : do ilm2=2,ilm1
4005 [ + + ]: 12990862 : if (lmselect2(ilm2)) then
4006 : 9957250 : isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2)
4007 [ + + ]: 9957250 : if (isel>0) then
4008 [ + + ]: 995530 : fact=pawang%realgnt(isel);if (ilm1/=ilm2) fact=two*fact
4009 [ + + ]: 529716444 : sum2(:,ilm,1)=sum2(:,ilm,1)+fact*rho1(:,ilm1)*rho2(:,ilm2)
4010 : : end if
4011 : : end if
4012 : : end do
4013 : : end if
4014 : : end do
4015 : : end do
4016 : : ! Three sums to compute
4017 : : else
4018 [ + + ]: 8164 : do ilm=1,lm_size
4019 [ + + ]: 196250 : do ilm1=2,lm_size
4020 [ + + ]: 196250 : if (lmselect1(ilm1)) then
4021 [ + + ]: 2341550 : do ilm2=2,ilm1
4022 [ + + ]: 2341550 : if (lmselect1(ilm2)) then
4023 : 1970850 : isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2)
4024 [ + + ]: 1970850 : if (isel>0) then
4025 [ + + ]: 158926 : fact=pawang%realgnt(isel);if (ilm1/=ilm2) fact=two*fact
4026 [ + + ]: 169361568 : sum2(:,ilm,1)=sum2(:,ilm,1)+fact*rho1(:,ilm1)*rho1(:,ilm2)
4027 : : end if
4028 : : end if
4029 : : end do
4030 : : end if
4031 : : end do
4032 [ + + ]: 196250 : do ilm1=2,lm_size
4033 [ + + ]: 196250 : if (lmselect2(ilm1)) then
4034 [ + + ]: 2341550 : do ilm2=2,ilm1
4035 [ + + ]: 2341550 : if (lmselect2(ilm2)) then
4036 : 1970850 : isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2)
4037 [ + + ]: 1970850 : if (isel>0) then
4038 [ + + ]: 158926 : fact=pawang%realgnt(isel);if (ilm1/=ilm2) fact=two*fact
4039 [ + + ]: 169361568 : sum2(:,ilm,3)=sum2(:,ilm,3)+fact*rho2(:,ilm1)*rho2(:,ilm2)
4040 : : end if
4041 : : end if
4042 : : end do
4043 : : end if
4044 : : end do
4045 [ + + ]: 196564 : do ilm1=2,lm_size
4046 [ + + ]: 196250 : if (lmselect1(ilm1)) then
4047 [ + + ]: 2341550 : do ilm2=2,ilm1
4048 [ + + ]: 2341550 : if (lmselect2(ilm2)) then
4049 : 1970850 : isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2)
4050 [ + + ]: 1970850 : if (isel>0) then
4051 : 158926 : fact=pawang%realgnt(isel)
4052 [ + + ]: 169361568 : sum2(:,ilm,2)=sum2(:,ilm,2)+fact*rho1(:,ilm1)*rho2(:,ilm2)
4053 : : end if
4054 : : end if
4055 : : end do
4056 [ + + ]: 170950 : if (ilm1<lm_size) then
4057 [ + + ]: 2095300 : do ilm2=ilm1+1,lm_size
4058 [ + + ]: 2095300 : if (lmselect2(ilm2)) then
4059 : 1799900 : isel=pawang%gntselect(ilm,ilm1+ilm2*(ilm2-1)/2)
4060 [ + + ]: 1799900 : if (isel>0) then
4061 : 133768 : fact=pawang%realgnt(isel)
4062 [ + + ]: 142549344 : sum2(:,ilm,2)=sum2(:,ilm,2)+fact*rho1(:,ilm1)*rho2(:,ilm2)
4063 : : end if
4064 : : end if
4065 : : end do
4066 : : end if
4067 : : end if
4068 : : end do
4069 : : end do
4070 : : end if ! nsums
4071 : :
4072 : : ! ===== At least one of Rho1 and Rho2 is COMPLEX ====
4073 : : else
4074 : : ! One sum to compute
4075 [ - + ]: 1392 : if (nsums==1) then
4076 [ + + ]: 13920 : do ilm=1,lm_size
4077 [ + + ]: 114144 : do ilm1=2,lm_size
4078 [ + + ]: 112752 : if (lmselect1(ilm1)) then
4079 [ + + ]: 484704 : do ilm2=2,ilm1
4080 [ + + ]: 484704 : if (lmselect2(ilm2)) then
4081 : 372384 : isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2)
4082 [ + + ]: 372384 : if (isel>0) then
4083 [ + + ]: 50280 : fact=pawang%realgnt(isel);if (ilm1/=ilm2) fact=two*fact
4084 [ + + ]: 24385712 : do ir=1,nrad
4085 : 24335432 : i1r=cplex1*(ir-1)+1;i2r=cplex2*(ir-1)+1;i3r=cplexsum*(ir-1)+1
4086 [ - + ]: 24335432 : ro1r=rho1(i1r,ilm1);ro1i=zero;if (cplex1==2) ro1i=rho1(i1r+1,ilm1)
4087 [ + - ]: 24335432 : ro2r=rho2(i2r,ilm2);ro2i=zero;if (cplex2==2) ro2i=rho2(i2r+1,ilm2)
4088 : 24335432 : sum2(i3r,ilm,1)=sum2(i3r,ilm,1)+fact*(ro1r*ro2r-ro1i*ro2i)
4089 [ + - ]: 24385712 : if (cplexsum==2) sum2(i3r+1,ilm,1)=sum2(i3r+1,ilm,1)+fact*(ro1r*ro2i+ro1i*ro2r)
4090 : : end do
4091 : : end if
4092 : : end if
4093 : : end do
4094 : : end if
4095 : : end do
4096 : : end do
4097 : : ! Three sums to compute
4098 : : else
4099 [ # # ]: 0 : do ilm=2,lm_size
4100 [ # # ]: 0 : do ir=1,nrad
4101 : 0 : i1r=cplex1*(ir-1)+1;i2r=cplex2*(ir-1)+1;i3r=cplexsum*(ir-1)+1
4102 [ # # ]: 0 : do ilm1=2,lm_size
4103 [ # # ]: 0 : if (lmselect1(ilm1)) then
4104 [ # # ]: 0 : ro1r=rho1(i1r,ilm1);ro1i=zero;if (cplex1==2) ro1i=rho1(i1r+1,ilm1)
4105 [ # # ]: 0 : do ilm2=2,ilm1
4106 [ # # ]: 0 : if (lmselect1(ilm2)) then
4107 : 0 : isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2)
4108 [ # # ]: 0 : if (isel>0) then
4109 [ # # ]: 0 : fact=pawang%realgnt(isel);if (ilm1/=ilm2) fact=two*fact
4110 [ # # ]: 0 : ro2r=rho1(i1r,ilm2);ro2i=zero;if (cplex1==2) ro2i=rho1(i1r+1,ilm2)
4111 : 0 : sum2(i3r,ilm,1)=sum2(i3r,ilm,1)+fact*(ro1r*ro2r-ro1i*ro2i)
4112 [ # # ]: 0 : if (cplexsum==2) sum2(i3r+1,ilm,1)=sum2(i3r+1,ilm,1)+fact*(ro1r*ro2i+ro1i*ro2r)
4113 : : end if
4114 : : end if
4115 : : end do
4116 : : end if
4117 : : end do
4118 [ # # ]: 0 : do ilm1=2,lm_size
4119 [ # # ]: 0 : if (lmselect2(ilm1)) then
4120 [ # # ]: 0 : ro1r=rho2(i2r,ilm1);ro1i=zero;if (cplex2==2) ro1i=rho2(i2r+1,ilm1)
4121 [ # # ]: 0 : do ilm2=2,ilm1
4122 [ # # ]: 0 : if (lmselect2(ilm2)) then
4123 : 0 : isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2)
4124 [ # # ]: 0 : if (isel>0) then
4125 [ # # ]: 0 : fact=pawang%realgnt(isel);if (ilm1/=ilm2) fact=two*fact
4126 [ # # ]: 0 : ro2r=rho2(i2r,ilm2);ro2i=zero;if (cplex2==2) ro2i=rho2(i2r+1,ilm2)
4127 : 0 : sum2(i3r,ilm,3)=sum2(i3r,ilm,3)+fact*(ro1r*ro2r-ro1i*ro2i)
4128 [ # # ]: 0 : if (cplexsum==2) sum2(i3r+1,ilm,3)=sum2(i3r+1,ilm,3)+fact*(ro1r*ro2i+ro1i*ro2r)
4129 : : end if
4130 : : end if
4131 : : end do
4132 : : end if
4133 : : end do
4134 [ # # ]: 0 : do ilm1=2,lm_size
4135 [ # # ]: 0 : if (lmselect1(ilm1)) then
4136 [ # # ]: 0 : ro1r=rho1(i1r,ilm1);ro1i=zero;if (cplex1==2) ro1i=rho1(i1r+1,ilm1)
4137 [ # # ]: 0 : do ilm2=2,ilm1
4138 [ # # ]: 0 : if (lmselect2(ilm2)) then
4139 : 0 : isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2)
4140 [ # # ]: 0 : if (isel>0) then
4141 : 0 : fact=pawang%realgnt(isel)
4142 [ # # ]: 0 : ro2r=rho2(i2r,ilm2);ro2i=zero;if (cplex2==2) ro2i=rho2(i2r+1,ilm2)
4143 : 0 : sum2(i3r,ilm,2)=sum2(i3r,ilm,2)+fact*(ro1r*ro2r-ro1i*ro2i)
4144 [ # # ]: 0 : if (cplexsum==2) sum2(i3r+1,ilm,2)=sum2(i3r+1,ilm,2)+fact*(ro1r*ro2i+ro1i*ro2r)
4145 : : end if
4146 : : end if
4147 : : end do
4148 [ # # ]: 0 : if (ilm1<lm_size) then
4149 [ # # ]: 0 : do ilm2=ilm1+1,lm_size
4150 [ # # ]: 0 : if (lmselect2(ilm2)) then
4151 : 0 : isel=pawang%gntselect(ilm,ilm1+ilm2*(ilm2-1)/2)
4152 [ # # ]: 0 : if (isel>0) then
4153 : 0 : fact=pawang%realgnt(isel)
4154 [ # # ]: 0 : ro2r=rho2(i2r,ilm2);ro2i=zero;if (cplex2==2) ro2i=rho2(i2r+1,ilm2)
4155 : 0 : sum2(i3r,ilm,2)=sum2(i3r,ilm,2)+fact*(ro1r*ro2r-ro1i*ro2i)
4156 [ # # ]: 0 : if (cplexsum==2) sum2(i3r+1,ilm,2)=sum2(i3r+1,ilm,2)+fact*(ro1r*ro2i+ro1i*ro2r)
4157 : : end if
4158 : : end if
4159 : : end do
4160 : : end if
4161 : : end if
4162 : : end do
4163 : : end do
4164 : : end do
4165 : : end if ! nsums
4166 : :
4167 : : end if ! cplex
4168 : :
4169 : : end if !option
4170 : :
4171 : 106063 : end subroutine pawxcsum
4172 : : !!***
4173 : :
4174 : : !----------------------------------------------------------------------
4175 : :
4176 : : !!****f* m_pawxc/pawxcm
4177 : : !! NAME
4178 : : !! pawxcm
4179 : : !!
4180 : : !! FUNCTION
4181 : : !! Start from the density or spin-density, and compute xc correlation
4182 : : !! potential and energies inside a paw sphere.
4183 : : !! LDA+GGA - USE A DEVELOPMENT OF THE DENSITY OVER (L,M) MOMENTS
4184 : : !! Driver of XC functionals.
4185 : : !!
4186 : : !! INPUTS
4187 : : !! corexc(nrad)=core density on radial grid
4188 : : !! exexch= choice of <<<local>>> exact exchange. Active if exexch=3 (only for PBE)
4189 : : !! ixc= choice of exchange-correlation scheme
4190 : : !! lm_size=size of density array rhor (see below)
4191 : : !! lmselect(lm_size)=select the non-zero LM-moments of input density rhor
4192 : : !! nhat(nrad,lm_size,nspden)=compensation density
4193 : : !! (total in 1st half and spin-up in 2nd half if nspden=2)
4194 : : !! nkxc=second dimension of the kxc array. If /=0, the exchange-correlation kernel must be computed
4195 : : !! non_magnetic_xc= if true, handle density/potential as non-magnetic (even if it is)
4196 : : !! nrad=size of radial mesh for densities/potentials (might be different from pawrad%mesh_size)
4197 : : !! nspden=number of spin-density components
4198 : : !! option=0 compute both XC energies (direct+double-counting) and potential (and Kernel)
4199 : : !! 1 compute only XC potential (and Kernel)
4200 : : !! 2 compute only XC energies (direct+double-counting)
4201 : : !! 3 compute only XC energy by direct scheme
4202 : : !! 4 compute only XC energy by direct scheme for spherical part of the density
4203 : : !! 5 compute only XC potential (and Kernel) for spherical part of the density
4204 : : !! pawang <type(pawang_type)>=paw angular mesh and related data
4205 : : !! pawrad <type(pawrad_type)>=paw radial mesh and related data
4206 : : !! pawxcdev=order of Vxc development
4207 : : !! rhor(nrad,lm_size,nspden)=electron density in real space in electrons/bohr**3
4208 : : !! (total in 1st half and spin-up in 2nd half if nspden=2)
4209 : : !! usecore= 1 if core density has to be used in Exc/Vxc ; 0 otherwise
4210 : : !! usexcnhat= 0 if compensation density does not have to be used
4211 : : !! 1 if compensation density has to be used in double counting energy term only
4212 : : !! 2 if compensation density (nhat) has to be used in Exc/Vxc and double counting energy term
4213 : : !! xclevel= XC functional level
4214 : : !! xc_denpos= lowest allowed density (usually for the computation of the XC functionals)
4215 : : !! el_temp=electronic temperature (hartree)
4216 : : !!
4217 : : !! OUTPUT
4218 : : !! == if option==0, 2, 3, or 4 ==
4219 : : !! enxc=returned exchange and correlation energy (hartree)
4220 : : !! snxc=returned exchange and correlation entropy (for finite-temperature xc functionals)
4221 : : !! == if option==0 or 2 ==
4222 : : !! enxcdc=returned exchange-cor. contribution to double-counting energy
4223 : : !! == if option==0 or 1 ==
4224 : : !! vxc(nrad,lm_size,nspden)=xc potential
4225 : : !! (spin up in 1st half and spin-down in 2nd half if nspden=2)
4226 : : !! == if nkxc>0 ==
4227 : : !! kxc(nrad,lm_size,nkxc)=xc kernel (see notes below for nkxc)
4228 : : !! == For the TB09 XC functional (modified Becke-Johnson)
4229 : : !! [grho1_over_rho1]=Integral of |Grad(rho^1)|/rho^1 over the augmentation region
4230 : : !! Used to compute the c parameter of the TB09 XC functional
4231 : : !! WARNING: NOT YET IMPLEMENTED!
4232 : : !!
4233 : : !! NOTES
4234 : : !! Content of Kxc array:
4235 : : !! ===== if LDA
4236 : : !! if nspden==1: kxc(:,1)= d2Exc/drho2
4237 : : !! (kxc(:,2)= d2Exc/drho_up drho_dn)
4238 : : !! if nspden>=2: kxc(:,1)= d2Exc/drho_up drho_up
4239 : : !! kxc(:,2)= d2Exc/drho_up drho_dn
4240 : : !! kxc(:,3)= d2Exc/drho_dn drho_dn
4241 : : !! if nspden==4: kxc(:,4:6)= (m_x, m_y, m_z) (magnetization)
4242 : : !! ===== if GGA
4243 : : !! if nspden==1:
4244 : : !! kxc(:,1)= d2Exc/drho2
4245 : : !! kxc(:,2)= 1/|grad(rho)| dExc/d|grad(rho)|
4246 : : !! kxc(:,3)= 1/|grad(rho)| d2Exc/d|grad(rho)| drho
4247 : : !! kxc(:,4)= 1/|grad(rho)| * d/d|grad(rho)| ( 1/|grad(rho)| dExc/d|grad(rho)| )
4248 : : !! kxc(:,5)= gradx(rho)
4249 : : !! kxc(:,6)= grady(rho)
4250 : : !! kxc(:,7)= gradz(rho)
4251 : : !! if nspden>=2:
4252 : : !! kxc(:,1)= d2Exc/drho_up drho_up
4253 : : !! kxc(:,2)= d2Exc/drho_up drho_dn
4254 : : !! kxc(:,3)= d2Exc/drho_dn drho_dn
4255 : : !! kxc(:,4)= 1/|grad(rho_up)| dEx/d|grad(rho_up)|
4256 : : !! kxc(:,5)= 1/|grad(rho_dn)| dEx/d|grad(rho_dn)|
4257 : : !! kxc(:,6)= 1/|grad(rho_up)| d2Ex/d|grad(rho_up)| drho_up
4258 : : !! kxc(:,7)= 1/|grad(rho_dn)| d2Ex/d|grad(rho_dn)| drho_dn
4259 : : !! kxc(:,8)= 1/|grad(rho_up)| * d/d|grad(rho_up)| ( 1/|grad(rho_up)| dEx/d|grad(rho_up)| )
4260 : : !! kxc(:,9)= 1/|grad(rho_dn)| * d/d|grad(rho_dn)| ( 1/|grad(rho_dn)| dEx/d|grad(rho_dn)| )
4261 : : !! kxc(:,10)=1/|grad(rho)| dEc/d|grad(rho)|
4262 : : !! kxc(:,11)=1/|grad(rho)| d2Ec/d|grad(rho)| drho_up
4263 : : !! kxc(:,12)=1/|grad(rho)| d2Ec/d|grad(rho)| drho_dn
4264 : : !! kxc(:,13)=1/|grad(rho)| * d/d|grad(rho)| ( 1/|grad(rho)| dEc/d|grad(rho)| )
4265 : : !! kxc(:,14)=gradx(rho_up)
4266 : : !! kxc(:,15)=gradx(rho_dn)
4267 : : !! kxc(:,16)=grady(rho_up)
4268 : : !! kxc(:,17)=grady(rho_dn)
4269 : : !! kxc(:,18)=gradz(rho_up)
4270 : : !! kxc(:,19)=gradz(rho_dn)
4271 : : !! if nspden==4:
4272 : : !! kxc(:,20:22)= (m_x, m_y, m_z) (magnetization)
4273 : : !!
4274 : : !! SOURCE
4275 : :
4276 : 73390 : subroutine pawxcm(corexc,enxc,enxcdc,snxc,exexch,hyb_mixing,ixc,kxc,lm_size,lmselect,nhat,nkxc,&
4277 : 73390 : & non_magnetic_xc,nrad,nspden,option,pawang,pawrad,pawxcdev,rhor,&
4278 : 73390 : & usecore,usexcnhat,vxc,xclevel,xc_denpos,el_temp,grho1_over_rho1)
4279 : :
4280 : : !Arguments ------------------------------------
4281 : : !scalars
4282 : : integer,intent(in) :: exexch,ixc,lm_size,nkxc,nrad,nspden,option,pawxcdev,usecore
4283 : : integer,intent(in) :: usexcnhat,xclevel
4284 : : logical,intent(in) :: non_magnetic_xc
4285 : : real(dp),intent(in) :: el_temp,hyb_mixing,xc_denpos
4286 : : real(dp),intent(out) :: enxc,snxc,enxcdc
4287 : : real(dp),intent(out),optional :: grho1_over_rho1
4288 : : type(pawang_type),intent(in) :: pawang
4289 : : type(pawrad_type),intent(in) :: pawrad
4290 : : !arrays
4291 : : logical,intent(in) :: lmselect(lm_size)
4292 : : real(dp),intent(in) :: corexc(nrad)
4293 : : real(dp),intent(in) :: nhat(nrad,lm_size,nspden*((usexcnhat+1)/2))
4294 : : real(dp),intent(in) :: rhor(nrad,lm_size,nspden)
4295 : : real(dp),intent(out) :: kxc(nrad,lm_size,nkxc)
4296 : : real(dp),intent(out) :: vxc(nrad,lm_size,nspden)
4297 : :
4298 : : !Local variables-------------------------------
4299 : : !scalars
4300 : : integer :: ilm,ir,ir1,ir2,ispden,iwarn,jr,nspden_updn,nsums
4301 : : real(dp),parameter :: delta=1.d-4
4302 : : real(dp) :: dvxc1,dvxc2,dvxc3,dvxc4,dvxca,dvxcb,dvxcc,dvxcd
4303 : : real(dp) :: fact,invsqfpi,invsqfpi2,sqfpi,sqfpi2,tol_rho
4304 : : character(len=500) :: msg
4305 : : !arrays
4306 : 73390 : real(dp),allocatable :: d1kxc(:,:),d2kxc(:,:),d1vxc(:,:),d2vxc(:,:)
4307 : 73390 : real(dp),allocatable :: exc_(:),sxc_(:),exci(:),tsxci(:),ff(:),gg(:)
4308 : 73390 : real(dp),allocatable :: kxc1(:,:),kxc2(:,:),kxcdn1(:,:),kxcdn2(:,:),kxci(:,:)
4309 : 73390 : real(dp),allocatable :: m_norm_inv(:),rho_(:,:),rhoinv(:,:),rhosph(:,:)
4310 : 73390 : real(dp),allocatable :: v1sum(:,:),v2sum(:,:,:)
4311 : 73390 : real(dp),allocatable :: vxc1(:,:),vxc2(:,:),vxcdn1(:,:),vxcdn2(:,:),vxci(:,:)
4312 : 73390 : real(dp),allocatable,target :: rho_nc(:,:),rho_updn(:,:,:),vxc_diag(:,:),vxc_nc(:,:)
4313 : 73390 : real(dp), LIBPAW_CONTIGUOUS pointer :: mag_nc(:,:),rho_dn(:,:),rho_up(:,:)
4314 : :
4315 : : !************************************************************************
4316 : :
4317 : 73390 : if(nkxc>3) then
4318 : 0 : msg='Kxc not implemented for GGA! Use pawxcdev 0 '
4319 : 0 : LIBPAW_ERROR(msg)
4320 : : end if
4321 [ + + - + ]: 73390 : if(nkxc>0.and.nspden==4) then
4322 : 0 : msg='Kxc not implemented for non-collinear magnetism!'
4323 : 0 : LIBPAW_ERROR(msg)
4324 : : end if
4325 [ + + ]: 73390 : if (option/=1.and.option/=5) then
4326 [ - + ]: 70671 : if (nrad<pawrad%int_meshsz) then
4327 : 0 : msg='When option=0,2,3,4, nrad must be greater than pawrad%int_meshsz!'
4328 : 0 : LIBPAW_BUG(msg)
4329 : : end if
4330 : : end if
4331 : : #if defined LIBPAW_HAVE_LIBXC
4332 [ - + - - : 73390 : if (present(grho1_over_rho1).and.option<4.and.ixc<0) then
- - ]
4333 [ # # ]: 0 : if (libxc_functionals_is_tb09()) then
4334 : 0 : msg='TB09 (mBJ) XC functional not yet implemented for pawxcdev/=0!'
4335 : 0 : LIBPAW_ERROR(msg)
4336 : : end if
4337 : : end if
4338 : : #endif
4339 : :
4340 : : !----------------------------------------------------------------------
4341 : : !----- Initializations
4342 : : !----------------------------------------------------------------------
4343 : :
4344 : : !Arrays dimensions and constants
4345 : 73390 : iwarn=0
4346 : 73390 : nspden_updn=min(nspden,2)
4347 : 73390 : sqfpi=sqrt(four_pi);sqfpi2=half*sqfpi
4348 : 73390 : invsqfpi=one/sqfpi;invsqfpi2=half*invsqfpi
4349 : 73390 : nsums=2*nspden_updn-1
4350 : :
4351 : : !Initializations of output arrays
4352 [ + + ]: 73390 : if (option/=1.and.option/=5) then
4353 : 70671 : enxc=zero
4354 : 70671 : snxc=zero
4355 : : end if
4356 [ + + ]: 73390 : if (option==0.or.option==2) enxcdc=zero
4357 [ + + + + : 1089768206 : if (option/=3.and.option/=4) vxc(:,:,:)=zero
+ + + + ]
4358 [ + + + + : 1223954 : if (nkxc/=0) kxc(:,:,:)=zero
+ + + + ]
4359 : :
4360 [ + + - + ]: 73390 : if (xclevel==0.or.ixc==0) then ! No xc at all is applied (usually for testing)
4361 : 494 : msg='Note that no xc is applied (ixc=0). Returning'
4362 : 494 : LIBPAW_WARNING(msg)
4363 : 494 : return
4364 : : end if
4365 : :
4366 : : !----------------------------------------------------------------------
4367 : : !----- Build several densities
4368 : : !----------------------------------------------------------------------
4369 : :
4370 : : !rho_updn contains the effective density used for XC
4371 : : !with core density and/or compensation density eventually included
4372 : : !-----------------------------------------------------------------
4373 : :
4374 [ - + + - : 364480 : LIBPAW_ALLOCATE(rho_updn,(nrad,lm_size,nspden))
- + + - -
+ + - + -
+ - - + -
+ ]
4375 [ + + + + : 1087993851 : rho_updn(:,:,:)=rhor(:,:,:)
+ + ]
4376 [ + + + + : 235760491 : if (usexcnhat==2) rho_updn(:,:,:)=rho_updn(:,:,:)+nhat(:,:,:)
+ + + + ]
4377 : :
4378 : : !Optionally suppressed magnetic part
4379 [ + + ]: 72896 : if(non_magnetic_xc) then
4380 [ + + + + : 8489008 : if(nspden==2) rho_updn(:,:,2)=rho_updn(:,:,1)*half
+ + ]
4381 [ + + + + : 38608910 : if(nspden==4) rho_updn(:,:,2:4)=zero
+ + + + ]
4382 : : endif
4383 : :
4384 : : !Add core density
4385 [ + + ]: 72896 : if (usecore==1) then
4386 [ + + ]: 56764 : if (nspden==1.or.nspden==4) then
4387 [ + + ]: 64026773 : rho_updn(:,1,1)=rho_updn(:,1,1)+sqfpi*corexc(:)
4388 [ + - ]: 6993 : else if (nspden==2) then
4389 [ + + ]: 5869933 : rho_updn(:,1,1)=rho_updn(:,1,1)+sqfpi*corexc(:)
4390 [ + + ]: 5869933 : rho_updn(:,1,2)=rho_updn(:,1,2)+sqfpi2*corexc(:)
4391 : : end if
4392 : : end if
4393 : :
4394 : : !In case of collinear magnetism, separate up and down contributions
4395 [ + + ]: 72896 : if (nspden==2) then
4396 [ - + + - : 30756 : LIBPAW_ALLOCATE(ff,(nrad))
+ - + - -
+ - + ]
4397 [ + + ]: 223786 : do ilm=1,lm_size
4398 [ + + ]: 145840085 : ff(:)=rho_updn(:,ilm,2)
4399 [ + + ]: 145840085 : rho_updn(:,ilm,2)=rho_updn(:,ilm,1)-ff(:)
4400 [ + + ]: 145850337 : rho_updn(:,ilm,1)=ff(:)
4401 : : end do
4402 [ - + ]: 10252 : LIBPAW_DEALLOCATE(ff)
4403 : : end if
4404 : :
4405 : : !Direct links to rho_up and rho_dn
4406 : 72896 : rho_up => rho_updn(:,:,1)
4407 : 72896 : rho_dn => rho_updn(:,:,nspden_updn)
4408 : :
4409 : : !rhoSPH contains the spherical part of effective density
4410 : : !(including Y00 spherical harmonic)
4411 : : !-----------------------------------------------------------------
4412 [ - + + - : 291584 : LIBPAW_ALLOCATE(rhosph,(nrad,nspden_updn))
- + + - +
- + - - +
- + ]
4413 : :
4414 : : ! Non-magnetic system: rhoSPH(;,1)=(1/2).rhoSPH_total
4415 [ + + ]: 72896 : if (nspden==1) then
4416 [ + + ]: 84618555 : rhosph(:,1)=rho_updn(:,1,1)*invsqfpi2
4417 : :
4418 : : ! Collinear magnetism: rhoSPH = (rhoSPH_up, rhoSPH_dn)
4419 [ + + ]: 13050 : else if (nspden==2) then
4420 [ + + + + ]: 15648394 : rhosph(:,1:2)=rho_updn(:,1,1:2)*invsqfpi
4421 : :
4422 : : ! Non-collinear magnetism: rhoSPH = (rhoSPH_up, rhoSPH_dn)
4423 : : ! obtained by rotating rho_updn
4424 [ + - ]: 2798 : else if (nspden==4) then
4425 [ - + + - : 8394 : LIBPAW_ALLOCATE(m_norm_inv,(nrad))
+ - + - -
+ - + ]
4426 [ - + + - : 11192 : LIBPAW_ALLOCATE(rho_nc,(nrad,nspden))
- + + - +
- + - - +
- + ]
4427 [ + + ]: 13990 : do ispden=1,nspden
4428 [ + + ]: 10323926 : rho_nc(1:nrad,ispden)=rho_updn(1:nrad,1,ispden)*invsqfpi
4429 : : end do
4430 : 2798 : mag_nc => rho_nc(:,2:4)
4431 : 2798 : call pawxc_rotate_mag(rho_nc,rhosph,mag_nc,nrad,mag_norm_out=m_norm_inv)
4432 [ + + ]: 2580282 : do ir=1,nrad
4433 [ + + ]: 3214829 : m_norm_inv(ir)=merge(invsqfpi/m_norm_inv(ir),zero,m_norm_inv(ir)>rho_min)
4434 : : end do
4435 : : end if
4436 : :
4437 : : !Make spherical density positive
4438 : : !Critical section (named pawxc_mkdenpos, also used in pawxc): pawxcm may run on different atoms
4439 : : !at the same time (threaded atom loop of pawdenpot); the warning of mkdenpos is then printed
4440 : : !by one thread at a time.
4441 : : !$OMP CRITICAL (pawxc_mkdenpos)
4442 : 72896 : call pawxc_mkdenpos_wrapper(iwarn,nrad,nspden_updn,0,rhosph,xc_denpos)
4443 : : !$OMP END CRITICAL (pawxc_mkdenpos)
4444 : :
4445 : : !----------------------------------------------------------------------
4446 : : !----- Compute Exc(rhoSPH) and Vxc(rhoSPH)
4447 : : !----------------------------------------------------------------------
4448 : :
4449 [ - + + - : 218688 : LIBPAW_ALLOCATE(exci,(nrad))
+ - + - -
+ - + ]
4450 [ - + + - : 145792 : LIBPAW_ALLOCATE(tsxci,(nrad))
- + - + ]
4451 [ - + + - : 218688 : LIBPAW_ALLOCATE(vxci,(nrad,nspden_updn))
- + + - -
+ - + ]
4452 [ - + + - : 291584 : LIBPAW_ALLOCATE(kxci,(nrad,nkxc))
+ + + - +
- + + - +
- + ]
4453 : 72896 : call pawxcsph(exci,tsxci,exexch,el_temp,hyb_mixing,ixc,kxci,nkxc,nrad,nspden_updn,pawrad,rhosph,vxci,xclevel)
4454 : :
4455 : : !----------------------------------------------------------------------
4456 : : !----- Compute numerical derivatives of Vxc,Kxc (by finite diff. scheme)
4457 : : !----------------------------------------------------------------------
4458 : :
4459 [ + + ]: 72896 : if (option/=4.and.option/=5) then
4460 [ - + + - : 144682 : LIBPAW_ALLOCATE(exc_,(nrad))
- + - + ]
4461 [ - + + - : 144682 : LIBPAW_ALLOCATE(sxc_,(nrad))
- + - + ]
4462 [ - + + - : 217023 : LIBPAW_ALLOCATE(rho_,(nrad,nspden_updn))
- + + - -
+ - + ]
4463 : :
4464 [ + + + + ]: 10386261 : if (nspden_updn==2) rho_(:,2)=rhosph(:,2)
4465 : :
4466 : : ! Compute Exc, Vxc for rho+delta_rho
4467 [ - + + - : 217023 : LIBPAW_ALLOCATE(vxc1,(nrad,nspden_updn))
- + + - -
+ - + ]
4468 [ - + + - : 217023 : LIBPAW_ALLOCATE(kxc1,(nrad,nkxc))
+ + + - -
+ - + ]
4469 [ + + ]: 94355779 : rho_(:,1)=(one+delta)*rhosph(:,1)
4470 : 72341 : call pawxcsph(exc_,sxc_,exexch,el_temp,hyb_mixing,ixc,kxc1,nkxc,nrad,nspden_updn,pawrad,rho_,vxc1,xclevel)
4471 : :
4472 : : ! Compute Exc, Vxc for rho-delta_rho
4473 [ - + + - : 217023 : LIBPAW_ALLOCATE(vxc2,(nrad,nspden_updn))
- + + - -
+ - + ]
4474 [ - + + - : 217023 : LIBPAW_ALLOCATE(kxc2,(nrad,nkxc))
+ + + - -
+ - + ]
4475 [ + + ]: 94355779 : rho_(:,1)=(one-delta)*rhosph(:,1)
4476 : 72341 : call pawxcsph(exc_,sxc_,exexch,el_temp,hyb_mixing,ixc,kxc2,nkxc,nrad,nspden_updn,pawrad,rho_,vxc2,xclevel)
4477 : :
4478 : : ! Additional terms for spin-polarized systems
4479 [ + + ]: 72341 : if (nspden_updn==2) then
4480 [ + + ]: 10326924 : rho_(:,1)=rhosph(:,1)
4481 : :
4482 : : ! Compute Exc, Vxc for rho+delta_rho_down
4483 [ - + + - : 39012 : LIBPAW_ALLOCATE(vxcdn1,(nrad,nspden_updn))
- + + - -
+ - + ]
4484 [ - + + - : 39012 : LIBPAW_ALLOCATE(kxcdn1,(nrad,nkxc))
+ + + - -
+ - + ]
4485 [ + + ]: 10326924 : rho_(:,2)=(one+delta)*rhosph(:,2)
4486 : 13004 : call pawxcsph(exc_,sxc_,exexch,el_temp,hyb_mixing,ixc,kxcdn1,nkxc,nrad,nspden_updn,pawrad,rho_,vxcdn1,xclevel)
4487 : :
4488 : : ! Compute Exc, Vxc for rho-delta_rho_down
4489 [ - + + - : 39012 : LIBPAW_ALLOCATE(vxcdn2,(nrad,nspden_updn))
- + + - -
+ - + ]
4490 [ - + + - : 39012 : LIBPAW_ALLOCATE(kxcdn2,(nrad,nkxc))
+ + + - -
+ - + ]
4491 [ + + ]: 10326924 : rho_(:,2)=(one-delta)*rhosph(:,2)
4492 : 13004 : call pawxcsph(exc_,sxc_,exexch,el_temp,hyb_mixing,ixc,kxcdn2,nkxc,nrad,nspden_updn,pawrad,rho_,vxcdn2,xclevel)
4493 : :
4494 : : end if !nspden_updn==2
4495 [ - + ]: 72341 : LIBPAW_DEALLOCATE(sxc_)
4496 [ - + ]: 72341 : LIBPAW_DEALLOCATE(exc_)
4497 [ - + ]: 72341 : LIBPAW_DEALLOCATE(rho_)
4498 : :
4499 : : ! Store inverse of density finite step
4500 [ - + + - : 217023 : LIBPAW_ALLOCATE(rhoinv,(nrad,nspden_updn))
- + + - -
+ - + ]
4501 [ + + ]: 72341 : fact=one/delta;if (nspden_updn==1) fact=half*fact
4502 [ + + ]: 157686 : do ispden=1,nspden_updn
4503 [ + + ]: 104755044 : do ir=1,nrad
4504 [ + + ]: 104682703 : if (rhosph(ir,ispden)>rho_min) then
4505 : 104592488 : rhoinv(ir,ispden)=fact/rhosph(ir,ispden)
4506 : : else
4507 : 4870 : rhoinv(ir,ispden)=zero
4508 : : end if
4509 : : end do
4510 : : end do
4511 : :
4512 : : ! Compute numerical first derivatives of Vxc (by finite difference scheme)
4513 [ - + + - : 361705 : LIBPAW_ALLOCATE(d1vxc,(nrad,2*nspden_updn-1))
+ - - + +
- + - + -
- + - + ]
4514 : : ! Non-magnetic system: compute dVxc/dn
4515 [ + + ]: 72341 : if (nspden==1) then
4516 [ + + ]: 84028855 : d1vxc(1:nrad,1)=(vxc1(1:nrad,1)-vxc2(1:nrad,1))*half*rhoinv(1:nrad,1)
4517 : : ! Collinear magnetism: compute dVxc_up/dn_up,dVxc_dn/dn_up,dVxc_dn/dn_dn
4518 [ + + ]: 13004 : else if (nspden==2) then
4519 [ + + ]: 7746642 : d1vxc(1:nrad,1)=(vxc1(1:nrad,1)-vxc2(1:nrad,1))*half*rhoinv(1:nrad,1)
4520 [ + + ]: 7746642 : d1vxc(1:nrad,2)=(vxc1(1:nrad,2)-vxc2(1:nrad,2))*half*rhoinv(1:nrad,1)
4521 [ + + ]: 7746642 : d1vxc(1:nrad,3)=(vxcdn1(1:nrad,2)-vxcdn2(1:nrad,2))*half*rhoinv(1:nrad,2)
4522 : : ! Non-collinear magnetism: compute 1/2 d(Vxc_up+Vxc_dn)/dn,1/2 d(Vxc_up-Vxc_dn)/dn
4523 : : ! 1/2 d(Vxc_up-Vxc_dn)/dm
4524 [ + - ]: 2798 : else if (nspden==4) then
4525 [ + + ]: 2580282 : do ir=1,nrad
4526 : 2577484 : fact=half*rhoinv(ir,1)
4527 : 2577484 : dvxc1=(vxc1 (ir,1)-vxc2 (ir,1))*fact !dVxc_up/dn_up
4528 : 2577484 : dvxc2=(vxc1 (ir,2)-vxc2 (ir,2))*fact !dVxc_dn/dn_up
4529 : 2577484 : fact=half*rhoinv(ir,2)
4530 : 2577484 : dvxc3=(vxcdn1(ir,2)-vxcdn2(ir,2))*fact !dVxc_dn/dn_dn
4531 : 2577484 : dvxca=dvxc1+dvxc3;dvxcb=dvxc1-dvxc3;dvxcc=two*dvxc2 !Temporary terms
4532 : 2577484 : d1vxc(ir,1)=quarter*(dvxca+dvxcc) ! 1/2 d(Vxc_up+Vxc_dn)/dn
4533 : 2577484 : d1vxc(ir,2)=quarter* dvxcb ! 1/2 d(Vxc_up-Vxc_dn)/dn
4534 : 2580282 : d1vxc(ir,3)=quarter*(dvxca-dvxcc) ! 1/2 d(Vxc_up-Vxc_dn)/dm
4535 : : end do
4536 : : end if
4537 : :
4538 : : ! Compute numerical second derivatives of Vxc (by finite difference scheme)
4539 [ - + - - ]: 72341 : if (option/=3.or.pawxcdev>=2) then
4540 [ - + + - : 289364 : LIBPAW_ALLOCATE(d2vxc,(nrad,3*nspden_updn-2))
+ - - + +
- + - + -
- + - + ]
4541 : : ! Non-magnetic system: compute d2Vxc/dn2
4542 [ + + ]: 72341 : if (nspden==1) then
4543 [ + + ]: 84028855 : d2vxc(1:nrad,1)=(vxc1(1:nrad,1)+vxc2(1:nrad,1)-two*vxci(1:nrad,1))*rhoinv(1:nrad,1)**2
4544 : : ! Collinear magnetism: compute d2Vxc_up/dn_up2,d2Vxc_dn/dn_up2,d2Vxc_up/dn_dn2,d2Vxc_dn/dn_dn2
4545 [ + + ]: 13004 : else if (nspden==2) then
4546 [ + + ]: 7746642 : d2vxc(1:nrad,1)=(vxc1(1:nrad,1)+vxc2(1:nrad,1)-two*vxci(1:nrad,1))*rhoinv(1:nrad,1)**2
4547 [ + + ]: 7746642 : d2vxc(1:nrad,2)=(vxc1(1:nrad,2)+vxc2(1:nrad,2)-two*vxci(1:nrad,2))*rhoinv(1:nrad,1)**2
4548 [ + + ]: 7746642 : d2vxc(1:nrad,3)=(vxcdn1(1:nrad,1)+vxcdn2(1:nrad,1)-two*vxci(1:nrad,1))*rhoinv(1:nrad,2)**2
4549 [ + + ]: 7746642 : d2vxc(1:nrad,4)=(vxcdn1(1:nrad,2)+vxcdn2(1:nrad,2)-two*vxci(1:nrad,2))*rhoinv(1:nrad,2)**2
4550 : : ! Non-collinear magnetism: compute 1/2 d2(Vxc_up+Vxc_dn)/dn2,1/2 d2(Vxc_up-Vxc_dn)/dn2
4551 : : ! 1/2 d2(Vxc_up+Vxc_dn)/dm2,1/2 d2(Vxc_up-Vxc_dn)/dm2
4552 [ + - ]: 2798 : else if (nspden==4) then
4553 [ + + ]: 2580282 : do ir=1,nrad
4554 : 2577484 : fact=rhoinv(ir,1)**2
4555 : 2577484 : dvxc1=(vxc1 (ir,1)+vxc2 (ir,1)-two*vxci(ir,1))*fact !d2Vxc_up/dn_up2
4556 : 2577484 : dvxc2=(vxc1 (ir,2)+vxc2 (ir,2)-two*vxci(ir,2))*fact !d2Vxc_dn/dn_up2
4557 : 2577484 : fact=rhoinv(ir,2)**2
4558 : 2577484 : dvxc3=(vxcdn1(ir,1)+vxcdn2(ir,1)-two*vxci(ir,1))*fact !d2Vxc_up/dn_dn2
4559 : 2577484 : dvxc4=(vxcdn1(ir,2)+vxcdn2(ir,2)-two*vxci(ir,2))*fact !d2Vxc_dn/dn_dn2
4560 : 2577484 : dvxca=dvxc1+dvxc4;dvxcb=dvxc1-dvxc4 !Temporary terms
4561 : 2577484 : dvxcc=dvxc2+dvxc3;dvxcd=dvxc2-dvxc3 !Temporary terms
4562 : 2577484 : d2vxc(ir,1)=(dvxca+three*dvxcc)/8._dp ! 1/2 d2(Vxc_up+Vxc_dn)/dn2
4563 : 2577484 : d2vxc(ir,2)=(dvxcb+dvxcd)/8._dp ! 1/2 d2(Vxc_up-Vxc_dn)/dn2
4564 : 2577484 : d2vxc(ir,3)=(dvxca-dvxcc)/8._dp ! 1/2 d2(Vxc_up+Vxc_dn)/dm2
4565 : 2580282 : d2vxc(ir,4)=(dvxcb-three*dvxcd)/8._dp ! 1/2 d2(Vxc_up-Vxc_dn)/dm2
4566 : : end do
4567 : : end if
4568 : : end if
4569 : :
4570 : : ! Compute numerical first and second derivatives of Kxc (by finite difference scheme)
4571 [ + + ]: 72341 : if (nkxc>0) then
4572 : : ! Non-magnetic system: compute dKxc/dn, d2Kxc/dn2
4573 [ + + ]: 134 : if (nspden==1) then
4574 [ - + + - : 252 : LIBPAW_ALLOCATE(d1kxc,(nrad,1))
- + - + ]
4575 [ - + + - : 252 : LIBPAW_ALLOCATE(d2kxc,(nrad,1))
- + - + ]
4576 [ + + ]: 85686 : d1kxc(1:nrad,1)=(kxc1(1:nrad,1)-kxc2(1:nrad,1))*half*rhoinv(1:nrad,1)
4577 [ + + ]: 85686 : d2kxc(1:nrad,1)=(kxc1(1:nrad,1)+kxc2(1:nrad,1)-two*kxci(1:nrad,1))*rhoinv(1:nrad,1)**2
4578 : : ! Collinear magnetism: compute dKxc_upup/dn_up,dKxc_updn/dn_up,dKxc_updn/dn_dn,dKxc_dndn/dn_dn
4579 : : ! compute d2Kxc_upup/dn_up2,d2Kxc_updn/dn_up2,d2Kxc_upup/dn_dn2,d2Kxc_updn/dn_dn2,d2Kxc_dndn/dn_dn2
4580 [ + - ]: 8 : else if (nspden==2) then
4581 [ - + + - : 24 : LIBPAW_ALLOCATE(d1kxc,(nrad,4))
+ - + - -
+ - + ]
4582 [ - + + - : 24 : LIBPAW_ALLOCATE(d2kxc,(nrad,5))
+ - + - -
+ - + ]
4583 [ + + ]: 2808 : d1kxc(1:nrad,1)=(kxc1(1:nrad,1)-kxc2(1:nrad,1))*half*rhoinv(1:nrad,1) ! dKxc_upup/dn_up
4584 [ + + ]: 2808 : d1kxc(1:nrad,2)=(kxc1(1:nrad,2)-kxc2(1:nrad,2))*half*rhoinv(1:nrad,1) ! dKxc_updn/dn_up
4585 [ + + ]: 2808 : d1kxc(1:nrad,3)=(kxc1(1:nrad,3)-kxc2(1:nrad,3))*half*rhoinv(1:nrad,1) ! dKxc_dndn/dn_up
4586 [ + + ]: 2808 : d1kxc(1:nrad,4)=(kxcdn1(1:nrad,3)-kxcdn2(1:nrad,3))*half*rhoinv(1:nrad,2) ! dKxc_dndn/dn_dn
4587 [ + + ]: 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
4588 [ + + ]: 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
4589 [ + + ]: 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
4590 [ + + ]: 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
4591 [ + + ]: 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
4592 : : end if
4593 : : end if
4594 : :
4595 [ - + ]: 72341 : LIBPAW_DEALLOCATE(rhoinv)
4596 [ - + ]: 72341 : LIBPAW_DEALLOCATE(vxc1)
4597 [ - + ]: 72341 : LIBPAW_DEALLOCATE(vxc2)
4598 [ - + ]: 72341 : LIBPAW_DEALLOCATE(kxc1)
4599 [ - + ]: 72341 : LIBPAW_DEALLOCATE(kxc2)
4600 [ + + ]: 72341 : if (nspden_updn==2) then
4601 [ - + ]: 13004 : LIBPAW_DEALLOCATE(vxcdn1)
4602 [ - + ]: 13004 : LIBPAW_DEALLOCATE(vxcdn2)
4603 [ - + ]: 13004 : LIBPAW_DEALLOCATE(kxcdn1)
4604 [ - + ]: 13004 : LIBPAW_DEALLOCATE(kxcdn2)
4605 : : end if
4606 : :
4607 : : end if ! (option/=4 and option/=5)
4608 : :
4609 [ - + ]: 72896 : LIBPAW_DEALLOCATE(rhosph)
4610 : :
4611 : : !If non-collinear magnetism, store 1/2(Vxc_up+Vxc_dn) and 1/2(Vxc_up-Vxc_dn)
4612 [ + + ]: 72896 : if (nspden==4) then
4613 [ + + ]: 2580282 : vxci(:,1)=half*(vxci(:,1)+vxci(:,2))
4614 [ + + ]: 2580282 : vxci(:,2)=vxci(:,1)-vxci(:,2)
4615 : : end if
4616 : :
4617 : : !----------------------------------------------------------------------
4618 : : !----- Compute useful sums of densities
4619 : : !----------------------------------------------------------------------
4620 : :
4621 [ + + ]: 72896 : if (option/=4.and.option/=5) then
4622 : :
4623 : : ! Non-collinear magnetism: replace rho_dn by (m_0.dot.m)/|m_0|
4624 [ + + ]: 72341 : if (nspden==4) then
4625 [ - + + - : 11192 : LIBPAW_POINTER_ALLOCATE(rho_dn,(nrad,lm_size))
- + + - +
- + - - +
- + ]
4626 [ + + ]: 2580282 : rho_dn(:,1)=zero
4627 [ + + ]: 71342 : do ilm=2,lm_size
4628 : : rho_dn(1:nrad,ilm)=m_norm_inv(1:nrad) &
4629 : : & *(rho_updn(1:nrad,1,2)*rho_updn(1:nrad,ilm,2) &
4630 : : & +rho_updn(1:nrad,1,3)*rho_updn(1:nrad,ilm,3) &
4631 [ + - + + : 125204846 : & +rho_updn(1:nrad,1,4)*rho_updn(1:nrad,ilm,4))
+ + ]
4632 : : end do
4633 : : end if
4634 : :
4635 : : ! Non-magnetic system:
4636 : : ! Compute
4637 : : ! V1SUM1(r)=Sum_L{n_L(r)^2}
4638 : : ! V2SUM1(r,L)=Sum_L1_L2{n_L1(r)*n_L2(r)*Gaunt_(L,L1,L2)}
4639 : : ! Collinear magnetism:
4640 : : ! Compute
4641 : : ! V1SUM1(r)=Sum_L{n^up_L(r)^2}
4642 : : ! V1SUM2(r)=Sum_L{n^up_L(r)*n^dn_L(r)}
4643 : : ! V1SUM3(r)=Sum_L{n^dn_L(r)^2}
4644 : : ! V2SUM1(r,L)=Sum_L1_L2{n^up_L1(r)*n^up_L2(r)*Gaunt_(L,L1,L2)}
4645 : : ! V2SUM2(r,L)=Sum_L1_L2{n^up_L1(r)*n^dn_L2(r)*Gaunt_(L,L1,L2)}
4646 : : ! V2SUM3(r,L)=Sum_L1_L2{n^dn_L1(r)*n^dn_L2(r)*Gaunt_(L,L1,L2)}
4647 : : ! Non-collinear magnetism:
4648 : : ! Compute
4649 : : ! V1SUM1(r)=Sum_L{n_L(r)^2}
4650 : : ! V1SUM2(r)=Sum_L{n_L(r) (m_0.m_L)}/|m_0|
4651 : : ! V1SUM3(r)=Sum_L{(m_0.m_L)^2}/|m_0|^2
4652 : : ! V2SUM1(r,L)=Sum_L1_L2{n_L1(r)*n_L2(r)*Gaunt_(L,L1,L2)}
4653 : : ! V2SUM2(r,L)=Sum_L1_L2{n_L1(r) (m_0.m_L2)*Gaunt_(L,L1,L2)}/|m_0|
4654 : : ! V2SUM3(r,L)=Sum_L1_L2{(m_0.m_L1)*(m_0.m_L2)*Gaunt_(L,L1,L2)}/|m_0|^2
4655 [ + - ]: 72341 : if (pawxcdev>=1) then
4656 [ - + + - : 289364 : LIBPAW_ALLOCATE(v1sum,(nrad,nsums))
- + + - +
- + - - +
- + ]
4657 : : else
4658 [ # # ]: 0 : LIBPAW_ALLOCATE(v1sum,(0,0))
4659 : : end if
4660 [ + + ]: 72341 : if (pawxcdev>=2) then
4661 [ - + + - : 1720 : LIBPAW_ALLOCATE(v2sum,(nrad,lm_size,nsums))
- + + - -
+ + - + -
+ - - + -
+ ]
4662 : : else
4663 [ - + ]: 71997 : LIBPAW_ALLOCATE(v2sum,(0,0,0))
4664 : : end if
4665 : : call pawxcsum(1,1,1,lmselect,lmselect,lm_size,nrad,nsums,pawxcdev,pawang,&
4666 : 72341 : & rho_up,rho_dn,v1sum,v2sum)
4667 : :
4668 : : end if !option
4669 : :
4670 : : !----------------------------------------------------------------------
4671 : : !----- Accumulate and store XC potential
4672 : : !----------------------------------------------------------------------
4673 : :
4674 [ + + ]: 72896 : if (option/=3.and.option/=4) then
4675 : :
4676 : : ! === First order development
4677 : : ! ---------------------------
4678 [ + - ]: 72385 : if (pawxcdev>=1) then
4679 : :
4680 : : ! Non-magnetic system
4681 [ + + ]: 72385 : if (nspden_updn==1) then
4682 [ + + ]: 84051419 : vxc(1:nrad,1,1)=vxci(1:nrad,1)*sqfpi
4683 [ + + ]: 59377 : if (option/=5) then
4684 [ + + ]: 84028855 : vxc(1:nrad,1,1)=vxc(1:nrad,1,1)+v1sum(1:nrad,1)*d2vxc(1:nrad,1)*invsqfpi2
4685 [ + + ]: 493457 : do ilm=2,lm_size
4686 [ + + ]: 493457 : if (lmselect(ilm)) then
4687 [ + + ]: 330698913 : vxc(1:nrad,ilm,1)=d1vxc(1:nrad,1)*rho_up(1:nrad,ilm)
4688 : : end if
4689 : : end do
4690 : : end if
4691 : :
4692 : : ! Magnetic system (including non-collinear magn.)
4693 [ + - ]: 13008 : else if (nspden_updn==2) then
4694 [ + + ]: 10332256 : vxc(1:nrad,1,1)=vxci(1:nrad,1)*sqfpi
4695 [ + + ]: 10332256 : vxc(1:nrad,1,2)=vxci(1:nrad,2)*sqfpi
4696 [ + + ]: 13008 : if (option/=5) then
4697 : : vxc(1:nrad,1,1)=vxc(1:nrad,1,1)+invsqfpi2*(v1sum(1:nrad,1)*d2vxc(1:nrad,1) &
4698 [ + + ]: 10326924 : & +two*v1sum(1:nrad,2)*d2vxc(1:nrad,2)+v1sum(1:nrad,3)*d2vxc(1:nrad,3))
4699 : : vxc(1:nrad,1,2)=vxc(1:nrad,1,2)+invsqfpi2*(v1sum(1:nrad,1)*d2vxc(1:nrad,2) &
4700 [ + + ]: 10326924 : & +two*v1sum(1:nrad,2)*d2vxc(1:nrad,3)+v1sum(1:nrad,3)*d2vxc(1:nrad,4))
4701 [ + + ]: 284830 : do ilm=2,lm_size
4702 [ + + ]: 284830 : if (lmselect(ilm)) then
4703 : : vxc(1:nrad,ilm,1)=vxc(1:nrad,ilm,1) &
4704 [ + + ]: 131265504 : & +d1vxc(1:nrad,1)*rho_up(1:nrad,ilm)+d1vxc(1:nrad,2)*rho_dn(1:nrad,ilm)
4705 : : vxc(1:nrad,ilm,2)=vxc(1:nrad,ilm,2) &
4706 [ + + ]: 131265504 : & +d1vxc(1:nrad,2)*rho_up(1:nrad,ilm)+d1vxc(1:nrad,3)*rho_dn(1:nrad,ilm)
4707 : : end if
4708 : : end do
4709 : : end if
4710 : : end if
4711 : : end if ! pawxcdev>=1
4712 : :
4713 : : ! == 2nd order development
4714 : : ! ---------------------------
4715 [ + + + - ]: 72385 : if (pawxcdev>=2.and.option/=5) then
4716 : :
4717 : : ! Non-magnetic system
4718 [ + + ]: 344 : if (nspden_updn==1) then
4719 [ + + ]: 270 : do ilm=2,lm_size
4720 [ + + ]: 332910 : vxc(1:nrad,ilm,1)=vxc(1:nrad,ilm,1)+half*d2vxc(1:nrad,1)*v2sum(1:nrad,ilm,1)
4721 : : end do
4722 : :
4723 : : ! Magnetic system (including non-collinear magn.)
4724 [ + - ]: 314 : else if (nspden_updn==2) then
4725 [ + + ]: 7850 : do ilm=2,lm_size
4726 : : vxc(1:nrad,ilm,1)=vxc(1:nrad,ilm,1)+d2vxc(1:nrad,2)*v2sum(1:nrad,ilm,2) &
4727 [ + + ]: 8032320 : & +half*(d2vxc(1:nrad,1)*v2sum(1:nrad,ilm,1)+d2vxc(1:nrad,3)*v2sum(1:nrad,ilm,3))
4728 : : vxc(1:nrad,ilm,2)=vxc(1:nrad,ilm,2)+d2vxc(1:nrad,3)*v2sum(1:nrad,ilm,2) &
4729 [ + + ]: 8032634 : & +half*(d2vxc(1:nrad,2)*v2sum(1:nrad,ilm,1)+d2vxc(1:nrad,4)*v2sum(1:nrad,ilm,3))
4730 : : end do
4731 : : end if
4732 : : end if !pawxcdev=2
4733 : :
4734 : : ! === Pathological case: if rho(r) is negative, interpolate Vxc
4735 : : ! -------------------------------------------------------------
4736 [ + - ]: 72385 : if (lmselect(1)) then
4737 : 72385 : tol_rho=xc_denpos*(one+tol6)
4738 [ + + ]: 157778 : do ispden=1,nspden_updn
4739 : : ir1=0;ir2=0
4740 [ + + ]: 104788316 : do ir=1,nrad
4741 [ + + ]: 104715931 : if (rho_updn(ir,1,ispden)<tol_rho) then
4742 [ + + ]: 1232475 : if (ir1==0) ir1=ir-1
4743 : 1232475 : ir2=ir+1
4744 [ + + ]: 103398063 : else if (ir1>0) then
4745 [ + + + + ]: 491 : if (ir1>1.or.ir2<nrad) then
4746 : 489 : fact=(vxc(ir2,1,ispden)-vxc(ir1,1,ispden))/(pawrad%rad(ir2)-pawrad%rad(ir1))
4747 [ + + ]: 152581 : do jr=ir1+1,ir2-1
4748 : 152583 : vxc(jr,1,ispden)=vxc(ir1,1,ispden)+fact*(pawrad%rad(jr)-pawrad%rad(ir1))
4749 : : end do
4750 : : end if
4751 : : ir1=0;ir2=0
4752 : : end if
4753 : : end do
4754 : : end do
4755 : : end if
4756 : :
4757 : : ! === Non-collinear magnetism: "rotate" back the XC potential
4758 : : ! ------- ---------------------------------------------------
4759 [ + + ]: 72385 : if (nspden==4) then
4760 [ - + + - : 8394 : LIBPAW_ALLOCATE(vxc_diag,(nrad,nspden_updn))
- + + - -
+ - + ]
4761 [ - + + - : 11192 : LIBPAW_ALLOCATE(vxc_nc,(nrad,nspden))
- + + - +
- + - - +
- + ]
4762 [ + + ]: 74140 : do ilm=1,lm_size
4763 [ + + ]: 65215578 : vxc_diag(:,1)=vxc(:,ilm,1)+vxc(:,ilm,2) ! Get V from (V_up+V_dn)/2
4764 [ + + ]: 65215578 : vxc_diag(:,2)=vxc(:,ilm,1)-vxc(:,ilm,2) ! and (V_up-V_dn)/2
4765 : 71342 : call pawxc_rotate_back_mag(vxc_diag,vxc_nc,mag_nc,nrad)
4766 [ + + ]: 359508 : do ispden=1,nspden
4767 [ + + ]: 260933654 : vxc(1:nrad,ilm,ispden)=vxc_nc(1:nrad,ispden)
4768 : : end do
4769 : : end do
4770 [ - + ]: 2798 : LIBPAW_DEALLOCATE(vxc_diag)
4771 [ - + ]: 2798 : LIBPAW_DEALLOCATE(vxc_nc)
4772 : : end if
4773 : : end if !option/=3 and option/=4
4774 : :
4775 : : !----------------------------------------------------------------------
4776 : : !----- Accumulate and store XC kernel
4777 : : !----------------------------------------------------------------------
4778 : :
4779 [ + + ]: 72896 : if (nkxc>0) then
4780 : :
4781 : : ! === First order development
4782 : : ! ---------------------------
4783 [ + - ]: 134 : if (pawxcdev>=1) then
4784 : : ! Non-magnetic system:
4785 [ + + ]: 134 : if (nspden_updn==1) then
4786 [ + + ]: 85686 : kxc(1:nrad,1,1)=kxci(1:nrad,1)*sqfpi
4787 [ + - ]: 126 : if (option/=5.and.option/=4) then
4788 [ + + ]: 85686 : kxc(1:nrad,1,1)=kxc(1:nrad,1,1)+invsqfpi2*v1sum(1:nrad,1)*d2kxc(1:nrad,1)
4789 [ + + ]: 1326 : do ilm=2,lm_size
4790 [ + + ]: 1326 : if (lmselect(ilm)) then
4791 [ + + ]: 336732 : kxc(1:nrad,ilm,1)=d1kxc(1:nrad,1)*rho_up(1:nrad,ilm)
4792 : : end if
4793 : : end do
4794 : : end if
4795 : : ! Magnetic system:
4796 [ + - ]: 8 : else if (nspden==2) then
4797 [ + + ]: 2808 : kxc(1:nrad,1,1)=kxci(1:nrad,1)*sqfpi
4798 [ + + ]: 2808 : kxc(1:nrad,1,2)=kxci(1:nrad,2)*sqfpi
4799 [ + + ]: 2808 : kxc(1:nrad,1,3)=kxci(1:nrad,3)*sqfpi
4800 [ + - ]: 8 : if (option/=5.and.option/=4) then
4801 : : kxc(1:nrad,1,1)=kxc(1:nrad,1,1)+invsqfpi2*(v1sum(1:nrad,1)*d2kxc(1:nrad,1) &
4802 [ + + ]: 2808 : & +two*v1sum(1:nrad,2)*d2kxc(1:nrad,2)+v1sum(1:nrad,3)*d2kxc(1:nrad,3))
4803 : : kxc(1:nrad,1,2)=kxc(1:nrad,1,2)+invsqfpi2*(v1sum(1:nrad,1)*d2kxc(1:nrad,2) &
4804 [ + + ]: 2808 : & +two*v1sum(1:nrad,2)*d2kxc(1:nrad,3)+v1sum(1:nrad,3)*d2kxc(1:nrad,4))
4805 : : kxc(1:nrad,1,3)=kxc(1:nrad,1,3)+invsqfpi2*(v1sum(1:nrad,1)*d2kxc(1:nrad,3) &
4806 [ + + ]: 2808 : & +two*v1sum(1:nrad,2)*d2kxc(1:nrad,4)+v1sum(1:nrad,3)*d2kxc(1:nrad,5))
4807 [ + + ]: 136 : do ilm=2,lm_size
4808 [ + + ]: 136 : if (lmselect(ilm)) then
4809 : : kxc(1:nrad,ilm,1)=kxc(1:nrad,ilm,1) &
4810 [ + + ]: 29484 : & +d1kxc(1:nrad,1)*rho_up(1:nrad,ilm)+d1kxc(1:nrad,2)*rho_dn(1:nrad,ilm)
4811 : : kxc(1:nrad,ilm,2)=kxc(1:nrad,ilm,2) &
4812 [ + + ]: 29484 : & +d1kxc(1:nrad,2)*rho_up(1:nrad,ilm)+d1kxc(1:nrad,3)*rho_dn(1:nrad,ilm)
4813 : : kxc(1:nrad,ilm,3)=kxc(1:nrad,ilm,3) &
4814 [ + + ]: 29484 : & +d1kxc(1:nrad,3)*rho_up(1:nrad,ilm)+d1kxc(1:nrad,4)*rho_dn(1:nrad,ilm)
4815 : : end if
4816 : : end do
4817 : : end if
4818 : : end if
4819 : : end if ! pawxcdev>=1
4820 : :
4821 : : ! == 2nd order development
4822 : : ! ---------------------------
4823 [ - + - - : 134 : if (pawxcdev>=2.and.option/=4.and.option/=5) then
- - ]
4824 : :
4825 : : ! Non-magnetic system:
4826 [ # # ]: 0 : if (nspden_updn==1) then
4827 [ # # ]: 0 : do ilm=2,lm_size
4828 [ # # ]: 0 : kxc(1:nrad,ilm,1)=kxc(1:nrad,ilm,1)+half*d2kxc(1:nrad,1)*v2sum(1:nrad,ilm,1)
4829 : : end do
4830 : : ! Magnetic system:
4831 [ # # ]: 0 : else if (nspden==2) then
4832 [ # # ]: 0 : do ilm=2,lm_size
4833 : : kxc(1:nrad,ilm,1)=kxc(1:nrad,ilm,1)+d2kxc(1:nrad,2)*v2sum(1:nrad,ilm,2) &
4834 [ # # ]: 0 : & +half*(d2kxc(1:nrad,1)*v2sum(1:nrad,ilm,1)+d2kxc(1:nrad,3)*v2sum(1:nrad,ilm,3))
4835 : : kxc(1:nrad,ilm,2)=kxc(1:nrad,ilm,2)+d2kxc(1:nrad,3)*v2sum(1:nrad,ilm,2) &
4836 [ # # ]: 0 : & +half*(d2kxc(1:nrad,2)*v2sum(1:nrad,ilm,1)+d2kxc(1:nrad,4)*v2sum(1:nrad,ilm,3))
4837 : : kxc(1:nrad,ilm,3)=kxc(1:nrad,ilm,3)+d2kxc(1:nrad,4)*v2sum(1:nrad,ilm,2) &
4838 [ # # ]: 0 : & +half*(d2kxc(1:nrad,3)*v2sum(1:nrad,ilm,1)+d2kxc(1:nrad,5)*v2sum(1:nrad,ilm,3))
4839 : : end do
4840 : : end if
4841 : : end if !pawxcdev=2
4842 : :
4843 : : ! === Pathological case: if rho(r) is negative, interpolate Kxc
4844 : : ! -------------------------------------------------------------
4845 : :
4846 : : ! NOT OK for spin polarized
4847 [ + - ]: 134 : if (lmselect(1)) then
4848 : 134 : tol_rho=xc_denpos*(one+tol6)
4849 [ + + ]: 276 : do ispden=1,nspden_updn
4850 : : ir1=0;ir2=0
4851 [ + + ]: 91436 : do ir=1,nrad
4852 [ - + ]: 91302 : if (rho_updn(ir,1,ispden)<tol_rho) then
4853 [ # # ]: 0 : if (ir1==0) ir1=ir-1
4854 : 0 : ir2=ir+1
4855 [ - + ]: 91160 : else if (ir1>0) then
4856 [ # # # # ]: 0 : if (ir1>1.or.ir2<nrad) then
4857 : 0 : fact=(kxc(ir2,1,ispden)-kxc(ir1,1,ispden))/(pawrad%rad(ir2)-pawrad%rad(ir1))
4858 [ # # ]: 0 : do jr=ir1+1,ir2-1
4859 : 0 : kxc(jr,1,ispden)=kxc(ir1,1,ispden)+fact*(pawrad%rad(jr)-pawrad%rad(ir1))
4860 : : end do
4861 : : end if
4862 : : ir1=0;ir2=0
4863 : : end if
4864 : : end do
4865 : : end do
4866 : : end if
4867 : :
4868 : : ! Non-collinear magnetism: need to store magnetization in kxc
4869 [ - + ]: 134 : if (nkxc==6.or.nkxc==22) then
4870 [ # # ]: 0 : do ilm=2,lm_size
4871 [ # # ]: 0 : kxc(1:nrad,ilm,nkxc-2)=rho_updn(1:nrad,ilm,2)
4872 [ # # ]: 0 : kxc(1:nrad,ilm,nkxc-1)=rho_updn(1:nrad,ilm,3)
4873 [ # # ]: 0 : kxc(1:nrad,ilm,nkxc )=rho_updn(1:nrad,ilm,4)
4874 : : end do
4875 : : end if
4876 : :
4877 : : end if ! nkxc>0
4878 : :
4879 [ + + ]: 72896 : if (nspden==4) then
4880 [ - + ]: 2798 : LIBPAW_DEALLOCATE(rho_nc)
4881 [ - + ]: 2798 : LIBPAW_DEALLOCATE(m_norm_inv)
4882 : : end if
4883 : :
4884 [ - + ]: 72896 : LIBPAW_DEALLOCATE(kxci)
4885 [ + + + - : 72896 : if (nkxc>0.and.option/=4.and.option/=5) then
+ - ]
4886 [ - + ]: 134 : LIBPAW_DEALLOCATE(d1kxc)
4887 [ - + ]: 134 : LIBPAW_DEALLOCATE(d2kxc)
4888 : : end if
4889 : :
4890 : : !----------------------------------------------------------------------
4891 : : !----- Accumulate and store XC energies
4892 : : !----------------------------------------------------------------------
4893 : :
4894 : : !----- Calculate Exc (direct scheme) term
4895 : : !----------------------------------------
4896 [ + + ]: 72896 : if (option/=1.and.option/=5) then
4897 [ - + + - : 140842 : LIBPAW_ALLOCATE(ff,(nrad))
- + - + -
+ ]
4898 : :
4899 : : ! Contribution from spherical part of rho
4900 [ + + ]: 70421 : if (nspden==1.or.nspden==4) then
4901 [ + + ]: 86105996 : ff(1:nrad)=rho_updn(1:nrad,1,1)*exci(1:nrad)*sqfpi
4902 [ + - ]: 9384 : else if (nspden==2) then
4903 [ + + ]: 7203469 : ff(1:nrad)=(rho_updn(1:nrad,1,1)+rho_updn(1:nrad,1,2))*exci(1:nrad)*sqfpi
4904 : : end if
4905 : :
4906 : : ! Contribution from aspherical part of rho
4907 [ + + ]: 70421 : if (option/=4) then
4908 : :
4909 : : ! First order development
4910 [ + - ]: 69910 : if (pawxcdev>=1) then
4911 [ + + ]: 69910 : if (nspden_updn==1) then
4912 [ + + ]: 83046638 : ff(1:nrad)=ff(1:nrad)+half*v1sum(1:nrad,1)*d1vxc(1:nrad,1)
4913 [ + - ]: 11992 : else if (nspden_updn==2) then
4914 : : ff(1:nrad)=ff(1:nrad)+v1sum(1:nrad,2)*d1vxc(1:nrad,2) &
4915 [ + + ]: 9628594 : & +half*(v1sum(1:nrad,1)*d1vxc(1:nrad,1)+v1sum(1:nrad,3)*d1vxc(1:nrad,3))
4916 : : end if
4917 : : end if
4918 : :
4919 : : ! Second order development
4920 [ + + ]: 69910 : if (pawxcdev>=2) then
4921 [ - + + - : 688 : LIBPAW_ALLOCATE(gg,(nrad))
- + - + ]
4922 : :
4923 [ + + ]: 376290 : gg=zero
4924 [ + + ]: 8120 : do ilm=2,lm_size
4925 [ + + ]: 8120 : if (lmselect(ilm)) then
4926 [ + + ]: 7331888 : gg(1:nrad)=gg(1:nrad)+v2sum(1:nrad,ilm,1)*rho_up(1:nrad,ilm)
4927 : : end if
4928 : : end do
4929 [ + + ]: 376290 : ff(1:nrad)=ff(1:nrad)+gg(1:nrad)*d2vxc(1:nrad,1)/6._dp
4930 : :
4931 [ + + ]: 344 : if (nspden_updn==2) then ! Spin polarized (including non-coll. magn.)
4932 [ + + ]: 334680 : gg=zero
4933 [ + + ]: 7850 : do ilm=2,lm_size
4934 [ + + ]: 7850 : if (lmselect(ilm)) then
4935 [ + + ]: 7287504 : gg(1:nrad)=gg(1:nrad)+v2sum(1:nrad,ilm,3)*rho_dn(1:nrad,ilm)
4936 : : end if
4937 : : end do
4938 [ + + ]: 334680 : ff(1:nrad)=ff(1:nrad)+gg(1:nrad)*d2vxc(1:nrad,4)/6._dp
4939 [ + + ]: 334680 : gg=zero
4940 [ + + ]: 7850 : do ilm=2,lm_size
4941 [ + + ]: 7850 : if (lmselect(ilm)) then
4942 [ + + ]: 7287504 : gg(1:nrad)=gg(1:nrad)+v2sum(1:nrad,ilm,2)*rho_up(1:nrad,ilm)
4943 : : end if
4944 : : end do
4945 [ + + ]: 334680 : ff(1:nrad)=ff(1:nrad)+half*gg(1:nrad)*d2vxc(1:nrad,2)
4946 [ + + ]: 334680 : gg=zero
4947 [ + + ]: 7850 : do ilm=2,lm_size
4948 [ + + ]: 7850 : if (lmselect(ilm)) then
4949 [ + + ]: 7287504 : gg(1:nrad)=gg(1:nrad)+v2sum(1:nrad,ilm,3)*rho_up(1:nrad,ilm)
4950 : : end if
4951 : : end do
4952 [ + + ]: 334680 : ff(1:nrad)=ff(1:nrad)+half*gg(1:nrad)*d2vxc(1:nrad,3)
4953 : : end if
4954 [ - + ]: 344 : LIBPAW_DEALLOCATE(gg)
4955 : : end if
4956 : :
4957 : : end if ! option/=4
4958 : :
4959 [ + + ]: 93309465 : ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2
4960 : 70421 : call simp_gen(enxc,ff,pawrad)
4961 [ - + ]: 70421 : LIBPAW_DEALLOCATE(ff)
4962 : : end if ! option/=1 and option/=5
4963 : :
4964 : : !----- Calculate Sxc term (using Exc as a model)
4965 : : !----------------------------------------
4966 [ + + + + : 95006888 : if (any(tsxci/=zero).and.option/=1.and.option/=5) then
+ + + - +
- ]
4967 [ - + + - : 60 : LIBPAW_ALLOCATE(ff,(nrad))
- + - + -
+ ]
4968 : :
4969 : : ! Contribution from spherical part of rho
4970 [ + - ]: 30 : if (nspden==1.or.nspden==4) then
4971 [ + + ]: 11050 : ff(1:nrad)=rho_updn(1:nrad,1,1)*tsxci(1:nrad)*sqfpi
4972 [ # # ]: 0 : else if (nspden==2) then
4973 [ # # ]: 0 : ff(1:nrad)=(rho_updn(1:nrad,1,1)+rho_updn(1:nrad,1,2))*tsxci(1:nrad)*sqfpi
4974 : : end if
4975 : :
4976 : : ! Contribution from aspherical part of rho
4977 [ + + ]: 30 : if (option/=4) then
4978 : :
4979 : : ! First order development
4980 [ + - ]: 28 : if (pawxcdev>=1) then
4981 [ + - ]: 28 : if (nspden_updn==1) then
4982 [ + + ]: 10276 : ff(1:nrad)=ff(1:nrad)+half*v1sum(1:nrad,1)*d1vxc(1:nrad,1)
4983 [ # # ]: 0 : else if (nspden_updn==2) then
4984 : : ff(1:nrad)=ff(1:nrad)+v1sum(1:nrad,2)*d1vxc(1:nrad,2) &
4985 [ # # ]: 0 : & +half*(v1sum(1:nrad,1)*d1vxc(1:nrad,1)+v1sum(1:nrad,3)*d1vxc(1:nrad,3))
4986 : : end if
4987 : : end if
4988 : :
4989 : : ! Second order development
4990 [ - + ]: 28 : if (pawxcdev>=2) then
4991 [ # # # # : 0 : LIBPAW_ALLOCATE(gg,(nrad))
# # # # ]
4992 : :
4993 [ # # ]: 0 : gg=zero
4994 [ # # ]: 0 : do ilm=2,lm_size
4995 [ # # ]: 0 : if (lmselect(ilm)) then
4996 [ # # ]: 0 : gg(1:nrad)=gg(1:nrad)+v2sum(1:nrad,ilm,1)*rho_up(1:nrad,ilm)
4997 : : end if
4998 : : end do
4999 [ # # ]: 0 : ff(1:nrad)=ff(1:nrad)+gg(1:nrad)*d2vxc(1:nrad,1)/6._dp
5000 : :
5001 [ # # ]: 0 : if (nspden_updn==2) then ! Spin polarized (including non-coll. magn.)
5002 [ # # ]: 0 : gg=zero
5003 [ # # ]: 0 : do ilm=2,lm_size
5004 [ # # ]: 0 : if (lmselect(ilm)) then
5005 [ # # ]: 0 : gg(1:nrad)=gg(1:nrad)+v2sum(1:nrad,ilm,3)*rho_dn(1:nrad,ilm)
5006 : : end if
5007 : : end do
5008 [ # # ]: 0 : ff(1:nrad)=ff(1:nrad)+gg(1:nrad)*d2vxc(1:nrad,4)/6._dp
5009 [ # # ]: 0 : gg=zero
5010 [ # # ]: 0 : do ilm=2,lm_size
5011 [ # # ]: 0 : if (lmselect(ilm)) then
5012 [ # # ]: 0 : gg(1:nrad)=gg(1:nrad)+v2sum(1:nrad,ilm,2)*rho_up(1:nrad,ilm)
5013 : : end if
5014 : : end do
5015 [ # # ]: 0 : ff(1:nrad)=ff(1:nrad)+half*gg(1:nrad)*d2vxc(1:nrad,2)
5016 [ # # ]: 0 : gg=zero
5017 [ # # ]: 0 : do ilm=2,lm_size
5018 [ # # ]: 0 : if (lmselect(ilm)) then
5019 [ # # ]: 0 : gg(1:nrad)=gg(1:nrad)+v2sum(1:nrad,ilm,3)*rho_up(1:nrad,ilm)
5020 : : end if
5021 : : end do
5022 [ # # ]: 0 : ff(1:nrad)=ff(1:nrad)+half*gg(1:nrad)*d2vxc(1:nrad,3)
5023 : : end if
5024 [ # # ]: 0 : LIBPAW_DEALLOCATE(gg)
5025 : : end if
5026 : :
5027 : : end if ! option/=4
5028 : :
5029 [ + + ]: 11050 : ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2
5030 : 30 : call simp_gen(snxc,ff,pawrad)
5031 [ - + ]: 30 : LIBPAW_DEALLOCATE(ff)
5032 : 60 : snxc=snxc/el_temp
5033 : : end if ! option/=1 and option/=5
5034 : :
5035 [ - + ]: 72896 : LIBPAW_DEALLOCATE(tsxci)
5036 [ - + ]: 72896 : LIBPAW_DEALLOCATE(exci)
5037 [ - + ]: 72896 : LIBPAW_DEALLOCATE(vxci)
5038 [ + + + - : 72896 : if (nspden==4.and.option/=4.and.option/=5) then
+ - ]
5039 [ - + ]: 2798 : LIBPAW_POINTER_DEALLOCATE(rho_dn)
5040 : : end if
5041 [ + + ]: 72896 : if (allocated(v1sum)) then
5042 : 72341 : LIBPAW_DEALLOCATE(v1sum)
5043 : : end if
5044 [ + + ]: 72896 : if (allocated(v2sum)) then
5045 : 72341 : LIBPAW_DEALLOCATE(v2sum)
5046 : : end if
5047 [ + + ]: 72896 : if (allocated(d1vxc)) then
5048 : 72341 : LIBPAW_DEALLOCATE(d1vxc)
5049 : : end if
5050 [ + + ]: 72896 : if (allocated(d2vxc)) then
5051 : 72341 : LIBPAW_DEALLOCATE(d2vxc)
5052 : : end if
5053 : :
5054 : : !----- Calculate Excdc double counting term
5055 : : !------------------------------------------
5056 [ + + ]: 72896 : if (option==0.or.option==2) then
5057 : :
5058 [ - + + - : 139820 : LIBPAW_ALLOCATE(ff,(nrad))
- + - + -
+ ]
5059 : :
5060 : : ! Build appropriate density (without core density)
5061 [ + + + + : 1032152882 : rho_updn(:,:,:)=rhor(:,:,:)
+ + ]
5062 [ + + + + : 209877058 : if (usexcnhat>0) rho_updn(:,:,:)=rho_updn(:,:,:)+nhat(:,:,:)
+ + + + ]
5063 [ + + ]: 69910 : if (nspden==2) then
5064 [ + + ]: 201358 : do ilm=1,lm_size
5065 [ + + ]: 130622362 : ff(:)=rho_updn(:,ilm,2)
5066 [ + + ]: 130622362 : rho_updn(:,ilm,2)=rho_updn(:,ilm,1)-ff(:)
5067 [ + + ]: 130631704 : rho_updn(:,ilm,1)=ff(:)
5068 : : end do
5069 : : end if
5070 : :
5071 [ + + ]: 92675232 : ff(1:nrad)=zero
5072 : :
5073 : : ! Non magnetic or collinear magnetic system:
5074 [ + + ]: 69910 : if (nspden/=4) then
5075 [ + + ]: 143862 : do ispden=1,nspden_updn
5076 [ + + ]: 999892 : do ilm=1,lm_size
5077 [ + + + + ]: 561964076 : if (lmselect(ilm)) ff(1:nrad)=ff(1:nrad)+vxc(1:nrad,ilm,ispden)*rho_updn(1:nrad,ilm,ispden)
5078 : : end do
5079 : : end do
5080 : : else
5081 : : ! Non-collinear magnetic system:
5082 [ + + ]: 70292 : do ilm=1,lm_size
5083 [ + + ]: 70292 : if (lmselect(ilm)) then
5084 [ + + ]: 59234848 : do ir=1,nrad
5085 : 59171550 : dvxca=vxc(ir,ilm,1)+vxc(ir,ilm,2);dvxcb=vxc(ir,ilm,1)-vxc(ir,ilm,2)
5086 : : ff(ir)=ff(ir)+half*(dvxca*rho_updn(ir,ilm,1)+dvxcb*rho_updn(ir,ilm,4)) &
5087 : 59234848 : & +vxc(ir,ilm,3)*rho_updn(ir,ilm,2)-vxc(ir,ilm,4)*rho_updn(ir,ilm,3)
5088 : : end do
5089 : : end if
5090 : : end do
5091 : : end if
5092 : :
5093 [ + + ]: 92675232 : ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2
5094 : 69910 : call simp_gen(enxcdc,ff,pawrad)
5095 [ - + ]: 69910 : LIBPAW_DEALLOCATE(ff)
5096 : :
5097 : : end if ! option
5098 : :
5099 [ - + ]: 72896 : LIBPAW_DEALLOCATE(rho_updn)
5100 : :
5101 [ - + - + : 146780 : end subroutine pawxcm
- + - + -
+ - + - +
- + - + -
+ ]
5102 : : !!***
5103 : :
5104 : : !----------------------------------------------------------------------
5105 : :
5106 : : !!****f* m_pawxc/pawxcm_dfpt
5107 : : !! NAME
5108 : : !! pawxcm_dfpt
5109 : : !!
5110 : : !! FUNCTION
5111 : : !! Compute first-order change of XC potential and contribution to
5112 : : !! 2nd-order change of XC energy inside a PAW sphere.
5113 : : !! LDA+GGA - USE A DEVELOPMENT OF THE DENSITY OVER (L,M) MOMENTS
5114 : : !!
5115 : : !! INPUTS
5116 : : !! corexc1(cplex_den*nrad)=first-order change of core density on radial grid
5117 : : !! cplex_den= if 1, 1st-order densities are REAL, if 2, COMPLEX
5118 : : !! cplex_vxc= if 1, 1st-order XC potential is complex, if 2, COMPLEX
5119 : : !! ixc= choice of exchange-correlation scheme
5120 : : !! kxc(nrad,lm_size,nkxc)=GS xc kernel
5121 : : !! lm_size=size of density array rhor (see below)
5122 : : !! lmselect(lm_size)=select the non-zero LM-moments of input density rhor1
5123 : : !! nhat1(cplex_den*nrad,lm_size,nspden)=first-order change of compensation density
5124 : : !! (total in 1st half and spin-up in 2nd half if nspden=2)
5125 : : !! nkxc=second dimension of the kxc array
5126 : : !! non_magnetic_xc= if true, handle density/potential as non-magnetic (even if it is)
5127 : : !! nrad=size of radial mesh for densities/potentials (might be different from pawrad%mesh_size)
5128 : : !! nspden=number of spin-density components
5129 : : !! option=0 compute both 2nd-order XC energy and 1st-order potential
5130 : : !! 1 compute only 1st-order XC potential
5131 : : !! 2 compute only 2nd-order XC energy, XC potential is temporary computed here
5132 : : !! 3 compute only 2nd-order XC energy, XC potential is input in vxc1(:)
5133 : : !! pawang <type(pawang_type)>=paw angular mesh and related data
5134 : : !! pawrad <type(pawrad_type)>=paw radial mesh and related data
5135 : : !! rhor1(cplex_den*nrad,lm_size,nspden)=first-order change of density
5136 : : !! usecore= 1 if core density has to be used in Exc/Vxc ; 0 otherwise
5137 : : !! usexcnhat= 0 if compensation density does not have to be used
5138 : : !! 1 if compensation density has to be used in d2Exc only
5139 : : !! 2 if compensation density (nhat) has to be used in d2Exc and Vxc1
5140 : : !! xclevel= XC functional level
5141 : : !!
5142 : : !! OUTPUT
5143 : : !! == if option=0 or 2 or 3 ==rho1_updn
5144 : : !! d2enxc=returned exchange-cor. contribution to 2nd-order XC energy
5145 : : !!
5146 : : !! SIDE EFFECTS
5147 : : !! vxc1(cplex_vxc*nrad,pawang%angl_size,nspden)=1st-order XC potential
5148 : : !! Output if option==0 or 1
5149 : : !! Unused if option==2
5150 : : !! Input if option==3
5151 : : !!
5152 : : !! SOURCE
5153 : :
5154 : 34970 : subroutine pawxcm_dfpt(corexc1,cplex_den,cplex_vxc,d2enxc,ixc,kxc,lm_size,lmselect,nhat1,&
5155 : 34970 : & nkxc,non_magnetic_xc,nrad,nspden,option,pawang,pawrad,rhor1,usecore,&
5156 : 34970 : & usexcnhat,vxc1,xclevel,&
5157 : : & d2enxc_im) ! optional
5158 : :
5159 : : !Arguments ------------------------------------
5160 : : !scalars
5161 : : integer,intent(in) :: cplex_den,cplex_vxc,ixc,lm_size,nkxc,nrad,nspden,option
5162 : : integer,intent(in) :: usecore,usexcnhat,xclevel
5163 : : logical,intent(in) :: non_magnetic_xc
5164 : : real(dp),intent(out) :: d2enxc
5165 : : real(dp),intent(out),optional :: d2enxc_im
5166 : : type(pawang_type),intent(in) :: pawang
5167 : : type(pawrad_type),intent(in) :: pawrad
5168 : : !arrays
5169 : : logical,intent(in) :: lmselect(lm_size)
5170 : : real(dp),intent(in) :: corexc1(cplex_den*nrad)
5171 : : real(dp),intent(in) :: kxc(nrad,lm_size,nkxc)
5172 : : real(dp),intent(in) :: nhat1(cplex_den*nrad,lm_size,nspden*((usexcnhat+1)/2))
5173 : : real(dp),intent(in) :: rhor1(cplex_den*nrad,lm_size,nspden)
5174 : : real(dp),intent(inout),target :: vxc1(cplex_vxc*nrad,lm_size,nspden)
5175 : :
5176 : : !Local variables-------------------------------
5177 : : !scalars
5178 : : integer :: ii,ilm,iplex,ir,ivxc,jr,kr,nkxc_cur
5179 : : logical :: need_impart
5180 : : real(dp) :: invsqfpi,ro1i,ro1r,sqfpi,sqfpi2,v1i,v1r,vxcrho
5181 : : character(len=500) :: msg
5182 : : !arrays
5183 : : integer,parameter :: ikxc(4)=(/1,2,2,3/),irho(4)=(/1,2,1,2/)
5184 : : ! real(dp) :: tsec(2)
5185 : 34970 : real(dp),allocatable :: ff(:),gg(:),rho1_updn(:,:,:)
5186 : 34970 : real(dp),allocatable :: v1sum(:),v2sum(:,:)
5187 : 34970 : real(dp),pointer :: vxc1_(:,:,:)
5188 : :
5189 : : !************************************************************************
5190 : :
5191 : : !NOTE (MT)
5192 : : !lmselect and lm_size are not necessarily the same for densities, kxc and vxc1
5193 : : !This is not taken into account for the moment, but has to be programmed...
5194 : :
5195 : : !----------------------------------------------------------------------
5196 : : !----- Check options
5197 : : !----------------------------------------------------------------------
5198 : :
5199 : 34970 : if(option<0.or.option>3) then
5200 : 0 : msg='wrong option!'
5201 : 0 : LIBPAW_BUG(msg)
5202 : : end if
5203 [ + + ]: 34970 : if(option/=3) then
5204 : 18026 : call pawxc_get_nkxc(nkxc_cur,nspden,xclevel)
5205 [ - + ]: 18026 : if(nkxc/=nkxc_cur) then
5206 : 0 : msg='Wrong size for kxc array!'
5207 : 0 : LIBPAW_BUG(msg)
5208 : : end if
5209 : : end if
5210 [ - + - - ]: 34970 : if(nspden==4.and.option/=3) then
5211 : 0 : msg='nspden=4 not implemented (for vxc)!'
5212 : 0 : LIBPAW_ERROR(msg)
5213 : : end if
5214 [ + + ]: 34970 : if (option/=1) then
5215 [ - + ]: 25578 : if (nrad<pawrad%int_meshsz) then
5216 : 0 : msg='When option=0,2,3, nrad must be greater than pawrad%int_meshsz!'
5217 : 0 : LIBPAW_BUG(msg)
5218 : : end if
5219 : : end if
5220 : :
5221 : : !----------------------------------------------------------------------
5222 : : !----- Initializations
5223 : : !----------------------------------------------------------------------
5224 : :
5225 : : !Arrays dimensions and constants
5226 : 34970 : need_impart=present(d2enxc_im)
5227 : 34970 : sqfpi=sqrt(four_pi);sqfpi2=half*sqfpi;invsqfpi=one/sqfpi
5228 : :
5229 : : !Initializations of outputs
5230 [ + + ]: 34970 : if (option/=1) then
5231 : 25578 : d2enxc=zero
5232 [ + + ]: 25578 : if (need_impart) d2enxc_im=zero
5233 : : end if
5234 [ + + + + : 55491634 : if (option<=1) vxc1(:,:,:)=zero
+ + + + ]
5235 : :
5236 : : !Special case: no XC applied
5237 [ + - + + : 34970 : if (ixc==0.or.(nkxc==0.and.option/=3)) then
- + ]
5238 : 0 : msg='Note that no xc is applied (ixc=0). Returning'
5239 : 0 : LIBPAW_WARNING(msg)
5240 : : return
5241 : : end if
5242 : :
5243 : : !----------------------------------------------------------------------
5244 : : !----- Build several densities
5245 : : !----------------------------------------------------------------------
5246 : :
5247 : : !rho1_updn contains the effective 1st-order density used for XC
5248 : : !with 1st-order core density and/or 1st-order compensation density eventually included
5249 : : !-----------------------------------------------------------------
5250 [ - + + - : 174850 : LIBPAW_ALLOCATE(rho1_updn,(cplex_den*nrad,lm_size,nspden))
- + + - -
+ + - + -
+ - - + -
+ ]
5251 [ + + + + : 197098690 : rho1_updn(:,:,:)=rhor1(:,:,:)
+ + ]
5252 [ + + + + : 68821036 : if (usexcnhat==2) rho1_updn(:,:,:)=rho1_updn(:,:,:)+nhat1(:,:,:)
+ + + + ]
5253 [ - + ]: 34970 : if (usecore==1) then
5254 [ # # ]: 0 : if (nspden==1.or.nspden==4) then
5255 [ # # ]: 0 : rho1_updn(:,1,1)=rho1_updn(:,1,1)+sqfpi*corexc1(:)
5256 [ # # ]: 0 : else if (nspden==2) then
5257 [ # # ]: 0 : rho1_updn(:,1,1)=rho1_updn(:,1,1)+sqfpi*corexc1(:)
5258 [ # # ]: 0 : rho1_updn(:,1,2)=rho1_updn(:,1,2)+sqfpi2*corexc1(:)
5259 : : end if
5260 : : end if
5261 : :
5262 : : !Optionally suppressed magnetic part
5263 [ - + ]: 34970 : if(non_magnetic_xc) then
5264 [ # # # # : 0 : if(nspden==2) rho1_updn(:,:,2)=rho1_updn(:,:,1)*half
# # ]
5265 [ # # # # : 0 : if(nspden==4) rho1_updn(:,:,2:4)=zero
# # # # ]
5266 : : endif
5267 : :
5268 : : !In case of collinear magnetism, separate up and down contributions
5269 [ + + ]: 34970 : if (nspden==2) then
5270 [ - + + - : 2544 : LIBPAW_ALLOCATE(ff,(cplex_den*nrad))
+ - + - -
+ - + ]
5271 [ + + ]: 15264 : do ilm=1,lm_size
5272 [ + + ]: 5060016 : ff(:)=rho1_updn(:,ilm,2)
5273 [ + + ]: 5060016 : rho1_updn(:,ilm,2)=rho1_updn(:,ilm,1)-ff(:)
5274 [ + + ]: 5060864 : rho1_updn(:,ilm,1)=ff(:)
5275 : : end do
5276 [ - + ]: 848 : LIBPAW_DEALLOCATE(ff)
5277 : : end if
5278 : :
5279 : : !
5280 : : !----------------------------------------------------------------------
5281 : : !----- Accumulate and store 1st-order change of XC potential
5282 : : !----------------------------------------------------------------------
5283 : :
5284 [ + + ]: 34970 : if (option==2) then
5285 [ - + + - : 43170 : LIBPAW_POINTER_ALLOCATE(vxc1_,(cplex_vxc*nrad,lm_size,nspden))
- + + - -
+ + - + -
+ - - + -
+ ]
5286 : : else
5287 : 26336 : vxc1_ => vxc1
5288 : : end if
5289 : :
5290 [ + + ]: 34970 : if (option/=3) then
5291 : :
5292 [ + + + + : 106453636 : vxc1_=zero
+ + ]
5293 [ - + + - : 54078 : LIBPAW_ALLOCATE(v1sum,(cplex_vxc*nrad))
+ - + - -
+ - + ]
5294 [ - + + - : 72104 : LIBPAW_ALLOCATE(v2sum,(cplex_vxc*nrad,lm_size))
- + + - +
- + - - +
- + ]
5295 : :
5296 [ + + ]: 38020 : do ii=1,3*nspden-2
5297 [ + + ]: 19994 : ivxc=1;if (ii>2) ivxc=2
5298 : :
5299 : : ! === Vxc1 and Rho1 are REAL
5300 [ + + + - ]: 38020 : if (cplex_vxc==1.and.cplex_den==1) then ! cplex_vxc==1 and cplex_den==1
5301 : : call pawxcsum(1,1,1,lmselect,lmselect,lm_size,nrad,1,2,pawang,&
5302 : 18602 : & kxc(:,:,ikxc(ii)),rho1_updn(:,:,irho(ii)),v1sum,v2sum)
5303 [ + + ]: 10184144 : vxc1_(:,1,ivxc)=vxc1_(:,1,ivxc)+invsqfpi*(v1sum(:)+kxc(:,1,ikxc(ii))*rho1_updn(:,1,irho(ii)))
5304 [ + + ]: 191066 : do ilm=2,lm_size
5305 : : vxc1_(:,ilm,ivxc)=vxc1_(:,ilm,ivxc)+v2sum(:,ilm) &
5306 : : & +invsqfpi*(kxc(:,ilm,ikxc(ii))*rho1_updn(:,1 ,irho(ii)) &
5307 [ + + ]: 91940458 : & +kxc(:,1 ,ikxc(ii))*rho1_updn(:,ilm,irho(ii)))
5308 : : end do
5309 : :
5310 : : ! === At least one of Vxc1 or Rho1 is COMPLEX
5311 : : else
5312 : : call pawxcsum(1,cplex_den,cplex_vxc,lmselect,lmselect,lm_size,nrad,1,2,pawang,&
5313 : 1392 : & kxc(:,:,ikxc(ii)),rho1_updn(:,:,irho(ii)),v1sum,v2sum)
5314 [ + + ]: 675120 : do ir=1,nrad
5315 : 673728 : jr=cplex_den*(ir-1);kr=cplex_vxc*(ir-1)
5316 [ + + ]: 2022576 : do iplex=1,1+(cplex_den*cplex_vxc)/4
5317 : 1347456 : jr=jr+1;kr=kr+1
5318 : 1347456 : vxc1_(kr,1,ivxc)=vxc1_(kr,1,ivxc)+invsqfpi*(v1sum(kr)+kxc(ir,1,ikxc(ii))*rho1_updn(jr,1,irho(ii)))
5319 [ + + ]: 12800832 : do ilm=2,lm_size
5320 : : vxc1_(kr,ilm,ivxc)=vxc1_(kr,ilm,ivxc)+v2sum(kr,ilm) &
5321 : : & +invsqfpi*(kxc(ir,ilm,ikxc(ii))*rho1_updn(jr,1 ,irho(ii)) &
5322 : 12127104 : & +kxc(ir,1 ,ikxc(ii))*rho1_updn(jr,ilm,irho(ii)))
5323 : : end do
5324 : : end do
5325 : : end do
5326 : :
5327 : : end if ! cplex_den and vxc_den
5328 : : end do ! ii=1,3*nspden-2
5329 : :
5330 [ - + ]: 18026 : LIBPAW_DEALLOCATE(v1sum)
5331 [ - + ]: 18026 : LIBPAW_DEALLOCATE(v2sum)
5332 : :
5333 : : end if
5334 : :
5335 : : !----------------------------------------------------------------------
5336 : : !----- Accumulate and store 2nd-order change of XC energy
5337 : : !----------------------------------------------------------------------
5338 [ + + ]: 34970 : if (option/=1) then
5339 : :
5340 [ + - ]: 25578 : if (.not.non_magnetic_xc) then
5341 : : ! For usexnhat=1 particular case, add now compensation density
5342 [ - + ]: 25578 : if (usexcnhat==1) then
5343 [ # # # # ]: 0 : rho1_updn(:,:,1)=rho1_updn(:,:,1)+nhat1(:,:,nspden)
5344 [ # # # # : 0 : if (nspden==2) rho1_updn(:,:,2)=rho1_updn(:,:,2)+nhat1(:,:,1)-nhat1(:,:,2)
# # ]
5345 : : end if
5346 : : else
5347 : : ! Has to be magnetic here
5348 [ # # # # : 0 : rho1_updn(:,:,:)=rhor1(:,:,:)
# # ]
5349 [ # # # # : 0 : if (usexcnhat>0) rho1_updn(:,:,:)=rho1_updn(:,:,:)+nhat1(:,:,:)
# # # # ]
5350 [ # # ]: 0 : if (usecore==1) then
5351 [ # # ]: 0 : if (nspden==1.or.nspden==4) then
5352 [ # # ]: 0 : rho1_updn(:,1,1)=rho1_updn(:,1,1)+sqfpi*corexc1(:)
5353 [ # # ]: 0 : else if (nspden==2) then
5354 [ # # ]: 0 : rho1_updn(:,1,1)=rho1_updn(:,1,1)+sqfpi*corexc1(:)
5355 [ # # ]: 0 : rho1_updn(:,1,2)=rho1_updn(:,1,2)+sqfpi2*corexc1(:)
5356 : : end if
5357 : : end if
5358 : : end if
5359 : :
5360 [ - + + - : 76734 : LIBPAW_ALLOCATE(ff,(nrad))
+ - + - -
+ - + -
+ ]
5361 [ + + ]: 14373014 : ff=zero
5362 [ + + ]: 25578 : if (need_impart) then
5363 [ - + + - : 33888 : LIBPAW_ALLOCATE(gg,(nrad))
- + - + ]
5364 [ + + ]: 9499502 : gg=zero
5365 : : end if
5366 : :
5367 : : ! ----- Calculate d2Exc=Int[Vxc^(1)^*(r).n^(1)(r).dr]
5368 [ + + ]: 51668 : do ii=1,nspden
5369 : : ! === Vxc1 and Rho1 are REAL
5370 [ + + + - ]: 51668 : if (cplex_vxc==1.and.cplex_den==1) then
5371 [ + + ]: 261364 : do ilm=1,lm_size
5372 [ + + + + ]: 79920166 : if (lmselect(ilm)) ff(:)=ff(:)+vxc1_(:,ilm,ii)*rho1_updn(:,ilm,ii)
5373 : : end do
5374 : : ! === Vxc1 and Rho1 are COMPLEX
5375 [ + - - + ]: 1048 : else if (cplex_vxc==2.and.cplex_den==2) then ! cplex_vxc==2 and cplex_den==2
5376 [ + + ]: 1048 : if (.not.need_impart) then ! Real part only
5377 [ + + ]: 6640 : do ilm=1,lm_size
5378 [ + + ]: 6640 : if (lmselect(ilm)) then
5379 [ + + ]: 2572440 : do ir=1,nrad
5380 : 2567136 : jr=2*ir;v1r=vxc1_(jr-1,ilm,ii);v1i=vxc1_(jr,ilm,ii)
5381 : 2567136 : ro1r=rho1_updn(jr-1,ilm,ii);ro1i=rho1_updn(jr,ilm,ii)
5382 : 2572440 : ff(ir)=ff(ir)+v1r*ro1r+v1i*ro1i
5383 : : end do
5384 : : end if
5385 : : end do
5386 : : else ! Real and imaginary parts
5387 [ + + ]: 3840 : do ilm=1,lm_size
5388 [ + + ]: 3840 : if (lmselect(ilm)) then
5389 [ + + ]: 1520960 : do ir=1,nrad
5390 : 1517824 : jr=2*ir;v1r=vxc1_(jr-1,ilm,ii);v1i=vxc1_(jr,ilm,ii)
5391 : 1517824 : ro1r=rho1_updn(jr-1,ilm,ii);ro1i=rho1_updn(jr,ilm,ii)
5392 : 1517824 : ff(ir)=ff(ir)+v1r*ro1r+v1i*ro1i
5393 : 1520960 : gg(ir)=gg(ir)+v1r*ro1i-v1i*ro1r
5394 : : end do
5395 : : end if
5396 : : end do
5397 : : end if ! need_impart
5398 : : ! === Vxc1 and Rho1 are REAL and COMPLEX
5399 : : else
5400 : : v1i=zero;ro1i=zero
5401 [ # # ]: 0 : do ilm=1,lm_size
5402 [ # # ]: 0 : if (lmselect(ilm)) then
5403 [ # # ]: 0 : do ir=1,nrad
5404 [ # # ]: 0 : jr=cplex_vxc*(ir-1)+1;v1r=vxc1_(jr,ilm,ii);;if(cplex_vxc==2)v1i=vxc1_(jr+1,ilm,ii)
5405 [ # # ]: 0 : jr=cplex_den*(ir-1)+1;ro1r=rho1_updn(jr,ilm,ii);if(cplex_den==2)ro1i=rho1_updn(jr+1,ilm,ii)
5406 : 0 : ff(ir)=ff(ir)+v1r*ro1r+v1i*ro1i
5407 [ # # ]: 0 : if (need_impart) gg(ir)=gg(ir)+v1r*ro1i-v1i*ro1r
5408 : : end do
5409 : : end if
5410 : : end do
5411 : : end if ! cplex_vxc and cplex_den
5412 : : end do ! ii=1,nspden
5413 : :
5414 [ + + ]: 14373014 : ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2
5415 : 25578 : call simp_gen(vxcrho,ff,pawrad)
5416 : 25578 : d2enxc=d2enxc+vxcrho
5417 [ - + ]: 25578 : LIBPAW_DEALLOCATE(ff)
5418 : :
5419 [ + + ]: 51156 : if (need_impart) then
5420 [ + + ]: 9499502 : gg(1:nrad)=gg(1:nrad)*pawrad%rad(1:nrad)**2
5421 : 16944 : call simp_gen(vxcrho,gg,pawrad)
5422 : 16944 : d2enxc_im=d2enxc_im+vxcrho
5423 [ - + ]: 16944 : LIBPAW_DEALLOCATE(gg)
5424 : : end if
5425 : :
5426 : : end if
5427 : :
5428 [ - + ]: 34970 : LIBPAW_DEALLOCATE(rho1_updn)
5429 [ + + ]: 34970 : if (option==2) then
5430 [ - + ]: 8634 : LIBPAW_POINTER_DEALLOCATE(vxc1_)
5431 : : end if
5432 : :
5433 [ - + - + : 69940 : end subroutine pawxcm_dfpt
- + ]
5434 : : !!***
5435 : :
5436 : : !----------------------------------------------------------------------
5437 : :
5438 : : !!****f* m_pawxc/pawxcmpositron
5439 : : !! NAME
5440 : : !! pawxcmpositron
5441 : : !!
5442 : : !! FUNCTION
5443 : : !! Compute electron-positron correlation potential and energies inside a PAW sphere
5444 : : !! LDA+GGA - USE A DEVELOPMENT OF THE DENSITY OVER (L,M) MOMENTS
5445 : : !! Driver of XC functionals.
5446 : : !!
5447 : : !! INPUTS
5448 : : !! calctype=type of electron-positron calculation:
5449 : : !! calctype=1 : positron in electronic density
5450 : : !! calctype=2 : electrons in positronic density
5451 : : !! corexc(nrad)=electron core density on radial grid
5452 : : !! ixcpositron=choice of electron-positron XC scheme
5453 : : !! lm_size=size of density array rhor (see below)
5454 : : !! lmselect (lm_size)=select the non-zero LM-moments of input density rhor (see below)
5455 : : !! lmselect_ep(lm_size)=select the non-zero LM-moments of input density rhor_ep (see below)
5456 : : !! nhat (nrad,lm_size,nspden)=compensation density corresponding to rhor
5457 : : !! nhat_ep(nrad,lm_size,nspden)=compensation density corresponding to rhor_ep
5458 : : !! nrad=size of radial mesh for densities/potentials (might be different from pawrad%mesh_size)
5459 : : !! nspden=number of spin-density components
5460 : : !! option=0 compute both XC energies (direct+double-counting) and potential
5461 : : !! 1 compute only XC potential
5462 : : !! 2 compute only XC energies (direct+double-counting)
5463 : : !! 3 compute only XC energy by direct scheme
5464 : : !! 4 compute only XC energy by direct scheme for spherical part of the density
5465 : : !! pawang <type(pawang_type)>=paw angular mesh and related data
5466 : : !! pawrad <type(pawrad_type)>=paw radial mesh and related data
5467 : : !! pawxcdev=order of Vxc development
5468 : : !! posdensity0_limit=True if we are in the zero positron density limit
5469 : : !! rhor(nrad,lm_size,nspden)=electron (or positron) density in real space
5470 : : !! (total in 1st half and spin-up in 2nd half if nspden=2)
5471 : : !! Contents depends on calctype value:
5472 : : !! calctype=1: rhor is the positronic density
5473 : : !! calctype=2: rhor is the electronic density
5474 : : !! rhor_ep(nrad,lm_size,nspden)=electron (or positron) density in real space
5475 : : !! (total in 1st half and spin-up in 2nd half if nspden=2)
5476 : : !! Contents depends on calctype value:
5477 : : !! calctype=1: rhor_ep is the electronic density
5478 : : !! calctype=2: rhor_ep is the positronic density
5479 : : !! usecore= 1 if core density has to be used in Exc/Vxc for the electronic density ; 0 otherwise
5480 : : !! usexcnhat= 0 if compensation density does not have to be used
5481 : : !! 1 if compensation density has to be used in double counting energy term only
5482 : : !! 2 if compensation density (nhat) has to be used in Exc/Vxc and double counting energy term
5483 : : !! xc_denpos= lowest allowed density (usually for the computation of the XC functionals)
5484 : : !!
5485 : : !! OUTPUT
5486 : : !! == if option==0, 2, 3, or 4 ==
5487 : : !! enxc=returned exchange and correlation energy (hartree)
5488 : : !! == if option==0 or 2 ==
5489 : : !! enxcdc=returned exchange-cor. contribution to double-counting energy
5490 : : !! == if option==0 or 1 ==
5491 : : !! vxc(nrad,lm_size,nspden)=xc potential
5492 : : !! (spin up in 1st half and spin-down in 2nd half if nspden=2)
5493 : : !!
5494 : : !! NOTES
5495 : : !!
5496 : : !! SOURCE
5497 : :
5498 : 11752 : subroutine pawxcmpositron(calctype,corexc,enxc,enxcdc,ixcpositron,lm_size,lmselect,lmselect_ep,&
5499 : 11752 : & nhat,nhat_ep,nrad,nspden,option,pawang,pawrad,pawxcdev,posdensity0_limit,&
5500 : 11752 : & rhor,rhor_ep,usecore,usexcnhat,vxc,xc_denpos)
5501 : :
5502 : : !Arguments ------------------------------------
5503 : : !scalars
5504 : : integer,intent(in) :: calctype,ixcpositron,lm_size,nrad,nspden,option,pawxcdev,usecore
5505 : : integer,intent(in) :: usexcnhat
5506 : : logical,intent(in) :: posdensity0_limit
5507 : : real(dp),intent(in) :: xc_denpos
5508 : : real(dp),intent(out) :: enxc,enxcdc
5509 : : type(pawang_type),intent(in) :: pawang
5510 : : type(pawrad_type),intent(in) :: pawrad
5511 : : !arrays
5512 : : logical,intent(in) :: lmselect(lm_size),lmselect_ep(lm_size)
5513 : : real(dp),intent(in) :: corexc(nrad)
5514 : : real(dp),intent(in) :: nhat (nrad,lm_size,nspden*((usexcnhat+1)/2))
5515 : : real(dp),intent(in) :: nhat_ep(nrad,lm_size,nspden*((usexcnhat+1)/2))
5516 : : real(dp),intent(in) :: rhor (nrad,lm_size,nspden)
5517 : : real(dp),intent(in) :: rhor_ep(nrad,lm_size,nspden)
5518 : : real(dp),intent(out) :: vxc(nrad,lm_size,nspden)
5519 : :
5520 : : !Local variables-------------------------------
5521 : : !scalars
5522 : : integer :: ilm,ir,ir1,ir2,iwarn,iwarnp,jr
5523 : : real(dp),parameter :: delta=1.d-4
5524 : : real(dp) :: fact,invsqfpi,sqfpi,rhomin
5525 : : character(len=500) :: msg
5526 : : !arrays
5527 : 11752 : real(dp),allocatable :: d1vxc(:,:),d2vxc(:,:),fxc_(:),ff(:),fxci(:),gg(:)
5528 : 11752 : real(dp),allocatable :: rho_(:),rhotot(:,:),rhotot_ep(:,:),rhoinv(:),rhoinv_ep(:)
5529 : 11752 : real(dp),allocatable :: rhosph(:),rhosph_ep(:),v1sum(:,:),v2sum(:,:,:)
5530 : 11752 : real(dp),allocatable :: vxce1(:),vxce1_ep(:),vxce2(:),vxce2_ep(:)
5531 : 11752 : real(dp),allocatable :: vxcp1(:),vxcp1_ep(:),vxcp2(:),vxcp2_ep(:)
5532 : 11752 : real(dp),allocatable :: vxcei(:),vxcpi(:)
5533 : :
5534 : : !************************************************************************
5535 : :
5536 : : !----- Check options
5537 [ - + ]: 11752 : if(calctype/=1.and.calctype/=2) then
5538 : 0 : msg='Invalid value for calctype'
5539 : 0 : LIBPAW_BUG(msg)
5540 : : end if
5541 [ + - ]: 11752 : if (option/=1) then
5542 [ - + ]: 11752 : if (nrad<pawrad%int_meshsz) then
5543 : 0 : msg='When option=0,2,3,4, nrad must be greater than pawrad%int_meshsz!'
5544 : 0 : LIBPAW_BUG(msg)
5545 : : end if
5546 : : end if
5547 : :
5548 : : !----------------------------------------------------------------------
5549 : : !----- Initializations
5550 : : !----------------------------------------------------------------------
5551 : :
5552 : : !Initializations and constants
5553 : 11752 : iwarn=0;iwarnp=1
5554 : 11752 : sqfpi=sqrt(four_pi)
5555 : 11752 : invsqfpi=one/sqfpi
5556 : :
5557 : : !Initializations of output arrays
5558 [ + - ]: 11752 : if (option/=1) enxc=zero
5559 [ + - ]: 11752 : if (option==0.or.option==2) enxcdc=zero
5560 [ + - + + : 141640664 : if (option<3) vxc(:,:,:)=zero
+ + + + ]
5561 : :
5562 [ - + ]: 11752 : if (ixcpositron==0) then ! No xc at all is applied (usually for testing)
5563 : 0 : msg='Note that no xc is applied (ixc=0). Returning'
5564 : 0 : LIBPAW_WARNING(msg)
5565 : 0 : return
5566 : : end if
5567 : :
5568 : : !----------------------------------------------------------------------
5569 : : !----- Build several densities
5570 : : !----------------------------------------------------------------------
5571 : :
5572 : : !rhotot/rhotot_ep contain the effective total densities used for XC
5573 : : !with core density and/or compensation density eventually included
5574 : : !-----------------------------------------------------------------
5575 : : !Input density
5576 [ - + + - : 47008 : LIBPAW_ALLOCATE(rhotot,(nrad,lm_size))
- + + - +
- + - - +
- + ]
5577 [ - + + - : 35256 : LIBPAW_ALLOCATE(rhotot_ep,(nrad,lm_size))
- + + - -
+ - + ]
5578 [ + + + + ]: 141628912 : rhotot (:,:)=rhor (:,:,1)
5579 [ + + + + ]: 141628912 : rhotot_ep(:,:)=rhor_ep(:,:,1)
5580 : : !Eventually add compensation density
5581 [ + + ]: 11752 : if (usexcnhat==2) then
5582 [ + + + + ]: 2113048 : rhotot (:,:)=rhotot (:,:)+nhat (:,:,1)
5583 [ + + + + ]: 2113048 : rhotot_ep(:,:)=rhotot_ep(:,:)+nhat_ep(:,:,1)
5584 : : end if
5585 : : !Eventually add core density
5586 [ + + ]: 11752 : if (usecore==1) then
5587 [ + + + + ]: 6223436 : if (calctype==1) rhotot_ep(:,1)=rhotot_ep(:,1)+sqfpi*corexc(:)
5588 [ + + + + ]: 9479940 : if (calctype==2) rhotot (:,1)=rhotot (:,1)+sqfpi*corexc(:)
5589 : : end if
5590 : :
5591 : : !rhoSPH/rhoSPH_ep contain the spherical part of effective densities
5592 : : !(including Y00 spherical harmonic)
5593 : : !-----------------------------------------------------------------
5594 [ - + + - : 35256 : LIBPAW_ALLOCATE(rhosph,(nrad))
+ - + - -
+ - + ]
5595 [ - + + - : 23504 : LIBPAW_ALLOCATE(rhosph_ep,(nrad))
- + - + ]
5596 : :
5597 [ + + ]: 15735240 : rhosph (:)=rhotot (:,1)*invsqfpi
5598 [ + + ]: 15735240 : rhosph_ep(:)=rhotot_ep(:,1)*invsqfpi
5599 : :
5600 : : !Make spherical densities positive
5601 [ + + ]: 11752 : if (calctype==1) then
5602 [ + + ]: 4782 : if (.not.posdensity0_limit) then
5603 : 56 : call pawxc_mkdenpos_wrapper(iwarnp,nrad,1,1,rhosph,xc_denpos)
5604 : : end if
5605 : 4782 : call pawxc_mkdenpos_wrapper(iwarn ,nrad,1,1,rhosph_ep,xc_denpos)
5606 [ + - ]: 6970 : else if (calctype==2) then
5607 : 6970 : call pawxc_mkdenpos_wrapper(iwarn ,nrad,1,1,rhosph,xc_denpos)
5608 [ + + ]: 6970 : if (.not.posdensity0_limit) then
5609 : 56 : call pawxc_mkdenpos_wrapper(iwarnp,nrad,1,1,rhosph_ep,xc_denpos)
5610 : : end if
5611 : : end if
5612 : :
5613 : : !----------------------------------------------------------------------
5614 : : !----- Compute Exc(rhoSPH,rhoSPH_ep) and Vxc(rhoSPH,rhoSPH_ep)
5615 : : !----------------------------------------------------------------------
5616 : :
5617 [ - + + - : 23504 : LIBPAW_ALLOCATE(fxci,(nrad))
- + - + ]
5618 [ - + + - : 23504 : LIBPAW_ALLOCATE(vxcei,(nrad))
- + - + ]
5619 [ - + + - : 23504 : LIBPAW_ALLOCATE(vxcpi,(nrad))
- + - + ]
5620 : 11752 : call pawxcsphpositron(calctype,fxci,ixcpositron,nrad,pawrad,posdensity0_limit,rhosph,rhosph_ep,vxcei,vxcpi)
5621 : :
5622 : : !----------------------------------------------------------------------
5623 : : !----- Compute numerical derivatives of Vxc (by finite diff. scheme)
5624 : : !----------------------------------------------------------------------
5625 : :
5626 [ + - ]: 11752 : if (option/=4) then
5627 : :
5628 [ - + + - : 23504 : LIBPAW_ALLOCATE(fxc_,(nrad))
- + - + ]
5629 [ - + + - : 23504 : LIBPAW_ALLOCATE(rho_,(nrad))
- + - + ]
5630 : :
5631 : : ! Compute Vxc for (rho+delta_rho,rho_ep)
5632 [ - + + - : 23504 : LIBPAW_ALLOCATE(vxce1,(nrad))
- + - + ]
5633 [ - + + - : 23504 : LIBPAW_ALLOCATE(vxcp1,(nrad))
- + - + ]
5634 [ + + ]: 15735240 : rho_(:)=(one+delta)*rhosph(:)
5635 : 11752 : call pawxcsphpositron(calctype,fxc_,ixcpositron,nrad,pawrad,posdensity0_limit,rho_,rhosph_ep,vxce1,vxcp1)
5636 : :
5637 : : ! Compute Vxc for(rho-delta_rho,rho_ep)
5638 [ - + + - : 23504 : LIBPAW_ALLOCATE(vxce2,(nrad))
- + - + ]
5639 [ - + + - : 23504 : LIBPAW_ALLOCATE(vxcp2,(nrad))
- + - + ]
5640 [ + + ]: 15735240 : rho_(:)=(one-delta)*rhosph(:)
5641 : 11752 : call pawxcsphpositron(calctype,fxc_,ixcpositron,nrad,pawrad,posdensity0_limit,rho_,rhosph_ep,vxce2,vxcp2)
5642 : :
5643 : : ! Compute Vxc for (rho,rho_ep+delta_rho_ep)
5644 [ - + + - : 23504 : LIBPAW_ALLOCATE(vxce1_ep,(nrad))
- + - + ]
5645 [ - + + - : 23504 : LIBPAW_ALLOCATE(vxcp1_ep,(nrad))
- + - + ]
5646 [ + + ]: 15735240 : rho_(:)=(one+delta)*rhosph_ep(:)
5647 : 11752 : call pawxcsphpositron(calctype,fxc_,ixcpositron,nrad,pawrad,posdensity0_limit,rhosph,rho_,vxce1_ep,vxcp1_ep)
5648 : :
5649 : : ! Compute Vxc for (rho,rho_ep-delta_rho_ep)
5650 [ - + + - : 23504 : LIBPAW_ALLOCATE(vxce2_ep,(nrad))
- + - + ]
5651 [ - + + - : 23504 : LIBPAW_ALLOCATE(vxcp2_ep,(nrad))
- + - + ]
5652 [ + + ]: 15735240 : rho_(:)=(one-delta)*rhosph_ep(:)
5653 : 11752 : call pawxcsphpositron(calctype,fxc_,ixcpositron,nrad,pawrad,posdensity0_limit,rhosph,rho_,vxce2_ep,vxcp2_ep)
5654 : :
5655 [ - + ]: 11752 : LIBPAW_DEALLOCATE(fxc_)
5656 [ - + ]: 11752 : LIBPAW_DEALLOCATE(rho_)
5657 : :
5658 : : ! Store inverse of density finite step
5659 [ - + + - : 23504 : LIBPAW_ALLOCATE(rhoinv,(nrad))
- + - + ]
5660 [ - + + - : 23504 : LIBPAW_ALLOCATE(rhoinv_ep,(nrad))
- + - + ]
5661 : 15735240 : fact=one/delta
5662 [ + + ]: 15735240 : do ir=1,nrad
5663 [ + + ]: 15723488 : if (rhosph(ir)>rho_min) then
5664 : 15501351 : rhoinv(ir)=fact/rhosph(ir)
5665 : : else
5666 : 222137 : rhoinv(ir)=zero
5667 : : end if
5668 [ + + ]: 15735240 : if (rhosph_ep(ir)>rho_min) then
5669 : 15722788 : rhoinv_ep(ir)=fact/rhosph_ep(ir)
5670 : : else
5671 : 700 : rhoinv_ep(ir)=zero
5672 : : end if
5673 : : end do
5674 : :
5675 : : ! Compute numerical first derivatives of Vxc (by finite difference scheme)
5676 [ - + + - : 35256 : LIBPAW_ALLOCATE(d1vxc,(nrad,3))
+ - + - -
+ - + ]
5677 [ + + ]: 11752 : if (calctype==1) then
5678 [ + + ]: 6260050 : d1vxc(:,1)=(vxcp1 (:)-vxcp2 (:))*half*rhoinv (:) ! dVxc+/drho+
5679 [ + + ]: 6260050 : d1vxc(:,2)=(vxcp1_ep(:)-vxcp2_ep(:))*half*rhoinv_ep(:) ! dVxc+/drho-
5680 [ + + ]: 6260050 : d1vxc(:,3)=(vxce1_ep(:)-vxce2_ep(:))*half*rhoinv_ep(:) ! dVxc-/drho-
5681 [ + - ]: 6970 : else if (calctype==2) then
5682 [ + + ]: 9475190 : d1vxc(:,1)=(vxce1 (:)-vxce2 (:))*half*rhoinv (:) ! dVxc-/drho-
5683 [ + + ]: 9475190 : d1vxc(:,2)=(vxcp1 (:)-vxcp2 (:))*half*rhoinv (:) ! dVxc+/drho-
5684 : : ! d1vxc(:,2)=(vxce1_ep(:)-vxce2_ep(:))*half*rhoinv_ep(:) ! dVxc-/drho+
5685 [ + + ]: 9475190 : d1vxc(:,3)=(vxcp1_ep(:)-vxcp2_ep(:))*half*rhoinv_ep(:) ! dVxc+/drho+
5686 : : end if
5687 : :
5688 : : ! Compute numerical second derivatives of Vxc (by finite difference scheme)
5689 [ - + - - ]: 11752 : if (option<3.or.pawxcdev>1) then
5690 [ - + + - : 35256 : LIBPAW_ALLOCATE(d2vxc,(nrad,4))
+ - + - -
+ - + ]
5691 [ + + ]: 11752 : if (calctype==1) then
5692 [ + + ]: 6260050 : d2vxc(:,1)=(vxcp1 (:)+vxcp2 (:)-two*vxcpi(:))*rhoinv (:)**2 ! d2Vxc+/drho+_drho+
5693 [ + + ]: 6260050 : d2vxc(:,2)=(vxce1 (:)+vxce2 (:)-two*vxcei(:))*rhoinv (:)**2 ! d2Vxc-/drho+_drho+
5694 [ + + ]: 6260050 : d2vxc(:,3)=(vxcp1_ep(:)+vxcp2_ep(:)-two*vxcpi(:))*rhoinv_ep(:)**2 ! d2Vxc+/drho-_drho-
5695 [ + + ]: 6260050 : d2vxc(:,4)=(vxce1_ep(:)+vxce2_ep(:)-two*vxcei(:))*rhoinv_ep(:)**2 ! d2Vxc-/drho-_drho-
5696 [ + - ]: 6970 : else if (calctype==2) then
5697 [ + + ]: 9475190 : d2vxc(:,1)=(vxce1 (:)+vxce2 (:)-two*vxcei(:))*rhoinv (:)**2 ! d2Vxc-/drho-_drho-
5698 [ + + ]: 9475190 : d2vxc(:,2)=(vxcp1 (:)+vxcp2 (:)-two*vxcpi(:))*rhoinv (:)**2 ! d2Vxc+/drho-_drho-
5699 [ + + ]: 9475190 : d2vxc(:,3)=(vxce1_ep(:)+vxce2_ep(:)-two*vxcei(:))*rhoinv_ep(:)**2 ! d2Vxc-/drho+_drho+
5700 [ + + ]: 9475190 : d2vxc(:,4)=(vxcp1_ep(:)+vxcp2_ep(:)-two*vxcpi(:))*rhoinv_ep(:)**2 ! d2Vxc+/drho+_drho+
5701 : : end if
5702 : : end if ! option
5703 : :
5704 [ - + ]: 11752 : LIBPAW_DEALLOCATE(rhoinv)
5705 [ - + ]: 11752 : LIBPAW_DEALLOCATE(rhoinv_ep)
5706 [ - + ]: 11752 : LIBPAW_DEALLOCATE(vxce1)
5707 [ - + ]: 11752 : LIBPAW_DEALLOCATE(vxcp1)
5708 [ - + ]: 11752 : LIBPAW_DEALLOCATE(vxce2)
5709 [ - + ]: 11752 : LIBPAW_DEALLOCATE(vxcp2)
5710 [ - + ]: 11752 : LIBPAW_DEALLOCATE(vxce1_ep)
5711 [ - + ]: 11752 : LIBPAW_DEALLOCATE(vxcp1_ep)
5712 [ - + ]: 11752 : LIBPAW_DEALLOCATE(vxce2_ep)
5713 [ - + ]: 11752 : LIBPAW_DEALLOCATE(vxcp2_ep)
5714 : :
5715 : : end if ! option/=4
5716 : :
5717 [ - + ]: 11752 : LIBPAW_DEALLOCATE(rhosph)
5718 [ - + ]: 11752 : LIBPAW_DEALLOCATE(rhosph_ep)
5719 : :
5720 : : !----------------------------------------------------------------------
5721 : : !----- Compute useful sums of densities
5722 : : !----------------------------------------------------------------------
5723 : :
5724 : : if (option<3.or.option/=1) then
5725 : :
5726 : : ! Compute V1SUM1(r)=Sum_L{n^el_L(r)^2}
5727 : : ! V1SUM2(r)=Sum_L{n^el_L(r)*n^pos_L(r)}
5728 : : ! V1SUM3(r)=Sum_L{n^pos_L(r)^2}
5729 : : ! V2SUM1(r,L)=Sum_L1_L2{n^el_L1(r)*n^el_L2(r)*Gaunt_(L,L1,L2)}
5730 : : ! V2SUM2(r,L)=Sum_L1_L2{n^el_L1(r)*n^pos_L2(r)*Gaunt_(L,L1,L2)}
5731 : : ! V2SUM3(r,L)=Sum_L1_L2{n^pos_L1(r)*n^pos_L2(r)*Gaunt_(L,L1,L2)}
5732 [ + - ]: 11752 : if (pawxcdev>=1) then
5733 [ - + + - : 35256 : LIBPAW_ALLOCATE(v1sum,(nrad,3))
+ - + - -
+ - + ]
5734 : : else
5735 [ # # ]: 0 : LIBPAW_ALLOCATE(v1sum,(0,0))
5736 : : end if
5737 [ - + ]: 11752 : if (pawxcdev>=2) then
5738 [ # # # # : 0 : LIBPAW_ALLOCATE(v2sum,(nrad,lm_size,3))
# # # # #
# # # # #
# # # # ]
5739 : : else
5740 [ - + ]: 11752 : LIBPAW_ALLOCATE(v2sum,(0,0,0))
5741 : : end if
5742 : 11752 : call pawxcsum(1,1,1,lmselect,lmselect_ep,lm_size,nrad,3,pawxcdev,pawang,rhotot,rhotot_ep,v1sum,v2sum)
5743 : :
5744 : : end if !option
5745 : :
5746 : : !----------------------------------------------------------------------
5747 : : !----- Accumulate and store XC potential
5748 : : !----------------------------------------------------------------------
5749 : :
5750 [ + - ]: 11752 : if (option<3) then
5751 : :
5752 : : ! if (option==0.or.option==2) allocate(vxc_ep(nrad,lm_size))
5753 : :
5754 : : ! === First order development
5755 : : ! ---------------------------
5756 [ + - ]: 11752 : if (pawxcdev>=1) then
5757 [ + + + + ]: 6267020 : if (calctype==1) vxc(:,1,1)=vxcpi(:)*sqfpi
5758 [ + + + + ]: 9479972 : if (calctype==2) vxc(:,1,1)=vxcei(:)*sqfpi
5759 : : vxc(:,1,1)=vxc(:,1,1)+invsqfpi*(d2vxc(:,2)*v1sum(:,2) &
5760 [ + + ]: 15735240 : & +half*(d2vxc(:,1)*v1sum(:,1)+d2vxc(:,3)*v1sum(:,3)))
5761 [ + + ]: 105768 : do ilm=2,lm_size
5762 [ + + + + ]: 84912996 : if (lmselect(ilm)) vxc(:,ilm,1)=vxc(:,ilm,1)+d1vxc(:,1)*rhotot (:,ilm)
5763 [ + + + + ]: 83581456 : if (lmselect_ep(ilm)) vxc(:,ilm,1)=vxc(:,ilm,1)+d1vxc(:,2)*rhotot_ep(:,ilm)
5764 : : end do
5765 : : ! if (option==0.or.option==2) then
5766 : : ! if (calctype==1) vxc_ep(:,1)=vxcei(:)*sqfpi
5767 : : ! if (calctype==2) vxc_ep(:,1)=vxcpi(:)*sqfpi
5768 : : ! vxc_ep(:,1)=vxc_ep(:,1,1)+invsqfpi*(d2vxc(:,3)*v1sum(:,2) &
5769 : : ! & +half*(d2vxc(:,2)*v1sum(:,1)+d2vxc(:,4)*v1sum(:,3)))
5770 : : ! do ilm=2,lm_size
5771 : : ! if (lmselect(ilm)) vxc_ep(:,ilm)=vxc_ep(:,ilm)+d1vxc(:,2)*rhotot (:,ilm)
5772 : : ! if (lmselect_ep(ilm)) vxc_ep(:,ilm)=vxc_ep(:,ilm)+d1vxc(:,3)*rhotot_ep(:,ilm)
5773 : : ! end do
5774 : : ! end if
5775 : : end if ! pawxcdev>=1
5776 : :
5777 : : ! == 2nd order development
5778 : : ! ---------------------------
5779 [ - + ]: 11752 : if (pawxcdev>=2) then
5780 [ # # ]: 0 : do ilm=2,lm_size
5781 : : vxc(:,ilm,1)=vxc(:,ilm,1)+d2vxc(:,2)*v2sum(:,ilm,2) &
5782 [ # # ]: 0 : & +half*(d2vxc(:,1)*v2sum(:,ilm,1)+d2vxc(:,3)*v2sum(:,ilm,3))
5783 : : end do
5784 : : ! if (option==0.or.option==2) then
5785 : : ! do ilm=2,lm_size
5786 : : ! vxc_ep(:,ilm)=vxc_ep(:,ilm)+d2vxc(:,3)*v2sum(:,ilm,2) &
5787 : : ! & +half*(d2vxc(:,2)*v2sum(:,ilm,1)+d2vxc(:,4)*v2sum(:,ilm,3))
5788 : : ! end do
5789 : : ! end if
5790 : : end if !pawxcdev=2
5791 : :
5792 : : ! === Pathological case: if rho(r) is negative, interpolate Vxc
5793 : : ! -------------------------------------------------------------
5794 [ + - ]: 11752 : if (lmselect(1)) then
5795 : 11752 : rhomin=xc_denpos*(one+tol6)
5796 : 11752 : ir1=0;ir2=0
5797 [ + + ]: 15735240 : do ir=1,nrad
5798 [ + + ]: 15735240 : if (rhotot(ir,1)<rhomin) then
5799 [ + + ]: 222137 : if (ir1==0) ir1=ir-1
5800 : 222137 : ir2=ir+1
5801 [ + + ]: 15501351 : else if (ir1>0) then
5802 [ + + + - ]: 680 : if (ir1>1.or.ir2<nrad) then
5803 : 680 : fact=(vxc(ir2,1,1)-vxc(ir1,1,1))/(pawrad%rad(ir2)-pawrad%rad(ir1))
5804 [ + + ]: 51508 : do jr=ir1+1,ir2-1
5805 : 51508 : vxc(jr,1,1)=vxc(ir1,1,1)+fact*(pawrad%rad(jr)-pawrad%rad(ir1))
5806 : : end do
5807 : : end if
5808 : : ir1=0;ir2=0
5809 : : end if
5810 : : end do
5811 : : end if
5812 : : ! if (option==0.or.option==2) then
5813 : : ! if (lmselect_ep(1)) then
5814 : : ! ir1=0;ir2=0
5815 : : ! do ir=1,nrad
5816 : : ! if (rhotot_ep(ir,1)<rho_min) then
5817 : : ! if (ir1==0) ir1=ir-1
5818 : : ! ir2=ir+1
5819 : : ! else if (ir1>0) then
5820 : : ! if (ir1>1.or.ir2<nrad) then
5821 : : ! fact=(vxc_ep(ir2,1)-vxc_ep(ir1,1))/(pawrad%rad(ir2)-pawrad%rad(ir1))
5822 : : ! do jr=ir1+1,ir2-1
5823 : : ! vxc_ep(jr,1)=vxc_ep(ir1,1)+fact*(pawrad%rad(jr)-pawrad%rad(ir1))
5824 : : ! end do
5825 : : ! end if
5826 : : ! ir1=0;ir2=0
5827 : : ! end if
5828 : : ! end do
5829 : : ! end if
5830 : : ! end if
5831 : :
5832 : : ! When vxc is dimensionned as polarized...
5833 [ - + - - : 11752 : if (nspden>=2) vxc(:,:,2)=vxc(:,:,1)
- - ]
5834 [ - + - - : 11752 : if (nspden==4) vxc(:,:,3:4)=zero
- - - - ]
5835 : :
5836 : : end if !option<3
5837 : :
5838 [ - + ]: 11752 : LIBPAW_DEALLOCATE(vxcei)
5839 [ - + ]: 11752 : LIBPAW_DEALLOCATE(vxcpi)
5840 : :
5841 : : !----------------------------------------------------------------------
5842 : : !----- Accumulate and store XC energies
5843 : : !----------------------------------------------------------------------
5844 : :
5845 : : !----- Calculate Exc (direct scheme) term
5846 : : !----------------------------------------
5847 : :
5848 [ + - ]: 11752 : if (option/=1) then
5849 [ - + + - : 23504 : LIBPAW_ALLOCATE(ff,(nrad))
- + - + ]
5850 : :
5851 : : ! Contribution from spherical part of rho
5852 [ + + ]: 15735240 : ff(:)=fxci(:)*four_pi
5853 : :
5854 : : ! Contribution from aspherical part of rho
5855 [ + - ]: 11752 : if (option/=4) then
5856 : :
5857 : : ! First order development
5858 [ + - ]: 11752 : if (pawxcdev>=1) then
5859 : : ff(:)=ff(:)+v1sum(:,2)*d1vxc(:,2) &
5860 [ + + ]: 15735240 : & +half*(v1sum(:,1)*d1vxc(:,1)+v1sum(:,3)*d1vxc(:,3))
5861 : : end if
5862 : :
5863 : : ! Second order development
5864 [ - + ]: 11752 : if (pawxcdev>=2) then
5865 [ # # # # : 0 : LIBPAW_ALLOCATE(gg,(nrad))
# # # # ]
5866 [ # # ]: 0 : gg=zero
5867 [ # # ]: 0 : do ilm=2,lm_size
5868 [ # # # # ]: 0 : if (lmselect(ilm)) gg(:)=gg(:)+v2sum(:,ilm,1)*rhotot(:,ilm)
5869 : : end do
5870 [ # # ]: 0 : ff(:)=ff(:)+gg(:)*d2vxc(:,1)/6._dp
5871 [ # # ]: 0 : gg=zero
5872 [ # # ]: 0 : do ilm=2,lm_size
5873 [ # # # # ]: 0 : if (lmselect(ilm)) gg(:)=gg(:)+v2sum(:,ilm,2)*rhotot(:,ilm)
5874 : : end do
5875 [ # # ]: 0 : ff(:)=ff(:) +half*gg(:)*d2vxc(:,2)
5876 [ # # ]: 0 : gg=zero
5877 [ # # ]: 0 : do ilm=2,lm_size
5878 [ # # # # ]: 0 : if (lmselect(ilm)) gg(:)=gg(:)+v2sum(:,ilm,3)*rhotot(:,ilm)
5879 : : end do
5880 [ # # ]: 0 : ff(:)=ff(:) +half*gg(:)*d2vxc(:,3)
5881 [ # # ]: 0 : gg=zero
5882 [ # # ]: 0 : do ilm=2,lm_size
5883 [ # # # # ]: 0 : if (lmselect_ep(ilm)) gg(:)=gg(:)+v2sum(:,ilm,3)*rhotot_ep(:,ilm)
5884 : : end do
5885 [ # # ]: 0 : ff(:)=ff(:)+gg(:)*d2vxc(:,4)/6._dp
5886 [ # # ]: 0 : LIBPAW_DEALLOCATE(gg)
5887 : : end if ! pawxcdev>=2
5888 : :
5889 : : end if ! option/=4
5890 : :
5891 [ + + ]: 15735240 : ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2
5892 : 11752 : call simp_gen(enxc,ff,pawrad)
5893 [ - + ]: 11752 : LIBPAW_DEALLOCATE(ff)
5894 : : end if ! option/=1
5895 : :
5896 [ - + ]: 11752 : LIBPAW_DEALLOCATE(fxci)
5897 : : if (option<3.or.option/=1) then
5898 [ - + ]: 11752 : LIBPAW_DEALLOCATE(v1sum)
5899 [ - + ]: 11752 : LIBPAW_DEALLOCATE(v2sum)
5900 : : end if
5901 [ - + - - : 11752 : if (option<3.or.(option/=4.and.pawxcdev>1)) then
- - ]
5902 [ - + ]: 11752 : LIBPAW_DEALLOCATE(d2vxc)
5903 : : end if
5904 [ + - ]: 11752 : if (option/=4) then
5905 [ - + ]: 11752 : LIBPAW_DEALLOCATE(d1vxc)
5906 : : end if
5907 : :
5908 : : !----- Calculate Excdc double counting term
5909 : : !------------------------------------------
5910 [ + - ]: 11752 : if (option==0.or.option==2) then
5911 : :
5912 : : ! Build appropriate density
5913 [ - + - - : 11752 : if (usexcnhat==1) rhotot(:,:)=rhotot(:,:)+nhat(:,:,1)
- - ]
5914 [ + + + + : 9479972 : if (usecore==1.and.calctype==2) rhotot(:,1)=rhotot(:,1)-sqfpi*corexc(:)
+ + ]
5915 : :
5916 : : ! Integrate with potential
5917 [ - + + - : 23504 : LIBPAW_ALLOCATE(ff,(nrad))
- + - + -
+ ]
5918 [ + + ]: 15735240 : ff(:)=zero
5919 [ + + ]: 117520 : do ilm=1,lm_size
5920 [ + + + + ]: 100659988 : if (lmselect(ilm)) ff(:)=ff(:)+vxc(:,ilm,1)*rhotot(:,ilm)
5921 : : end do
5922 [ + + ]: 15735240 : ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2
5923 : 11752 : call simp_gen(enxcdc,ff,pawrad)
5924 [ - + ]: 11752 : LIBPAW_DEALLOCATE(ff)
5925 : : end if ! option
5926 : :
5927 [ - + ]: 11752 : LIBPAW_DEALLOCATE(rhotot)
5928 [ - + ]: 11752 : LIBPAW_DEALLOCATE(rhotot_ep)
5929 : :
5930 [ - + - + : 11752 : end subroutine pawxcmpositron
- + ]
5931 : : !!***
5932 : :
5933 : : !----------------------------------------------------------------------
5934 : :
5935 : : !!****f* m_pawxc/pawxc_get_nkxc
5936 : : !! NAME
5937 : : !! pawxc_get_nkxc
5938 : : !!
5939 : : !! FUNCTION
5940 : : !! Get size of XC kernel array (Kxc) according to spin polarization and XC type
5941 : : !!
5942 : : !! INPUTS
5943 : : !! nspden= nmber of density spin components
5944 : : !! xclevel= XC type
5945 : : !!
5946 : : !! OUTPUT
5947 : : !! nkxc= size of XC kernel (kxc array)
5948 : : !!
5949 : : !! NOTES
5950 : : !! Content of Kxc array:
5951 : : !! ===== if LDA
5952 : : !! if nspden==1: kxc(:,1)= d2Exc/drho2
5953 : : !! (kxc(:,2)= d2Exc/drho_up drho_dn)
5954 : : !! if nspden>=2: kxc(:,1)= d2Exc/drho_up drho_up
5955 : : !! kxc(:,2)= d2Exc/drho_up drho_dn
5956 : : !! kxc(:,3)= d2Exc/drho_dn drho_dn
5957 : : !! if nspden==4: kxc(:,4:6)= (m_x, m_y, m_z) (magnetization)
5958 : : !! ===== if GGA
5959 : : !! if nspden==1:
5960 : : !! kxc(:,1)= d2Exc/drho2
5961 : : !! kxc(:,2)= 1/|grad(rho)| dExc/d|grad(rho)|
5962 : : !! kxc(:,3)= 1/|grad(rho)| d2Exc/d|grad(rho)| drho
5963 : : !! kxc(:,4)= 1/|grad(rho)| * d/d|grad(rho)| ( 1/|grad(rho)| dExc/d|grad(rho)| )
5964 : : !! kxc(:,5)= gradx(rho)
5965 : : !! kxc(:,6)= grady(rho)
5966 : : !! kxc(:,7)= gradz(rho)
5967 : : !! if nspden>=2:
5968 : : !! kxc(:,1)= d2Exc/drho_up drho_up
5969 : : !! kxc(:,2)= d2Exc/drho_up drho_dn
5970 : : !! kxc(:,3)= d2Exc/drho_dn drho_dn
5971 : : !! kxc(:,4)= 1/|grad(rho_up)| dEx/d|grad(rho_up)|
5972 : : !! kxc(:,5)= 1/|grad(rho_dn)| dEx/d|grad(rho_dn)|
5973 : : !! kxc(:,6)= 1/|grad(rho_up)| d2Ex/d|grad(rho_up)| drho_up
5974 : : !! kxc(:,7)= 1/|grad(rho_dn)| d2Ex/d|grad(rho_dn)| drho_dn
5975 : : !! kxc(:,8)= 1/|grad(rho_up)| * d/d|grad(rho_up)| ( 1/|grad(rho_up)| dEx/d|grad(rho_up)| )
5976 : : !! kxc(:,9)= 1/|grad(rho_dn)| * d/d|grad(rho_dn)| ( 1/|grad(rho_dn)| dEx/d|grad(rho_dn)| )
5977 : : !! kxc(:,10)=1/|grad(rho)| dEc/d|grad(rho)|
5978 : : !! kxc(:,11)=1/|grad(rho)| d2Ec/d|grad(rho)| drho_up
5979 : : !! kxc(:,12)=1/|grad(rho)| d2Ec/d|grad(rho)| drho_dn
5980 : : !! kxc(:,13)=1/|grad(rho)| * d/d|grad(rho)| ( 1/|grad(rho)| dEc/d|grad(rho)| )
5981 : : !! kxc(:,14)=gradx(rho_up)
5982 : : !! kxc(:,15)=gradx(rho_dn)
5983 : : !! kxc(:,16)=grady(rho_up)
5984 : : !! kxc(:,17)=grady(rho_dn)
5985 : : !! kxc(:,18)=gradz(rho_up)
5986 : : !! kxc(:,19)=gradz(rho_dn)
5987 : : !! if nspden==4:
5988 : : !! kxc(:,20:22)= (m_x, m_y, m_z) (magnetization)
5989 : : !!
5990 : : !! SOURCE
5991 : :
5992 : 24374 : subroutine pawxc_get_nkxc(nkxc,nspden,xclevel)
5993 : :
5994 : : !Arguments ------------------------------------
5995 : : !scalars
5996 : : integer,intent(in) :: nspden,xclevel
5997 : : integer,intent(out) :: nkxc
5998 : : !arrays
5999 : :
6000 : : !Local variables-------------------------------
6001 : : !scalars
6002 : : !arrays
6003 : :
6004 : : !************************************************************************
6005 : :
6006 : 24374 : nkxc=0
6007 : :
6008 [ + + ]: 24374 : if (nspden==1) then ! Non polarized
6009 : :
6010 [ + + ]: 19367 : if (xclevel==1) nkxc=1
6011 [ + + ]: 19367 : if (xclevel==2) nkxc=7
6012 : :
6013 [ + - ]: 5007 : else if (nspden==2) then ! Polarized
6014 : :
6015 [ + + ]: 5007 : if (xclevel==1) nkxc=3
6016 [ + + ]: 5007 : if (xclevel==2) nkxc=19
6017 : :
6018 [ # # ]: 0 : else if (nspden==4) then ! Non-collinear
6019 : :
6020 : : ! Store magnetization in the 3 last terms of Kxc
6021 [ # # ]: 0 : if (xclevel==1) nkxc=6
6022 [ # # ]: 0 : if (xclevel==2) nkxc=22
6023 : :
6024 : : end if
6025 : :
6026 : 24374 : end subroutine pawxc_get_nkxc
6027 : : !!***
6028 : :
6029 : : !----------------------------------------------------------------------
6030 : :
6031 : : !!****f* m_pawxc/pawxc_drivexc_wrapper
6032 : : !! NAME
6033 : : !! pawxc_drivexc_wrapper
6034 : : !!
6035 : : !! FUNCTION
6036 : : !! PAW only
6037 : : !! Wrapper for drivexc routines
6038 : : !!
6039 : : !! NOTES
6040 : : !! PENDING. Need to manage properly optional arguments:
6041 : : !! Check that these are present before calling drivexc
6042 : : !! Probably use better interfaces of fortran 2003 to avoid
6043 : : !! numerous if/then sentences.
6044 : : !!
6045 : : !! SOURCE
6046 : :
6047 : 538733 : subroutine pawxc_drivexc_wrapper(hyb_mixing,ixc,order,npts,nspden,usegradient,uselaplacian,usekden,&
6048 : 538733 : & rho,exc,tsxc,vxcrho,nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc,el_temp, & ! mandatory arguments
6049 : : & grho2,vxcgrho,lrho,vxclrho,tau,vxctau,dvxc,d2vxc, & ! optional arguments
6050 : : & exexch) ! optional arguments
6051 : :
6052 : : !Arguments ------------------------------------
6053 : : !scalars
6054 : : integer,intent(in) :: ixc,ndvxc,nd2vxc,npts,nspden,nvxcgrho,nvxclrho,nvxctau,order
6055 : : integer,intent(in) :: usegradient,uselaplacian,usekden
6056 : : real(dp),intent(in) :: el_temp,hyb_mixing
6057 : : integer,intent(in),optional :: exexch
6058 : : !arrays
6059 : : real(dp),intent(in) :: rho(npts,nspden)
6060 : : real(dp),intent(out) :: exc(npts),tsxc(npts),vxcrho(npts,nspden)
6061 : : real(dp),intent(in),optional :: grho2(npts,(2*nspden-1)*usegradient)
6062 : : real(dp),intent(in),optional :: lrho(npts,nspden*uselaplacian)
6063 : : real(dp),intent(in),optional :: tau(npts,nspden*usekden)
6064 : : real(dp),intent(out),optional:: dvxc(npts,ndvxc),d2vxc(npts,nd2vxc)
6065 : : real(dp),intent(out),optional:: vxcgrho(npts,nvxcgrho),vxclrho(npts,nvxclrho),vxctau(npts,nvxctau)
6066 : :
6067 : : !Local variables-------------------------------
6068 : : character(len=100) :: msg
6069 : :
6070 : : ! *************************************************************************
6071 : :
6072 : :
6073 : : !One could add here a section for other codes (i.e. BigDFT, ...)
6074 : : #if defined HAVE_LIBPAW_ABINIT
6075 : 538733 : call pawxc_drivexc_abinit()
6076 : : #elif defined LIBPAW_HAVE_LIBXC
6077 : : call pawxc_drivexc_libxc()
6078 : : #else
6079 : : write(msg,'(5a)') 'libPAW XC driving routine only implemented in the following cases:',ch10, &
6080 : : & ' - ABINIT',ch10,' - libXC'
6081 : : LIBPAW_BUG(msg)
6082 : : #endif
6083 : :
6084 : : if (.false.) write(std_out,*) el_temp
6085 : : !!***
6086 : :
6087 : : contains
6088 : : !!***
6089 : :
6090 : : #if defined HAVE_LIBPAW_ABINIT
6091 : : !!****f* m_pawxc/pawxc_drivexc_abinit
6092 : : !! NAME
6093 : : !! pawxc_drivexc_abinit
6094 : : !!
6095 : : !! FUNCTION
6096 : : !! ABINIT version of XC driving routine
6097 : : !!
6098 : : !! SOURCE
6099 : :
6100 : 538733 : subroutine pawxc_drivexc_abinit()
6101 : :
6102 : : logical :: test_args
6103 : :
6104 : : ! *************************************************************************
6105 : :
6106 : 538733 : test_args=present(dvxc)
6107 [ + + ]: 538733 : if (nd2vxc>0) test_args=(test_args.and.present(d2vxc))
6108 [ + + + - : 538733 : if (usegradient==1) test_args=(test_args.and.present(grho2).and.present(vxcgrho))
- + ]
6109 [ + + + - : 538733 : if (uselaplacian==1) test_args=(test_args.and.present(lrho).and.present(vxclrho))
- + ]
6110 [ + + + - : 538733 : if (usekden==1) test_args=(test_args.and.present(tau).and.present(vxctau))
- + ]
6111 [ - + ]: 387711 : if (.not.test_args) then
6112 : 0 : msg='missing mandatory arguments in pawxc_drivexc_wrapper'
6113 : 0 : LIBPAW_BUG(msg)
6114 : : end if
6115 : :
6116 [ + + + + ]: 538733 : if (uselaplacian==1.or.usekden==1) then
6117 [ + + + - ]: 151022 : if (uselaplacian==1.and.usekden==1) then
6118 : : call drivexc(ixc,order,npts,nspden,usegradient,uselaplacian,usekden,&
6119 : : & rho,exc,tsxc,vxcrho,nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc,el_temp, &
6120 : : & grho2_updn=grho2,vxcgrho=vxcgrho,&
6121 : : & lrho_updn=lrho,vxclrho=vxclrho,&
6122 : : & tau_updn=tau,vxctau=vxctau,&
6123 : 34946 : & dvxc=dvxc,d2vxc=d2vxc,hyb_mixing=hyb_mixing)
6124 [ - + ]: 116076 : else if (uselaplacian==1) then
6125 : : call drivexc(ixc,order,npts,nspden,usegradient,uselaplacian,usekden,&
6126 : : & rho,exc,tsxc,vxcrho,nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc,el_temp, &
6127 : : & grho2_updn=grho2,vxcgrho=vxcgrho,&
6128 : : & lrho_updn=lrho,vxclrho=vxclrho,&
6129 : 0 : & dvxc=dvxc,d2vxc=d2vxc,hyb_mixing=hyb_mixing)
6130 [ + - ]: 116076 : else if (usekden==1) then
6131 : : call drivexc(ixc,order,npts,nspden,usegradient,uselaplacian,usekden,&
6132 : : & rho,exc,tsxc,vxcrho,nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc,el_temp, &
6133 : : & grho2_updn=grho2,vxcgrho=vxcgrho,&
6134 : : & tau_updn=tau,vxctau=vxctau,&
6135 : 116076 : & dvxc=dvxc,d2vxc=d2vxc,hyb_mixing=hyb_mixing)
6136 : : end if
6137 [ + + ]: 387711 : else if (usegradient==1) then
6138 [ + + ]: 114025 : if (present(exexch)) then
6139 : : call drivexc(ixc,order,npts,nspden,usegradient,uselaplacian,usekden,&
6140 : : & rho,exc,tsxc,vxcrho,nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc,el_temp, &
6141 : : & grho2_updn=grho2,vxcgrho=vxcgrho,&
6142 : : & dvxc=dvxc,d2vxc=d2vxc,&
6143 : 75374 : & exexch=exexch,hyb_mixing=hyb_mixing)
6144 : : else
6145 : : call drivexc(ixc,order,npts,nspden,usegradient,uselaplacian,usekden,&
6146 : : & rho,exc,tsxc,vxcrho,nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc,el_temp, &
6147 : : & grho2_updn=grho2,vxcgrho=vxcgrho,&
6148 : 38651 : & dvxc=dvxc,d2vxc=d2vxc,hyb_mixing=hyb_mixing)
6149 : : end if
6150 : : else
6151 : : call drivexc(ixc,order,npts,nspden,usegradient,uselaplacian,usekden,&
6152 : : & rho,exc,tsxc,vxcrho,nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc,el_temp, &
6153 : 273686 : & dvxc=dvxc,d2vxc=d2vxc,hyb_mixing=hyb_mixing)
6154 : : end if
6155 : :
6156 : 538733 : end subroutine pawxc_drivexc_abinit
6157 : : !!***
6158 : : #endif
6159 : :
6160 : : #if defined LIBPAW_HAVE_LIBXC
6161 : : !!****f* m_pawxc/pawxc_drivexc_libxc
6162 : : !! NAME
6163 : : !! pawxc_drivexc_libxc
6164 : : !!
6165 : : !! FUNCTION
6166 : : !! LibXC version of XC driving routine
6167 : : !!
6168 : : !! SOURCE
6169 : :
6170 : : subroutine pawxc_drivexc_libxc()
6171 : :
6172 : : ! *************************************************************************
6173 : :
6174 : : !Check the compatibility of input arguments
6175 : : if (ixc>=0) then
6176 : : msg='ixc argument should be negative!'
6177 : : LIBPAW_BUG(msg)
6178 : : end if
6179 : : if (ixc/=libxc_functionals_ixc()) then
6180 : : msg='The value of ixc differs from the one used to initialize the functional!'
6181 : : LIBPAW_BUG(msg)
6182 : : end if
6183 : : if ((order<1.and.order/=-2).or.order>4) then
6184 : : msg='The only allowed values for order are 1, 2, -2, or 3!'
6185 : : LIBPAW_BUG(msg)
6186 : : end if
6187 : : if ((order**2>1).and.(.not.present(dvxc))) then
6188 : : msg='The value of order is not compatible with the presence of the array dvxc!'
6189 : : LIBPAW_BUG(msg)
6190 : : end if
6191 : : if ((order==3).and.(.not.present(d2vxc))) then
6192 : : msg='The value of order is not compatible with the presence of the array d2vxc!'
6193 : : LIBPAW_BUG(msg)
6194 : : end if
6195 : : if (libxc_functionals_isgga().or.libxc_functionals_ismgga()) then
6196 : : if ((.not.present(grho2)).or.(.not.present(vxcgrho)).or.&
6197 : : & (usegradient==0).or.(nvxcgrho==0)) then
6198 : : write(msg,'(3a)') 'At least one of the functionals is a GGA,',ch10, &
6199 : : & 'but not all the necessary optional arguments are present.'
6200 : : LIBPAW_BUG(msg)
6201 : : end if
6202 : : if (libxc_functionals_needs_laplacian()) then
6203 : : if ((.not.present(lrho)).or.(.not.present(vxclrho)).or.&
6204 : : & (uselaplacian==0).or.(nvxclrho==0)) then
6205 : : write(msg,'(3a)') 'At least one of the functionals is a mGGA,',ch10, &
6206 : : & 'but not all the necessary optional arguments are present.'
6207 : : LIBPAW_BUG(msg)
6208 : : end if
6209 : : end if
6210 : : if (libxc_functionals_ismgga()) then
6211 : : if ((.not.present(tau)).or.(.not.present(vxctau)).or.&
6212 : : & (usekden==0).or.(nvxctau==0)) then
6213 : : write(msg,'(3a)') 'At least one of the functionals is a mGGA,',ch10, &
6214 : : & 'but not all the necessary optional arguments are present.'
6215 : : LIBPAW_BUG(msg)
6216 : : end if
6217 : : end if
6218 : : end if
6219 : : if ((uselaplacian==1.or.usekden==1).and.(usegradient==0)) then
6220 : : msg='Laplacian or kinetic energy density needs gradient!'
6221 : : LIBPAW_BUG(msg)
6222 : : end if
6223 : :
6224 : : !Call LibXC routines
6225 : : if (uselaplacian==1.or.usekden==1) then ! meta-GGA
6226 : : if (uselaplacian==1.and.usekden==1) then
6227 : : call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho,&
6228 : : & grho2=grho2,vxcgr=vxcgrho,lrho=lrho,vxclrho=vxclrho,tau=tau,vxctau=vxctau)
6229 : : else if (uselaplacian==1) then
6230 : : call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho,&
6231 : : & grho2=grho2,vxcgr=vxcgrho,lrho=lrho,vxclrho=vxclrho)
6232 : : else if (usekden==1) then
6233 : : call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho,&
6234 : : & grho2=grho2,vxcgr=vxcgrho,tau=tau,vxctau=vxctau)
6235 : : end if
6236 : : else if (usegradient==1) then ! GGA
6237 : : if (abs(order)<=1) then
6238 : : call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho,&
6239 : : & grho2=grho2,vxcgr=vxcgrho)
6240 : : else
6241 : : call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho,&
6242 : : & grho2=grho2,vxcgr=vxcgrho,dvxc=dvxc)
6243 : : end if
6244 : : else ! LDA
6245 : : if (abs(order)<=1) then
6246 : : call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho)
6247 : : else if (abs(order)<=2) then
6248 : : call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho,&
6249 : : & dvxc=dvxc)
6250 : : else
6251 : : call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho,&
6252 : : & d2vxc=d2vxc)
6253 : : end if
6254 : : end if
6255 : :
6256 : : end subroutine pawxc_drivexc_libxc
6257 : : !!***
6258 : : #endif
6259 : :
6260 : : end subroutine pawxc_drivexc_wrapper
6261 : : !!***
6262 : :
6263 : : !----------------------------------------------------------------------
6264 : :
6265 : : !!****f* m_pawxc/pawxc_rotate_mag
6266 : : !! NAME
6267 : : !! pawxc_rotate_mag
6268 : : !!
6269 : : !! FUNCTION
6270 : : !! Project (rotate) a non-collinear density (stored as density+magn.)
6271 : : !! on a magnetization and give a collinear density (stored as [up,dn] or [up+dn,up]).
6272 : : !!
6273 : : !! INPUTS
6274 : : !! rho_in(vectsize,4)=input non-collinear density and magnetization
6275 : : !! mag(vectsize,3)=magnetization used for projection
6276 : : !! vectsize=size of vector fields
6277 : : !! [rho_out_format]= 1=rho_out is stored as [up,dn]
6278 : : !! 2=rho_out is stored as [up+dn,up]
6279 : : !! Default=1
6280 : : !!
6281 : : !! OUTPUT
6282 : : !! rho_out(vectsize,2)=output (projected, collinear) density
6283 : : !! [mag_norm_out(vectsize)]= --optional-- norm of mag(:) at each point of the grid
6284 : : !! SOURCE
6285 : :
6286 : 33686 : subroutine pawxc_rotate_mag(rho_in,rho_out,mag,vectsize,mag_norm_out,rho_out_format)
6287 : :
6288 : : !Arguments ------------------------------------
6289 : : !scalars
6290 : : integer,intent(in) :: vectsize
6291 : : integer,intent(in),optional :: rho_out_format
6292 : : !arrays
6293 : : real(dp),intent(in) :: rho_in(vectsize,4),mag(vectsize,3)
6294 : : real(dp),intent(out) :: rho_out(vectsize,2)
6295 : : real(dp),intent(out),optional :: mag_norm_out(vectsize)
6296 : :
6297 : : !Local variables-------------------------------
6298 : : !scalars
6299 : : #if ! defined HAVE_LIBPAW_ABINIT
6300 : : integer :: ipt
6301 : : real(dp),parameter :: m_norm_min=tol8
6302 : : real(dp) :: m_norm,rhoin_dot_mag,rho_up
6303 : : #endif
6304 : : !arrays
6305 : :
6306 : : ! *************************************************************************
6307 : :
6308 : : !One could add here a section for other codes (i.e. BigDFT, ...)
6309 : : #if defined HAVE_LIBPAW_ABINIT
6310 [ - + ]: 33686 : if (present(rho_out_format).and.present(mag_norm_out)) then
6311 : : call rotate_mag(rho_in,rho_out,mag,vectsize,1, &
6312 : 0 : & rho_out_format=rho_out_format,mag_norm_out=mag_norm_out)
6313 [ - + ]: 33686 : else if (present(rho_out_format).and..not.present(mag_norm_out)) then
6314 : 0 : call rotate_mag(rho_in,rho_out,mag,vectsize,1,rho_out_format=rho_out_format)
6315 [ + + ]: 33686 : else if (.not.present(rho_out_format).and.present(mag_norm_out)) then
6316 : 2798 : call rotate_mag(rho_in,rho_out,mag,vectsize,1,mag_norm_out=mag_norm_out)
6317 : : else
6318 : 30888 : call rotate_mag(rho_in,rho_out,mag,vectsize,1)
6319 : : end if
6320 : : #else
6321 : : do ipt=1,vectsize
6322 : : m_norm=sqrt(mag(ipt,1)**2+mag(ipt,2)**2+mag(ipt,3)**2)
6323 : : rhoin_dot_mag=rho_in(ipt,2)*mag(ipt,1)+rho_in(ipt,3)*mag(ipt,2) &
6324 : : & +rho_in(ipt,4)*mag(ipt,3)
6325 : : if(m_norm>m_norm_min)then
6326 : : rho_out(ipt,1)=half*(rho_in(ipt,1)+rhoin_dot_mag/m_norm)
6327 : : rho_out(ipt,2)=half*(rho_in(ipt,1)-rhoin_dot_mag/m_norm)
6328 : : else
6329 : : rho_out(ipt,1)=half*rho_in(ipt,1)
6330 : : rho_out(ipt,2)=half*rho_in(ipt,1)
6331 : : end if
6332 : : if (present(mag_norm_out).and.m_norm> m_norm_min) mag_norm_out(ipt)=m_norm
6333 : : if (present(mag_norm_out).and.m_norm<=m_norm_min) mag_norm_out(ipt)=zero
6334 : : end do
6335 : : if (present(rho_out_format)) then
6336 : : if (rho_out_format==2) then
6337 : : do ipt=1,vectsize
6338 : : rho_up=rho_out(ipt,1)
6339 : : rho_out(ipt,1)=rho_up+rho_out(ipt,2)
6340 : : rho_out(ipt,2)=rho_up
6341 : : end do
6342 : : end if
6343 : : end if
6344 : : #endif
6345 : :
6346 : 33686 : end subroutine pawxc_rotate_mag
6347 : : !!***
6348 : :
6349 : : !----------------------------------------------------------------------
6350 : :
6351 : : !!****f* m_pawxc/pawxc_rotate_back_mag
6352 : : !! NAME
6353 : : !! pawxc_rotate_back_mag
6354 : : !!
6355 : : !! FUNCTION
6356 : : !! Rotate back a collinear XC potential (stored as up+dn) with respect to
6357 : : !! a magnetization and give a non-collinear XC potential
6358 : : !! (stored as up_up, dn_dn, Re{up_dn}, Im{up_dn}).
6359 : : !!
6360 : : !! INPUTS
6361 : : !! vxc_in(vectsize,2)=input collinear XC potential
6362 : : !! mag(vectsize,3)=magnetization used for projection
6363 : : !! vectsize=size of vector fields
6364 : : !!
6365 : : !! OUTPUT
6366 : : !! vxc_out(vectsize,4)=output non-collinear XC potential
6367 : : !!
6368 : : !! SOURCE
6369 : :
6370 : 71540 : subroutine pawxc_rotate_back_mag(vxc_in,vxc_out,mag,vectsize)
6371 : :
6372 : : !Arguments ------------------------------------
6373 : : !scalars
6374 : : integer,intent(in) :: vectsize
6375 : : !arrays
6376 : : real(dp),intent(in) :: vxc_in(vectsize,2),mag(vectsize,3)
6377 : : real(dp),intent(out) :: vxc_out(vectsize,4)
6378 : :
6379 : : !Local variables-------------------------------
6380 : : !scalars
6381 : : #if ! defined HAVE_LIBPAW_ABINIT
6382 : : integer :: ipt
6383 : : real(dp),parameter :: m_norm_min=tol8
6384 : : real(dp) :: dvdn,dvdz,m_norm
6385 : : #endif
6386 : : !arrays
6387 : :
6388 : : ! *************************************************************************
6389 : :
6390 : : !One could add here a section for other codes (i.e. BigDFT, ...)
6391 : : #if defined HAVE_LIBPAW_ABINIT
6392 : 71540 : call rotate_back_mag(vxc_in,vxc_out,mag,vectsize)
6393 : : #else
6394 : : do ipt=1,vectsize
6395 : : m_norm=sqrt(mag(ipt,1)**2+mag(ipt,2)**2+mag(ipt,3)**2)
6396 : : dvdn=half*(vxc_in(ipt,1)+vxc_in(ipt,2))
6397 : : if (m_norm>m_norm_min) then
6398 : : dvdz=half*(vxc_in(ipt,1)-vxc_in(ipt,2))/m_norm
6399 : : vxc_out(ipt,1)=dvdn+mag(ipt,3)*dvdz
6400 : : vxc_out(ipt,2)=dvdn-mag(ipt,3)*dvdz
6401 : : vxc_out(ipt,3)= mag(ipt,1)*dvdz
6402 : : vxc_out(ipt,4)=-mag(ipt,2)*dvdz
6403 : : else
6404 : : vxc_out(ipt,1:2)=dvdn
6405 : : vxc_out(ipt,3:4)=zero
6406 : : end if
6407 : : end do
6408 : : #endif
6409 : :
6410 : : end subroutine pawxc_rotate_back_mag
6411 : : !!***
6412 : :
6413 : : !----------------------------------------------------------------------
6414 : :
6415 : : !!****f* m_pawxc/pawxc_rotate_back_mag_dfpt
6416 : : !! NAME
6417 : : !! pawxc_rotate_back_mag_dfpt
6418 : : !!
6419 : : !! FUNCTION
6420 : : !! Rotate back a 1st-order collinear XC potential (stored as up+dn) with respect to
6421 : : !! a magnetization and give a 1st-order non-collinear XC potential
6422 : : !! (stored as up_up, dn_dn, Re{up_dn}, Im{up_dn}).
6423 : : !!
6424 : : !! INPUTS
6425 : : !! mag(vectsize,3)=0-order magnetization used for projection
6426 : : !! rho1(vectsize,4)=1st-order non-collinear density and magnetization
6427 : : !! vxc(vectsize,4)=0-order non-collinear XC potential
6428 : : !! kxc(vectsize,nkxc)=0-order XC kernel (associated to vxc)
6429 : : !! vxc1_in(vectsize,2)=input 1st-order collinear XC potential
6430 : : !! vectsize=size of vector fields
6431 : : !!
6432 : : !! OUTPUT
6433 : : !! vxc1_out(vectsize,4)=output 1st-order non-collinear XC potential
6434 : : !!
6435 : : !! SOURCE
6436 : :
6437 [ # # ]: 0 : subroutine pawxc_rotate_back_mag_dfpt(vxc1_in,vxc1_out,vxc,kxc,rho1,mag,vectsize)
6438 : :
6439 : : !Arguments ------------------------------------
6440 : : !scalars
6441 : : integer,intent(in) :: vectsize
6442 : : !arrays
6443 : : real(dp),intent(in) :: kxc(:,:),mag(vectsize,3),rho1(vectsize,4)
6444 : : real(dp),intent(in) :: vxc(vectsize,4),vxc1_in(vectsize,2)
6445 : : real(dp),intent(out) :: vxc1_out(vectsize,4)
6446 : :
6447 : : !Local variables-------------------------------
6448 : : !scalars
6449 : : #if ! defined HAVE_LIBPAW_ABINIT
6450 : : character(len=100) :: msg
6451 : : #endif
6452 : : !arrays
6453 : :
6454 : : ! *************************************************************************
6455 : :
6456 : : !One could add here a section for other codes (i.e. BigDFT, ...)
6457 : : #if defined HAVE_LIBPAW_ABINIT
6458 : 0 : call rotate_back_mag_dfpt(1,vxc1_in,vxc1_out,vxc,kxc,rho1,mag,vectsize,1)
6459 : : #else
6460 : : msg='[LIBPAW] Non-collinear DFPT not available (only in ABINIT)!'
6461 : : LIBPAW_ERROR(msg)
6462 : : #endif
6463 : :
6464 : 0 : end subroutine pawxc_rotate_back_mag_dfpt
6465 : : !!***
6466 : :
6467 : : !----------------------------------------------------------------------
6468 : :
6469 : : end module m_pawxc
6470 : : !!***
|
