Branch data Line data Source code
1 : : !!****m* ABINIT/m_pawdij
2 : : !! NAME
3 : : !! m_pawdij
4 : : !!
5 : : !! FUNCTION
6 : : !! This module contains several routines used to compute the PAW pseudopotential
7 : : !! strengths Dij. The Dijs define the non-local PAW operator:
8 : : !! VNL = Sum_ij [ Dij |pi><pj| ], with pi, pj= projectors
9 : : !!
10 : : !! COPYRIGHT
11 : : !! Copyright (C) 2013-2026 ABINIT group (MT, FJ, BA, JWZ)
12 : : !! This file is distributed under the terms of the
13 : : !! GNU General Public License, see ~abinit/COPYING
14 : : !! or http://www.gnu.org/copyleft/gpl.txt .
15 : : !! For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
16 : : !!
17 : : !! NOTES
18 : : !! FOR DEVELOPERS: in order to preserve the portability of libPAW library,
19 : : !! please consult ~abinit/src/??_libpaw/libpaw-coding-rules.txt
20 : : !!
21 : : !! SOURCE
22 : :
23 : : #include "libpaw.h"
24 : :
25 : : #define MATPACK(row,col) (MAX(row,col)*(MAX(row,col)-1)/2 + MIN(row,col))
26 : : #define LMPACK(lqn,mqn) (lqn*lqn+lqn+mqn+1)
27 : :
28 : : MODULE m_pawdij
29 : :
30 : : USE_DEFS
31 : : USE_MSG_HANDLING
32 : : USE_MPI_WRAPPERS
33 : : USE_MEMORY_PROFILING
34 : :
35 : : use m_paral_atom, only : get_my_atmtab, free_my_atmtab
36 : : use m_paw_io, only : pawio_print_ij
37 : : use m_pawang, only : pawang_type
38 : : use m_pawrad, only : pawrad_type, pawrad_deducer0, simp_gen, nderiv_gen
39 : : use m_pawtab, only : pawtab_type
40 : : use m_paw_an, only : paw_an_type
41 : : use m_paw_ij, only : paw_ij_type, paw_ij_print
42 : : use m_pawfgrtab, only : pawfgrtab_type
43 : : use m_pawrhoij, only : pawrhoij_type
44 : : use m_paw_finegrid, only : pawgylm, pawexpiqr
45 : : use m_paw_sphharm, only : initylmr,slxyzs,make_dyadic,realgaunt
46 : : use m_numeric_tools,only : geteuler
47 : :
48 : : implicit none
49 : :
50 : : private :: pawdijaa
51 : :
52 : :
53 : : !public procedures.
54 : : public :: pawdij ! Dij total
55 : : public :: pawdijhartree ! Dij Hartree
56 : : public :: pawdijfock ! Dij Fock exact-exchange
57 : : public :: pawdijxc ! Dij eXchange-Correlation (using (r,theta,phi) grid)
58 : : public :: pawdijxcm ! Dij eXchange-Correlation (using (l,m) moments)
59 : : public :: pawdijhat ! Dij^hat (compensation charge contribution)
60 : : public :: pawdijnd ! Dij nuclear dipole
61 : : public :: pawdijso ! Dij spin-orbit
62 : : public :: pawdiju ! Dij DFT+U
63 : : public :: pawdiju_euijkl ! Dij DFT+U, using pawrhoij instead of occupancies
64 : : public :: pawdijexxc ! Dij local exact-exchange
65 : : public :: pawdijfr ! 1st-order frozen Dij
66 : : public :: pawpupot ! On-site DFT+U potential
67 : : public :: pawxpot ! On-site local exact-exchange potential
68 : : public :: symdij ! Symmetrize total Dij or one part of it
69 : : public :: symdij_all ! Symmetrize all contributions to Dij
70 : : public :: pawdij_gather ! Perform a allgather operation on Dij
71 : : public :: pawdij_print_dij ! Print out a Dij matrix
72 : : public :: pawv1 ! On-site V1 potential
73 : : !!***
74 : :
75 : : CONTAINS
76 : :
77 : : !===========================================================
78 : : !!***
79 : :
80 : : !----------------------------------------------------------------------
81 : :
82 : : !!****f* m_pawdij/pawdij
83 : : !! NAME
84 : : !! pawdij
85 : : !!
86 : : !! FUNCTION
87 : : !! Compute the pseudopotential strengths Dij of the PAW non local operator as sum of
88 : : !! several contributions. Can compute first-order strengths Dij for RF calculations.
89 : : !! This routine is a driver calling, for each contribution to Dij, a specific
90 : : !! routines.
91 : : !! Within standard PAW formalism, Dij can be decomposd as follows:
92 : : !! Dij = Dij_atomic + Dij_Hartree + Dij_XC + Dij^hat
93 : : !! In case of additional approximations, several other terms can appear:
94 : : !! Dij_DFT+U, Dij_spin-orbit, Dij_local-exact-exchange, Dij_Fock...
95 : : !!
96 : : !! INPUTS
97 : : !! cplex=1 if no phase is applied (GS), 2 if a exp(-iqr) phase is applied (Response Function at q<>0)
98 : : !! enunit=choice for units of output Dij
99 : : !! gprimd(3,3)=dimensional primitive translations for reciprocal space
100 : : !! [hyb_mixing, hyb_mixing_sr]= -- optional-- mixing factors for the global (resp. screened) XC hybrid functional
101 : : !! ipert=index of perturbation (used only for RF calculation ; set ipert<=0 for GS calculations.
102 : : !! my_natom=number of atoms treated by current processor
103 : : !! natom=total number of atoms in cell
104 : : !! nfft=number of real space grid points (for current proc)
105 : : !! nfftot=total number of real space grid points
106 : : !! nspden=number of spin-density components
107 : : !! ntypat=number of types of atoms in unit cell.
108 : : !! paw_an(my_natom) <type(paw_an_type)>=paw arrays given on angular mesh
109 : : !! paw_ij(my_natom) <type(paw_ij_type)>=paw arrays given on (i,j) channels
110 : : !! pawang <type(pawang_type)>=paw angular mesh and related data
111 : : !! pawfgrtab(my_natom) <type(pawfgrtab_type)>=atomic data given on fine rectangular grid
112 : : !! pawprtvol=control print volume and debugging output for PAW
113 : : !! pawrad(ntypat) <type(pawrad_type)>=paw radial mesh and related data
114 : : !! pawrhoij(my_natom) <type(pawrhoij_type)>= paw rhoij occupancies and related data
115 : : !! pawspnorb=flag: 1 if spin-orbit coupling is activated
116 : : !! pawtab(ntypat) <type(pawtab_type)>=paw tabulated starting data
117 : : !! pawxcdev=Choice of XC development (0=no dev. (use of angular mesh) ; 1 or 2=dev. on moments)
118 : : !! qphon(3)=wavevector of the phonon
119 : : !! spnorbscl=scaling factor for spin-orbit coupling
120 : : !! ucvol=unit cell volume
121 : : !! vtrial(cplex*nfft,nspden)=GS potential on real space grid
122 : : !! vxc(cplex*nfft,nspden)=XC potential (Hartree) on real space grid
123 : : !! xred(3,my_natom)= reduced atomic coordinates
124 : : !! znuc(ntypat)=nuclear charges
125 : : !! ======== Optional arguments ==============
126 : : !! Parallelism over atomic sites:
127 : : !! mpi_atmtab(:)=indexes of the atoms treated by current proc
128 : : !! comm_atom=MPI communicator over atoms
129 : : !! mpi_comm_grid=MPI communicator over real space grid points
130 : : !! Application of a potential energy shift on atomic sites:
131 : : !! natvshift=number of atomic potential energy shifts (per atom) ; default=0
132 : : !! atvshift(natvshift,nsppol,natom)=potential energy shift for lm channel & spin & atom
133 : : !! fatvshift=factor that multiplies atvshift
134 : : !! Electrons-positron 2-component DFT:
135 : : !! electronpositron_calctype=type of calculation for electron-positron 2component-DFT:
136 : : !! 0: standard DFT (no positron) ; default value
137 : : !! 1: positron in the constant electrons potential
138 : : !! 2: electrons in the constant positron potential
139 : : !! electronpositron_pawrhoij(my_natom) <type(pawrhoij_type)>=
140 : : !! PAW occupation matrix of the "constant" particle(s)
141 : : !! (electrons if calctype=1, positron if calctype=2)
142 : : !! electronpositron_lmselect(lmmax,my_natom)=
143 : : !! Flags selecting the non-zero LM-moments of on-site densities
144 : : !! for the "constant" particle(s)
145 : : !! (electrons if calctype=1, positron if calctype=2)
146 : : !!
147 : : !! OUTPUT
148 : : !! paw_ij(iatom)%dij(cplex_dij*qphase*lmn2_size,ndij)= total Dij terms (GS calculation, ipert=0)
149 : : !! total 1st-order Dij terms (RF ccalc., ipert>0)
150 : : !! May be complex if cplex_dij=2
151 : : !! dij(:,1) contains Dij^up-up
152 : : !! dij(:,2) contains Dij^dn-dn
153 : : !! dij(:,3) contains Dij^up-dn (only if nspinor=2)
154 : : !! dij(:,4) contains Dij^dn-up (only if nspinor=2)
155 : : !! May also compute paw_ij(iatom)%dij0,paw_ij(iatom)%dijhartree,paw_ij(iatom)%dijxc,
156 : : !! paw_ij(iatom)%dijxc_hat,paw_ij(iatom)%dijxc_val,
157 : : !! paw_ij(iatom)%dijhat,paw_ij(iatom)dijso,
158 : : !! paw_ij(iatom)%dijU,paw_ij(iatom)%dijexxc,paw_ij(iatom)%dijfock
159 : : !!
160 : : !! NOTES
161 : : !! Response function calculations:
162 : : !! In order to compute first-order Dij, paw_an (resp. paw_ij) datastructures
163 : : !! must contain first-order quantities, namely paw_an1 (resp. paw_ij1).
164 : : !!
165 : : !! SOURCE
166 : :
167 : 20720 : subroutine pawdij(cplex,enunit,gprimd,ipert,my_natom,natom,nfft,nfftot,nspden,ntypat,&
168 : 62160 : & paw_an,paw_ij,pawang,pawfgrtab,pawprtvol,pawrad,pawrhoij,pawspnorb,pawtab,&
169 [ - + ]: 20720 : & pawxcdev,qphon,spnorbscl,ucvol,charge,vtrial,vxc,xred,znuc,&
170 [ + + + + : 20720 : & electronpositron_calctype,electronpositron_pawrhoij,electronpositron_lmselect,&
- + + + +
+ - + ]
171 [ + + + - : 20720 : & atvshift,fatvshift,natvshift,nucdipmom,eijkl_is_sym,&
- + ]
172 [ + + + + : 20720 : & mpi_atmtab,comm_atom,mpi_comm_grid,hyb_mixing,hyb_mixing_sr,spinaxis)
- + ]
173 : :
174 : : !Arguments ---------------------------------------------
175 : : !scalars
176 : : integer,intent(in) :: cplex,enunit,ipert,my_natom,natom,nfft,nfftot
177 : : integer,intent(in) :: nspden,ntypat,pawprtvol,pawspnorb,pawxcdev
178 : : integer,optional,intent(in) :: electronpositron_calctype
179 : : integer,optional,intent(in) :: comm_atom,mpi_comm_grid,natvshift
180 : : real(dp),intent(in) :: spnorbscl,ucvol,charge
181 : : real(dp),intent(in),optional ::fatvshift,hyb_mixing,hyb_mixing_sr
182 : : type(pawang_type),intent(in) :: pawang
183 : : !arrays
184 : : integer,optional,target,intent(in) :: mpi_atmtab(:)
185 : : logical,optional,intent(in) :: electronpositron_lmselect(:,:)
186 : : logical,optional,intent(in) :: eijkl_is_sym(ntypat)
187 : : real(dp),intent(in) :: gprimd(3,3),qphon(3)
188 : : real(dp),intent(in) :: vxc(:,:),xred(3,natom),znuc(ntypat)
189 : : real(dp),intent(in),target :: vtrial(cplex*nfft,nspden)
190 : : real(dp),intent(in),optional :: atvshift(:,:,:)
191 : : real(dp),intent(in),optional :: nucdipmom(3,natom)
192 : : real(dp),intent(in),optional :: spinaxis(3)
193 : : type(paw_an_type),intent(in) :: paw_an(my_natom)
194 : : type(paw_ij_type),target,intent(inout) :: paw_ij(my_natom)
195 : : type(pawfgrtab_type),intent(inout) :: pawfgrtab(my_natom)
196 : : type(pawrad_type),intent(in) :: pawrad(ntypat)
197 : : type(pawrhoij_type),intent(inout) :: pawrhoij(my_natom)
198 : : type(pawrhoij_type),intent(in),optional :: electronpositron_pawrhoij(:)
199 : : type(pawtab_type),intent(in) :: pawtab(ntypat)
200 : :
201 : : !Local variables ---------------------------------------
202 : : !scalars
203 : : !Possible algos for PAW+U: 1=using occupation matrix n_i,,2=using PAW matrix rho_ij
204 : : integer, parameter :: PAWU_ALGO_1=1,PAWU_ALGO_2=2
205 : : integer, parameter :: PAWU_FLL=1,PAWU_AMF=2
206 : : integer :: cplex_dij,iatom,iatom_tot,idij,ipositron,itypat,klmn,klmn1,lm_size,lmn2_size
207 : : integer :: lpawu,my_comm_atom,my_comm_grid,natvshift_,ndij,nsploop,nsppol
208 : : integer :: pawu_algo,pawu_dblec,qphase,usekden,usepawu,usexcnhat
209 : : logical :: dij_available,dij_need,dij_prereq
210 : : logical :: dij0_available,dij0_need,dij0_prereq
211 : : logical :: dijexxc_available,dijexxc_need,dijexxc_prereq
212 : : logical :: dijfock_available,dijfock_need,dijfock_prereq
213 : : logical :: dijhartree_available,dijhartree_need,dijhartree_prereq
214 : : logical :: dijhat_available,dijhat_need,dijhat_prereq
215 : : logical :: dijhatfr_available,dijhatfr_need,dijhatfr_prereq
216 : : logical :: dijnd_available,dijnd_need,dijnd_prereq
217 : : logical :: dijso_available,dijso_need,dijso_prereq
218 : : logical :: dijxc_available,dijxc_need,dijxc_prereq
219 : : logical :: dijxchat_available,dijxchat_need,dijxchat_prereq
220 : : logical :: dijxcval_available,dijxcval_need,dijxcval_prereq
221 : : logical :: dijU_available,dijU_need,dijU_prereq
222 : : logical :: has_nucdipmom,my_atmtab_allocated,is_sym
223 : : logical :: need_to_print,paral_atom,v_dijhat_allocated
224 : : real(dp) :: hyb_mixing_,hyb_mixing_sr_
225 : : character(len=500) :: msg
226 : : !arrays
227 : 20720 : integer,pointer :: my_atmtab(:)
228 : 20720 : logical,allocatable :: lmselect(:)
229 : : real(dp) :: spinaxis_in(3)
230 : 20720 : real(dp),allocatable :: dij0(:),dijhartree(:)
231 : 20720 : real(dp),allocatable :: dijhat(:,:),dijexxc(:,:),dijfock_cv(:,:),dijfock_vv(:,:),dijpawu(:,:)
232 : 20720 : real(dp),allocatable :: dijnd(:,:),dijso(:,:)
233 : 20720 : real(dp),allocatable :: dijxc(:,:),dij_ep(:),dijxchat(:,:),dijxcval(:,:)
234 : 20720 : real(dp),pointer :: v_dijhat(:,:),vpawu(:,:,:,:),vpawx(:,:,:)
235 : :
236 : : ! *************************************************************************
237 : :
238 : : !------------------------------------------------------------------------
239 : : !----- Check consistency of arguments
240 : : !------------------------------------------------------------------------
241 : :
242 : : ! === Check optional arguments ===
243 : :
244 : 15229 : hyb_mixing_ =zero ; if(present(hyb_mixing)) hyb_mixing_ =hyb_mixing
245 [ + + ]: 20720 : hyb_mixing_sr_=zero ; if(present(hyb_mixing_sr)) hyb_mixing_sr_=hyb_mixing_sr
246 : :
247 [ + + ]: 20720 : natvshift_=0;if (present(natvshift)) natvshift_=natvshift
248 [ + + ]: 20720 : if (natvshift_>0) then
249 [ - + ]: 196 : if ((.not.present(atvshift)).or.(.not.present(fatvshift))) then
250 : 0 : msg='when natvshift>0, atvshift and fatvshift arguments must be present!'
251 : 0 : LIBPAW_BUG(msg)
252 : : end if
253 : : end if
254 : :
255 [ + + ]: 20720 : ipositron=0;if (present(electronpositron_calctype)) ipositron=electronpositron_calctype
256 [ + + ]: 15229 : if (ipositron/=0) then
257 [ - + ]: 488 : if ((.not.present(electronpositron_pawrhoij)).or.&
258 : : & (.not.present(electronpositron_lmselect))) then
259 : 0 : msg='ep_pawrhoij and ep_lmselect must be present for electron-positron calculations!'
260 : 0 : LIBPAW_BUG(msg)
261 : : end if
262 : : end if
263 : :
264 : 20720 : has_nucdipmom=present(nucdipmom)
265 : :
266 : : ! === Check complex character of arguments ===
267 : :
268 [ + + - + ]: 20720 : if (nspden==4.and.cplex==2) then
269 : 0 : msg='nspden=4 probably not compatible with cplex=2!'
270 : 0 : LIBPAW_BUG(msg)
271 : : end if
272 [ + + ]: 20720 : if (my_natom>0) then
273 [ + + - + ]: 18956 : if (paw_ij(1)%ndij==4.and.paw_ij(1)%cplex_dij/=2) then
274 : 0 : msg='invalid cplex size for Dij (4 Dij components)!'
275 : 0 : LIBPAW_BUG(msg)
276 : : end if
277 [ - + ]: 18956 : if (paw_ij(1)%qphase/=paw_an(1)%cplex) then
278 : 0 : msg='paw_ij()%qphase and paw_an()%cplex must be equal!'
279 : 0 : LIBPAW_BUG(msg)
280 : : end if
281 [ + + - + ]: 18956 : if (ipert<=0.and.paw_ij(1)%qphase/=1) then
282 : 0 : msg='qphase must be 1 for GS calculations!'
283 : 0 : LIBPAW_BUG(msg)
284 : : end if
285 [ + + - + ]: 18956 : if (ipert>0.and.paw_ij(1)%qphase/=cplex) then
286 : 0 : msg='paw_ij()%qphase must be equal to cplex!'
287 : 0 : LIBPAW_BUG(msg)
288 : : end if
289 [ + + - + ]: 18956 : if (paw_an(1)%has_vxcval>0.and.paw_an(1)%has_vxctau==2) then
290 : 0 : msg='kinetic energy density not available for vxc_val!'
291 : 0 : LIBPAW_BUG(msg)
292 : : end if
293 : : end if
294 : :
295 : : !------------------------------------------------------------------------
296 : : !----- Initializations
297 : : !------------------------------------------------------------------------
298 : :
299 : : !Nothing to do for some perturbations (RF case)
300 [ + + + + ]: 20720 : if (ipert==natom+1.or.ipert==natom+10) then
301 [ + + ]: 2517 : do iatom=1,my_natom
302 [ + - + + : 257917 : if (paw_ij(iatom)%has_dij==1) paw_ij(iatom)%dij=zero
+ + ]
303 [ - + - - ]: 1626 : if (paw_ij(iatom)%has_dij0==1) paw_ij(iatom)%dij0=zero
304 [ - + - - : 1626 : if (paw_ij(iatom)%has_dijfock==1) paw_ij(iatom)%dijfock=zero
- - ]
305 [ + - + + ]: 88709 : if (paw_ij(iatom)%has_dijhartree==1) paw_ij(iatom)%dijhartree=zero
306 [ - + - - : 1626 : if (paw_ij(iatom)%has_dijxc==1) paw_ij(iatom)%dijxc=zero
- - ]
307 [ - + - - : 1626 : if (paw_ij(iatom)%has_dijhat==1) paw_ij(iatom)%dijhat=zero
- - ]
308 [ - + - - : 1626 : if (paw_ij(iatom)%has_dijso==1) paw_ij(iatom)%dijso=zero
- - ]
309 [ - + - - : 1626 : if (paw_ij(iatom)%has_dijU==1) paw_ij(iatom)%dijU=zero
- - ]
310 [ - + - - : 1626 : if (paw_ij(iatom)%has_dijexxc==1) paw_ij(iatom)%dijexxc=zero
- - ]
311 [ - + - - : 1626 : if (paw_ij(iatom)%has_dijxc_hat==1) paw_ij(iatom)%dijxc_hat=zero
- - ]
312 [ - + - - : 2517 : if (paw_ij(iatom)%has_dijxc_val==1) paw_ij(iatom)%dijxc_val=zero
- - ]
313 : : end do
314 : : return
315 : : end if
316 : :
317 : : !Set up parallelism over atoms
318 [ + + + + ]: 19829 : paral_atom=(present(comm_atom).and.(my_natom/=natom))
319 [ + + ]: 19829 : nullify(my_atmtab);if (present(mpi_atmtab)) my_atmtab => mpi_atmtab
320 [ + + ]: 19829 : my_comm_atom=xmpi_comm_self;if (present(comm_atom)) my_comm_atom=comm_atom
321 : 19829 : call get_my_atmtab(my_comm_atom,my_atmtab,my_atmtab_allocated,paral_atom,natom,my_natom_ref=my_natom)
322 : :
323 : : !----- Various initializations
324 : 19829 : nsppol=1;nsploop=1
325 [ + + ]: 19829 : if (my_natom>0) then
326 : 18065 : nsppol=paw_ij(1)%nsppol
327 [ + + ]: 18065 : nsploop=nsppol;if (paw_ij(1)%ndij==4) nsploop=4
328 : : end if
329 [ + + ]: 50029 : usexcnhat=maxval(pawtab(1:ntypat)%usexcnhat)
330 [ + + ]: 19829 : my_comm_grid=xmpi_comm_self;if (present(mpi_comm_grid)) my_comm_grid=mpi_comm_grid
331 : :
332 : : !------ Select potential for Dij^hat computation
333 : 19829 : v_dijhat_allocated=.false.
334 [ + + ]: 19829 : if (my_natom>0) then
335 [ - + - - : 18065 : if ((paw_ij(1)%has_dij==1).or.(paw_ij(1)%has_dijhat==1).or. &
- - - - ]
336 : : & (paw_ij(1)%has_dijhat==0.and.pawprtvol/=0)) then
337 [ + + ]: 18065 : if (usexcnhat==0) then
338 [ + - - + ]: 10578 : if (size(vxc,1)/=cplex*nfft.or.size(vxc,2)/=nspden) then
339 : 0 : msg='invalid size for vxc!'
340 : 0 : LIBPAW_BUG(msg)
341 : : end if
342 [ - + + - : 42312 : LIBPAW_POINTER_ALLOCATE(v_dijhat,(cplex*nfft,nspden))
- + + - +
- + - - +
- + ]
343 : 10578 : v_dijhat_allocated=.true.
344 : : !v_dijhat=vtrial-vxc
345 [ + + ]: 23808 : do idij=1,nspden
346 [ + + ]: 457478959 : do klmn=1,cplex*nfft
347 : 457468381 : v_dijhat(klmn,idij)=vtrial(klmn,idij)-vxc(klmn,idij)
348 : : end do
349 : : end do
350 : : else
351 : 7487 : v_dijhat => vtrial
352 : : end if
353 : : end if
354 : : end if
355 : :
356 : : !------------------------------------------------------------------------
357 : : !----- Loop over atoms
358 : : !------------------------------------------------------------------------
359 : :
360 [ + + ]: 63438 : do iatom=1,my_natom
361 [ + + ]: 43609 : iatom_tot=iatom;if (paral_atom) iatom_tot=my_atmtab(iatom)
362 : :
363 : : ! === Atom-dependent data ===
364 : :
365 : 43609 : itypat=paw_ij(iatom)%itypat
366 : 43609 : cplex_dij=paw_ij(iatom)%cplex_dij
367 : 43609 : qphase=paw_ij(iatom)%qphase
368 : 43609 : lm_size=paw_an(iatom)%lm_size
369 : 43609 : lmn2_size=paw_ij(iatom)%lmn2_size
370 : 43609 : ndij=paw_ij(iatom)%ndij
371 : 43609 : usepawu=pawtab(itypat)%usepawu
372 [ + + + + ]: 43609 : pawu_algo=merge(PAWU_ALGO_1,PAWU_ALGO_2,ipert<=0.and.usepawu>=0)
373 [ + + ]: 43609 : pawu_dblec=merge(PAWU_FLL,PAWU_AMF,abs(usepawu)==1.or.abs(usepawu)==4)
374 [ + + ]: 43609 : usekden=merge(0,1,paw_an(iatom)%has_vxctau/=2)
375 : : need_to_print=((abs(pawprtvol)>=1).and. &
376 [ + + + + : 43609 : & (iatom_tot==1.or.iatom_tot==natom.or.pawprtvol<0))
+ + + + ]
377 : :
378 : : ! === Determine which conditions and prerequisites are fulfilled for Dij ===
379 : :
380 [ + - ]: 43609 : if (my_natom>0) then
381 : : ! Total Dij: no condition ; no prerequisites
382 : 43609 : dij_available=.true.;dij_prereq=.true.
383 : : ! Dij0: not available for RF ; need kij for the positron
384 [ + + + - ]: 43609 : dij0_available=(ipert<=0);dij0_prereq=(ipositron/=1.or.pawtab(itypat)%has_kij==2)
385 : : ! DijFock:not available for RF, positron; only for Fock exact exch. ; Vxc_ex needed
386 [ + + + - : 43609 : dijfock_available=(paw_ij(iatom)%has_dijfock>0.and.ipert<=0.and.ipositron/=1)
- + ]
387 : 43609 : dijfock_prereq=(paw_ij(iatom)%has_dijfock==2)
388 : : ! DijHartree: no condition ; no prerequisites
389 : 43609 : dijhartree_available=.true.;dijhartree_prereq=.true.
390 : : ! DijXC: no condition ; Vxc needed
391 : 43609 : dijxc_available=.true.
392 [ + - + - ]: 43609 : dijxc_prereq=(paw_ij(iatom)%has_dijxc==2.or.paw_an(iatom)%has_vxc>0)
393 : : ! Dij^hat: no condition ; no prerequisites
394 : 43609 : dijhat_available=.true.;dijhat_prereq=.true.
395 : : ! Dij^hat_FR: only for RF and when it was previously computed
396 [ + + - + ]: 43609 : dijhatfr_available=(ipert>0.and.paw_ij(iatom)%has_dijfr==2) ; dijhatfr_prereq=.true.
397 : : ! DijND: requires non-zero nucdipmom
398 : 43609 : dijnd_available=.false. ; dijnd_prereq=(cplex_dij==2)
399 [ + + + + : 155112 : if (has_nucdipmom) dijnd_available=(any(abs(nucdipmom(:,iatom))>tol8))
+ + ]
400 : : ! DijSO: not available for RF, positron; only for spin-orbit ; VHartree and Vxc needed
401 [ + + + - : 43609 : dijso_available=(pawspnorb>0.and.ipert<=0.and.ipositron/=1)
- + ]
402 : : dijso_prereq=(paw_ij(iatom)%has_dijso==2.or.&
403 [ + + + + : 43609 : & (paw_an(iatom)%has_vhartree>0.and.paw_an(iatom)%has_vxc>0))
+ - ]
404 : : ! DijU: not available for positron; only for DFT+U
405 [ + + - + ]: 43609 : dijU_available=(pawtab(itypat)%usepawu/=0.and.ipositron/=1)
406 : : dijU_prereq=(paw_ij(iatom)%has_dijU==2.or.paw_ij(iatom)%has_pawu_occ>0.or. &
407 [ + + + + : 43609 : & (paw_ij(iatom)%has_dijU>0))
+ + ]
408 : : ! DijExxc: not available for RF, positron; only for local exact exch. ; Vxc_ex needed
409 [ + + + - : 43609 : dijexxc_available=(pawtab(itypat)%useexexch/=0.and.ipert<=0.and.ipositron/=1)
- + ]
410 [ + - + + ]: 43609 : dijexxc_prereq=(paw_ij(iatom)%has_dijexxc==2.or.paw_ij(iatom)%has_exexch_pot>0)
411 : : ! DijXC^hat: not available for RF ; Vxc needed
412 : 43609 : dijxchat_available=(ipert<=0)
413 [ + - + - ]: 43609 : dijxchat_prereq=(paw_ij(iatom)%has_dijxc_hat==2.or.paw_an(iatom)%has_vxc>0)
414 : : ! DijXC_val: not available for RF ; Vxc_val needed
415 : 43609 : dijxcval_available=(ipert<=0)
416 [ + - + + ]: 43609 : dijxcval_prereq=(paw_ij(iatom)%has_dijxc_val==2.or.paw_an(iatom)%has_vxcval>0)
417 : : end if
418 : :
419 : : ! === Determine which parts of Dij have to be computed ===
420 : :
421 : 43609 : dij_need=.false.;dij0_need=.false.;dijexxc_need=.false.;dijfock_need=.false.
422 : 43609 : dijhartree_need=.false.;dijhat_need=.false.;dijhatfr_need=.false.;
423 : 43609 : dijso_need=.false.;dijU_need=.false.;dijxc_need=.false.
424 : 43609 : dijxchat_need=.false.;dijxcval_need=.false.; dijnd_need=.false.
425 : :
426 : : if (dij_available) then
427 [ + - ]: 43609 : if (paw_ij(iatom)%has_dij==1) then
428 [ + + + + ]: 5513528 : dij_need=.true.;paw_ij(iatom)%dij(:,:)=zero
429 [ # # # # ]: 0 : else if (paw_ij(iatom)%has_dij==0.and.need_to_print) then
430 [ # # # # : 0 : LIBPAW_ALLOCATE(paw_ij(iatom)%dij,(cplex_dij*qphase*lmn2_size,ndij))
# # # # #
# # # # #
# # # # ]
431 [ # # # # ]: 0 : dij_need=.true.;paw_ij(iatom)%dij(:,:)=zero
432 : 0 : paw_ij(iatom)%has_dij=-1
433 : : end if
434 : : else if (paw_ij(iatom)%has_dij==1) then
435 : : paw_ij(iatom)%dij=zero
436 : : end if
437 : :
438 [ + + ]: 43609 : if (dij0_available) then
439 [ - + ]: 37666 : if (paw_ij(iatom)%has_dij0==1) then
440 [ # # ]: 0 : dij0_need=.true.;paw_ij(iatom)%dij0(:)=zero
441 [ + - + + ]: 37666 : else if (paw_ij(iatom)%has_dij0==0.and.need_to_print) then
442 [ - + + - : 5991 : LIBPAW_ALLOCATE(paw_ij(iatom)%dij0,(lmn2_size))
+ - + - -
+ - + -
+ ]
443 [ + + ]: 394984 : dij0_need=.true.;paw_ij(iatom)%dij0(:)=zero
444 : 1997 : paw_ij(iatom)%has_dij0=-1
445 : : end if
446 [ - + ]: 5943 : else if (paw_ij(iatom)%has_dij0==1) then
447 [ # # ]: 0 : paw_ij(iatom)%dij0=zero
448 : : end if
449 : :
450 [ + + ]: 43609 : if (dijfock_available) then
451 [ - + ]: 498 : if (paw_ij(iatom)%has_dijfock==1) then
452 [ # # # # ]: 0 : dijfock_need=.true.;paw_ij(iatom)%dijfock(:,:)=zero
453 [ - + - - ]: 498 : else if (paw_ij(iatom)%has_dijfock==0.and.need_to_print) then
454 [ # # # # : 0 : LIBPAW_ALLOCATE(paw_ij(iatom)%dijfock,(cplex_dij*lmn2_size,ndij))
# # # # #
# # # # #
# # # # ]
455 [ # # # # ]: 0 : dijfock_need=.true.;paw_ij(iatom)%dijfock(:,:)=zero
456 : 0 : paw_ij(iatom)%has_dijfock=-1
457 : : end if
458 [ - + ]: 43111 : else if (paw_ij(iatom)%has_dijfock==1) then
459 [ # # # # ]: 0 : paw_ij(iatom)%dijfock=zero
460 : : end if
461 : :
462 : : if (dijhartree_available) then
463 [ - + ]: 43609 : if (paw_ij(iatom)%has_dijhartree==1) then
464 [ # # ]: 0 : dijhartree_need=.true.;paw_ij(iatom)%dijhartree(:)=zero
465 [ - + ]: 43609 : else if (paw_ij(iatom)%has_dijhartree==0) then
466 [ # # # # : 0 : LIBPAW_ALLOCATE(paw_ij(iatom)%dijhartree,(qphase*lmn2_size))
# # # # #
# # # #
# ]
467 [ # # ]: 0 : dijhartree_need=.true.;paw_ij(iatom)%dijhartree(:)=zero
468 : 0 : paw_ij(iatom)%has_dijhartree=-1
469 : : end if
470 : : else if (paw_ij(iatom)%has_dijhartree==1) then
471 : : paw_ij(iatom)%dijhartree=zero
472 : : end if
473 : :
474 : : if (dijxc_available) then
475 [ + + ]: 43609 : if (paw_ij(iatom)%has_dijxc==1) then
476 [ + + + + ]: 1673 : dijxc_need=.true.;paw_ij(iatom)%dijxc(:,:)=zero
477 [ + - + + ]: 43578 : else if (paw_ij(iatom)%has_dijxc==0.and.need_to_print) then
478 [ - + + - : 7972 : LIBPAW_ALLOCATE(paw_ij(iatom)%dijxc,(cplex_dij*qphase*lmn2_size,ndij))
- + + - +
- + - - +
- + - + ]
479 [ + + + + ]: 1462265 : dijxc_need=.true.;paw_ij(iatom)%dijxc(:,:)=zero
480 : 1993 : paw_ij(iatom)%has_dijxc=-1
481 : : end if
482 : : else if (paw_ij(iatom)%has_dijxc==1) then
483 : : paw_ij(iatom)%dijxc=zero
484 : : end if
485 : :
486 : : if (dijhat_available) then
487 [ + + ]: 43609 : if (paw_ij(iatom)%has_dijhat==1) then
488 [ + + + + ]: 1878 : dijhat_need=.true.;paw_ij(iatom)%dijhat(:,:)=zero
489 [ + - + + ]: 43574 : else if (paw_ij(iatom)%has_dijhat==0.and.need_to_print) then
490 [ - + + - : 7972 : LIBPAW_ALLOCATE(paw_ij(iatom)%dijhat,(cplex_dij*qphase*lmn2_size,ndij))
- + + - +
- + - - +
- + - + ]
491 [ + + + + ]: 1462265 : dijhat_need=.true.;paw_ij(iatom)%dijhat(:,:)=zero
492 : 1993 : paw_ij(iatom)%has_dijhat=-1
493 : : end if
494 : : else if (paw_ij(iatom)%has_dijhat==1) then
495 : : paw_ij(iatom)%dijhat=zero
496 : : end if
497 : :
498 [ + + ]: 43609 : if (dijnd_available) then
499 [ - + ]: 639 : if (paw_ij(iatom)%has_dijnd==1) then
500 [ # # # # ]: 0 : dijnd_need=.true.;paw_ij(iatom)%dijnd(:,:)=zero
501 [ - + - - ]: 639 : else if (paw_ij(iatom)%has_dijnd==0.and.need_to_print) then
502 [ # # # # : 0 : LIBPAW_ALLOCATE(paw_ij(iatom)%dijnd,(cplex_dij*lmn2_size,ndij))
# # # # #
# # # # #
# # # # ]
503 [ # # # # ]: 0 : dijnd_need=.true.;paw_ij(iatom)%dijnd(:,:)=zero
504 : 0 : paw_ij(iatom)%has_dijnd=-1
505 : : end if
506 [ + + ]: 42970 : else if (paw_ij(iatom)%has_dijnd==1) then
507 [ + + + + ]: 28595 : paw_ij(iatom)%dijnd=zero
508 : : end if
509 : :
510 [ + + ]: 43609 : if (dijso_available) then
511 [ - + ]: 2220 : if (paw_ij(iatom)%has_dijso==1) then
512 [ # # # # ]: 0 : dijso_need=.true.;paw_ij(iatom)%dijso(:,:)=zero
513 [ - + - - ]: 2220 : else if (paw_ij(iatom)%has_dijso==0.and.need_to_print) then
514 [ # # # # : 0 : LIBPAW_ALLOCATE(paw_ij(iatom)%dijso,(cplex_dij*qphase*lmn2_size,ndij))
# # # # #
# # # # #
# # # # ]
515 [ # # # # ]: 0 : dijso_need=.true.;paw_ij(iatom)%dijso(:,:)=zero
516 : 0 : paw_ij(iatom)%has_dijso=-1
517 : : end if
518 [ - + ]: 41389 : else if (paw_ij(iatom)%has_dijso==1) then
519 [ # # # # ]: 0 : paw_ij(iatom)%dijso=zero
520 : : end if
521 : :
522 [ + + ]: 43609 : if (dijU_available) then
523 [ + + ]: 2834 : if (paw_ij(iatom)%has_dijU==1) then
524 [ + + + + ]: 23310 : dijU_need=.true.;paw_ij(iatom)%dijU(:,:)=zero
525 [ + + + + ]: 2744 : else if (paw_ij(iatom)%has_dijU==0.and.need_to_print) then
526 [ - + + - : 5256 : LIBPAW_ALLOCATE(paw_ij(iatom)%dijU,(cplex_dij*qphase*lmn2_size,ndij))
- + + - +
- + - - +
- + - + ]
527 [ + + + + ]: 1085996 : dijU_need=.true.;paw_ij(iatom)%dijU(:,:)=zero
528 : 1314 : paw_ij(iatom)%has_dijU=-1
529 : : end if
530 [ + + ]: 40775 : else if (paw_ij(iatom)%has_dijU==1) then
531 [ + + + + ]: 3041654 : paw_ij(iatom)%dijU=zero
532 : : end if
533 : :
534 [ + + + - ]: 43609 : if (dijexxc_available.and.paw_ij(iatom)%has_dijexxc/=2) then
535 [ - + ]: 42 : if (paw_ij(iatom)%has_dijexxc==1) then
536 [ # # # # ]: 0 : dijexxc_need=.true.;paw_ij(iatom)%dijexxc(:,:)=zero
537 [ + - - + ]: 42 : else if (paw_ij(iatom)%has_dijexxc==0.and.need_to_print) then
538 [ # # # # : 0 : LIBPAW_ALLOCATE(paw_ij(iatom)%dijexxc,(cplex_dij*lmn2_size,ndij))
# # # # #
# # # # #
# # # # ]
539 [ # # # # ]: 0 : dijexxc_need=.true.;paw_ij(iatom)%dijexxc(:,:)=zero
540 : 0 : paw_ij(iatom)%has_dijexxc=-1
541 : : end if
542 [ - + ]: 43567 : else if (paw_ij(iatom)%has_dijexxc==1) then
543 [ # # # # ]: 0 : paw_ij(iatom)%dijexxc=zero
544 : : end if
545 : :
546 [ + + ]: 43609 : if (dijxchat_available) then
547 [ + + ]: 37666 : if (paw_ij(iatom)%has_dijxc_hat==1) then
548 [ + + + + ]: 1673 : dijxchat_need=.true.;paw_ij(iatom)%dijxc_hat(:,:)=zero
549 : : ! else if (paw_ij(iatom)%has_dijxc_hat==0.and.need_to_print) then
550 : : ! LIBPAW_ALLOCATE(paw_ij(iatom)%dijxc_hat,(cplex_dij*qphase*lmn2_size,ndij))
551 : : ! dijxchat_need=.true.;paw_ij(iatom)%dijxc_hat(:,:)=zero
552 : : ! paw_ij(iatom)%has_dijxc_hat=-1
553 : : end if
554 [ - + ]: 5943 : else if (paw_ij(iatom)%has_dijxc_hat==1) then
555 [ # # # # ]: 0 : paw_ij(iatom)%dijxc_hat=zero
556 : : end if
557 : :
558 [ + + ]: 43609 : if (dijxcval_available) then
559 [ + + ]: 37666 : if (paw_ij(iatom)%has_dijxc_val==1) then
560 [ + + + + ]: 1673 : dijxcval_need=.true.;paw_ij(iatom)%dijxc_val(:,:)=zero
561 : : ! else if (paw_ij(iatom)%has_dijxc_val==0.and.need_to_print) then
562 : : ! LIBPAW_ALLOCATE(paw_ij(iatom)%dijxc_val,(cplex_dij*qphase*lmn2_size,ndij))
563 : : ! dijxcval_need=.true.;paw_ij(iatom)%dijxc_val(:,:)=zero
564 : : ! paw_ij(iatom)%has_dijxc_val=-1
565 : : end if
566 [ - + ]: 5943 : else if (paw_ij(iatom)%has_dijxc_val==1) then
567 [ # # # # ]: 0 : paw_ij(iatom)%dijxc_val=zero
568 : : end if
569 : :
570 : : ! === Print error messages if prerequisites are not fulfilled ===
571 : :
572 : : if (dij_need.and.(.not.dij_prereq)) then
573 : : msg='Dij prerequisites missing!'
574 : : LIBPAW_BUG(msg)
575 : : end if
576 [ - + ]: 43609 : if (dij0_need.and.(.not.dij0_prereq)) then
577 : 0 : msg='Dij0 prerequisites missing!'
578 : 0 : LIBPAW_BUG(msg)
579 : : end if
580 [ - + ]: 43609 : if (dijfock_need.and.(.not.dijfock_prereq)) then
581 : 0 : msg='DijFock prerequisites missing!'
582 : 0 : LIBPAW_BUG(msg)
583 : : end if
584 : :
585 : : if (dijhartree_need.and.(.not.dijhartree_prereq)) then
586 : : msg='DijHartree prerequisites missing!'
587 : : LIBPAW_BUG(msg)
588 : : end if
589 [ - + ]: 43609 : if (dijxc_need.and.(.not.dijxc_prereq)) then
590 : 0 : msg='Dij^XC prerequisites missing!'
591 : 0 : LIBPAW_BUG(msg)
592 : : end if
593 : : if (dijhat_need.and.(.not.dijhat_prereq)) then
594 : : msg='Dij^hat prerequisites missing!'
595 : : LIBPAW_BUG(msg)
596 : : end if
597 : : if (dijhatfr_need.and.(.not.dijhatfr_prereq)) then
598 : : msg='DijFR^hat prerequisites missing!'
599 : : LIBPAW_BUG(msg)
600 : : end if
601 [ - + ]: 43609 : if (dijnd_need.and.(.not.dijnd_prereq)) then
602 : 0 : msg='DijND prerequisites missing!'
603 : 0 : LIBPAW_BUG(msg)
604 : : end if
605 [ - + ]: 43609 : if (dijso_need.and.(.not.dijso_prereq)) then
606 : 0 : msg='DijSO prerequisites missing!'
607 : 0 : LIBPAW_BUG(msg)
608 : : end if
609 [ - + ]: 43609 : if (dijU_need.and.(.not.dijU_prereq)) then
610 : 0 : msg='DijU prerequisites missing!'
611 : 0 : LIBPAW_BUG(msg)
612 : : end if
613 [ - + ]: 43609 : if (dijexxc_need.and.(.not.dijexxc_prereq)) then
614 : 0 : msg='DijExcc prerequisites missing!'
615 : 0 : LIBPAW_BUG(msg)
616 : : end if
617 [ - + ]: 43609 : if (dijxchat_need.and.(.not.dijxchat_prereq)) then
618 : 0 : msg='DijXC^hat prerequisites missing!'
619 : 0 : LIBPAW_BUG(msg)
620 : : end if
621 [ - + ]: 43609 : if (dijxcval_need.and.(.not.dijxcval_prereq)) then
622 : 0 : msg='DijXC_val prerequisites missing!'
623 : 0 : LIBPAW_BUG(msg)
624 : : end if
625 : :
626 : : ! ------------------------------------------------------------------------
627 : : ! ----------- Add atomic Dij0 to Dij
628 : : ! ------------------------------------------------------------------------
629 : :
630 [ + - + + ]: 43609 : if ((dij0_need.or.dij_need).and.dij0_available) then
631 : :
632 [ - + + - : 112998 : LIBPAW_ALLOCATE(dij0,(lmn2_size))
+ - + - -
+ - + ]
633 : : ! ===== Dij0 already computed
634 [ - + ]: 37666 : if (paw_ij(iatom)%has_dij0==2) then
635 [ # # ]: 0 : dij0(:)=paw_ij(iatom)%dij0(:)
636 : : else
637 : : ! ===== Need to compute Dij0
638 [ + + ]: 2150813 : dij0(:)=pawtab(itypat)%dij0(:)
639 [ + + + + ]: 125086 : if (ipositron==1) dij0(:)=two*pawtab(itypat)%kij(:)-dij0(:)
640 [ + + + + ]: 69218 : if (pawu_algo==PAWU_ALGO_2.and.pawu_dblec==PAWU_FLL) dij0(:)=dij0(:)+pawtab(itypat)%euij_fll(:)
641 [ + + + + ]: 430653 : if (dij0_need) paw_ij(iatom)%dij0(:)=dij0(:)
642 : : end if
643 : :
644 [ + - ]: 37666 : if (dij_need) then
645 [ + + ]: 82336 : do idij=1,min(nsploop,2)
646 : : klmn1=1
647 [ + + ]: 3062838 : do klmn=1,lmn2_size
648 : 2980502 : paw_ij(iatom)%dij(klmn1,idij)=paw_ij(iatom)%dij(klmn1,idij)+dij0(klmn)
649 : 3025172 : klmn1=klmn1+cplex_dij
650 : : end do
651 : : end do
652 : : end if
653 [ - + ]: 37666 : LIBPAW_DEALLOCATE(dij0)
654 : : end if
655 : :
656 : : ! ------------------------------------------------------------------------
657 : : ! ------------------------------------------------------------------------
658 : : ! ----------- Add Dij_{Fock exact-exchange} to Dij
659 : : ! ------------------------------------------------------------------------
660 : :
661 [ + - + + ]: 43609 : if ((dijfock_need.or.dij_need).and.dijfock_available) then
662 : :
663 : : ! ===== DijFock already computed
664 [ + - ]: 498 : if (paw_ij(iatom)%has_dijfock==2) then
665 [ + - ]: 498 : if (dij_need) paw_ij(iatom)%dij(1:cplex_dij*lmn2_size,:)= &
666 : : & paw_ij(iatom)%dij(1:cplex_dij*lmn2_size,:) &
667 [ + + + + ]: 18749 : & +paw_ij(iatom)%dijfock(1:cplex_dij*lmn2_size,:)
668 : :
669 : : else
670 : :
671 : : ! ===== Need to compute DijFock
672 [ # # # # : 0 : LIBPAW_ALLOCATE(dijfock_vv,(cplex_dij*lmn2_size,ndij))
# # # # #
# # # # #
# # # # ]
673 [ # # # # : 0 : LIBPAW_ALLOCATE(dijfock_cv,(cplex_dij*lmn2_size,ndij))
# # # # #
# # # #
# ]
674 [ # # # # : 0 : dijfock_vv(:,:)=zero ; dijfock_cv(:,:)=zero
# # # # ]
675 : : ! Exact exchange is evaluated for electrons only
676 [ # # ]: 0 : if (ipositron/=1) then
677 : : call pawdijfock(dijfock_vv,dijfock_cv,cplex_dij,qphase,hyb_mixing_,hyb_mixing_sr_, &
678 : 0 : & ndij,pawrhoij(iatom),pawtab(itypat))
679 : : end if
680 [ # # # # : 0 : if (dijfock_need) paw_ij(iatom)%dijfock(:,:)=dijfock_vv(:,:)+dijfock_cv(:,:)
# # ]
681 [ # # ]: 0 : if (dij_need) paw_ij(iatom)%dij(1:cplex_dij*lmn2_size,:)= &
682 : : & paw_ij(iatom)%dij(1:cplex_dij*lmn2_size,:) &
683 [ # # # # ]: 0 : & +dijfock_vv(1:cplex_dij*lmn2_size,:)+dijfock_cv(1:cplex_dij*lmn2_size,:)
684 [ # # ]: 0 : LIBPAW_DEALLOCATE(dijfock_vv)
685 [ # # ]: 0 : LIBPAW_DEALLOCATE(dijfock_cv)
686 : : end if
687 : : end if
688 : :
689 : : ! ----------- Add Dij_Hartree to Dij
690 : : ! ------------------------------------------------------------------------
691 : :
692 [ + - ]: 43609 : if ((dijhartree_need.or.dij_need).and.dijhartree_available) then
693 : :
694 [ - + + - : 130827 : LIBPAW_ALLOCATE(dijhartree,(qphase*lmn2_size))
+ - + - -
+ - + -
+ ]
695 : : ! ===== DijHartree already computed
696 [ + - ]: 43609 : if (paw_ij(iatom)%has_dijhartree==2) then
697 [ + + ]: 2400856 : dijhartree(:)=paw_ij(iatom)%dijhartree(:)
698 : : else
699 : : ! ===== Need to compute DijHartree
700 : 0 : is_sym=.true.
701 [ # # ]: 0 : if(present(eijkl_is_sym)) is_sym=eijkl_is_sym(itypat)
702 [ # # ]: 0 : if (ipositron/=1) then
703 : 0 : call pawdijhartree(dijhartree,qphase,nspden,pawrhoij(iatom),pawtab(itypat),is_sym=is_sym)
704 : : else
705 [ # # ]: 0 : dijhartree(:)=zero
706 : : end if
707 [ # # ]: 0 : if (ipositron/=0) then
708 [ # # # # : 0 : LIBPAW_ALLOCATE(dij_ep,(qphase*lmn2_size))
# # # # #
# ]
709 : 0 : call pawdijhartree(dij_ep,qphase,nspden,electronpositron_pawrhoij(iatom),pawtab(itypat))
710 [ # # ]: 0 : dijhartree(:)=dijhartree(:)-dij_ep(:)
711 [ # # ]: 0 : LIBPAW_DEALLOCATE(dij_ep)
712 : : end if
713 [ # # # # ]: 0 : if (dijhartree_need) paw_ij(iatom)%dijhartree(:)=dijhartree(:)
714 : : end if
715 : :
716 [ + - ]: 43609 : if (dij_need) then
717 [ + + ]: 95522 : do idij=1,min(nsploop,2)
718 : : klmn1=1
719 [ + + ]: 3370596 : do klmn=1,qphase*lmn2_size
720 : 3275074 : paw_ij(iatom)%dij(klmn1,idij)=paw_ij(iatom)%dij(klmn1,idij)+dijhartree(klmn)
721 : 3326987 : klmn1=klmn1+cplex_dij
722 : : end do
723 : : end do
724 : : end if
725 : :
726 [ - + ]: 43609 : LIBPAW_DEALLOCATE(dijhartree)
727 : : end if
728 : :
729 : : ! ------------------------------------------------------------------------
730 : : ! ----------- Add Dij_xc to Dij
731 : : ! ------------------------------------------------------------------------
732 : :
733 [ + - ]: 43609 : if ((dijxc_need.or.dij_need).and.dijxc_available) then
734 : :
735 : : ! ===== Dijxc already computed
736 [ - + ]: 43609 : if (paw_ij(iatom)%has_dijxc==2) then
737 [ # # # # : 0 : if (dij_need) paw_ij(iatom)%dij(:,:)=paw_ij(iatom)%dij(:,:)+paw_ij(iatom)%dijxc(:,:)
# # ]
738 : : else
739 : :
740 : : ! ===== Need to compute DijXC
741 [ - + + - : 174436 : LIBPAW_ALLOCATE(dijxc,(cplex_dij*qphase*lmn2_size,ndij))
- + + - +
- + - - +
- + - + ]
742 [ + + ]: 43609 : if (pawxcdev/=0) then
743 [ - + + - : 122715 : LIBPAW_ALLOCATE(lmselect,(lm_size))
+ - + - -
+ - + -
+ ]
744 [ + + ]: 459339 : lmselect(:)=paw_an(iatom)%lmselect(:)
745 [ + + + + : 93789 : if (ipositron/=0) lmselect(:)=(lmselect(:).or.electronpositron_lmselect(1:lm_size,iatom))
+ + + + ]
746 : : call pawdijxcm(dijxc,cplex_dij,qphase,lmselect,ndij,nspden,nsppol,pawang,&
747 : : & pawrad(itypat),pawtab(itypat),paw_an(iatom)%vxc1,&
748 : 40905 : & paw_an(iatom)%vxct1,usexcnhat)
749 [ - + ]: 40905 : LIBPAW_DEALLOCATE(lmselect)
750 : : else
751 : : call pawdijxc(dijxc,cplex_dij,qphase,ndij,nspden,nsppol,&
752 : : & pawang,pawrad(itypat),pawtab(itypat),paw_an(iatom)%vxc1,&
753 : : & paw_an(iatom)%vxct1,usexcnhat,usekden,&
754 : 2704 : & vxctau1=paw_an(iatom)%vxctau1,vxcttau1=paw_an(iatom)%vxcttau1)
755 : : end if
756 [ + + + + : 1505523 : if (dijxc_need) paw_ij(iatom)%dijxc(:,:)=dijxc(:,:)
+ + ]
757 [ + - + + : 5513528 : if (dij_need) paw_ij(iatom)%dij(:,:)=paw_ij(iatom)%dij(:,:)+dijxc(:,:)
+ + ]
758 [ - + ]: 43609 : LIBPAW_DEALLOCATE(dijxc)
759 : : end if
760 : :
761 : : end if
762 : :
763 : : ! ------------------------------------------------------------------------
764 : : ! ----------- Add Dij_hat to Dij
765 : : ! ------------------------------------------------------------------------
766 : :
767 [ + - ]: 43609 : if ((dijhat_need.or.dij_need).and.dijhat_available) then
768 : :
769 : : ! ===== Dijhat already computed
770 [ - + ]: 43609 : if (paw_ij(iatom)%has_dijhat==2) then
771 [ # # # # : 0 : if (dij_need) paw_ij(iatom)%dij(:,:)=paw_ij(iatom)%dij(:,:)+paw_ij(iatom)%dijhat(:,:)
# # ]
772 : : else
773 : :
774 : : ! ===== Need to compute Dijhat
775 [ - + + - : 174436 : LIBPAW_ALLOCATE(dijhat,(cplex_dij*qphase*lmn2_size,ndij))
- + + - +
- + - - +
- + - + ]
776 : : call pawdijhat(dijhat,cplex_dij,qphase,gprimd,iatom_tot,&
777 : : & natom,ndij,nfft,nfftot,nspden,nsppol,pawang,pawfgrtab(iatom),&
778 [ - + ]: 43609 : & pawtab(itypat),v_dijhat,qphon,ucvol,xred,mpi_comm_grid=my_comm_grid)
779 [ + + + + : 1505724 : if (dijhat_need) paw_ij(iatom)%dijhat(:,:)=dijhat(:,:)
+ + ]
780 [ + - + + : 5513528 : if (dij_need) paw_ij(iatom)%dij(:,:)=paw_ij(iatom)%dij(:,:)+dijhat(:,:)
+ + ]
781 [ - + ]: 43609 : LIBPAW_DEALLOCATE(dijhat)
782 : : end if
783 : :
784 : : ! ===== RF: add frozen part of 1st-order Dij
785 [ + + ]: 43609 : if (dijhatfr_available) then
786 [ + + ]: 13186 : do idij=1,nsploop
787 [ + - ]: 7243 : if (dij_need) paw_ij(iatom)%dij(:,idij)=paw_ij(iatom)%dij(:,idij) &
788 [ + + ]: 301815 : & +paw_ij(iatom)%dijfr(:,idij)
789 [ - + ]: 7243 : if (dijhat_need) paw_ij(iatom)%dijhat(:,idij)=paw_ij(iatom)%dijhat(:,idij) &
790 [ - - ]: 5943 : & +paw_ij(iatom)%dijfr(:,idij)
791 : : end do
792 : : end if
793 : :
794 : : end if
795 : :
796 : : ! ------------------------------------------------------------------------
797 : : ! ----------- Add Dij nuclear dipole moments to Dij
798 : : ! ------------------------------------------------------------------------
799 : :
800 [ + - + + ]: 43609 : if ((dijnd_need.or.dij_need).and.dijnd_available) then
801 : :
802 : : ! ===== Dijnd already computed
803 [ + - ]: 639 : if (paw_ij(iatom)%has_dijnd==2) then
804 [ + - ]: 639 : if (dij_need) then
805 : : paw_ij(iatom)%dij(1:cplex_dij*lmn2_size,:)= &
806 : : & paw_ij(iatom)%dij(1:cplex_dij*lmn2_size,:) + &
807 [ + + + + ]: 113789 : & paw_ij(iatom)%dijnd(1:cplex_dij*lmn2_size,:)
808 : : end if
809 : :
810 : : else
811 : :
812 : : ! ===== Need to compute Dijnd
813 [ # # # # : 0 : LIBPAW_ALLOCATE(dijnd,(cplex_dij*lmn2_size,ndij))
# # # # #
# # # # #
# # # # ]
814 : : call pawdijnd(dijnd,cplex_dij,gprimd,iatom,natom,ndij,nspden,nucdipmom(1:3,1:natom),&
815 : : & pawang,pawrad(itypat),pawtab(itypat),pawxcdev,qphase,&
816 : 0 : & paw_an(iatom)%vh1,paw_an(iatom)%vxc1,xred,znuc(itypat),paw_ij(iatom)%zora)
817 [ # # # # : 0 : if (dijnd_need) paw_ij(iatom)%dijnd(:,:)=dijnd(:,:)
# # ]
818 [ # # ]: 0 : if (dij_need) then
819 : : paw_ij(iatom)%dij(1:cplex_dij*lmn2_size,:)= &
820 : : & paw_ij(iatom)%dij(1:cplex_dij*lmn2_size,:) + &
821 [ # # # # ]: 0 : & dijnd(1:cplex_dij*lmn2_size,:)
822 : : end if
823 [ # # ]: 0 : LIBPAW_DEALLOCATE(dijnd)
824 : : end if
825 : :
826 : : end if
827 : :
828 : : ! ------------------------------------------------------------------------
829 : : ! ----------- Add Dij spin-orbit to Dij
830 : : ! ------------------------------------------------------------------------
831 : :
832 [ + - + + ]: 43609 : if ((dijso_need.or.dij_need).and.dijso_available) then
833 : :
834 : : ! ===== DijSO already computed
835 [ + - ]: 2220 : if (paw_ij(iatom)%has_dijso==2) then
836 [ + - + + : 1858996 : if (dij_need) paw_ij(iatom)%dij(:,:)=paw_ij(iatom)%dij(:,:)+paw_ij(iatom)%dijso(:,:)
+ + ]
837 : : else
838 : :
839 : : ! ===== Need to compute DijSO
840 [ # # # # : 0 : LIBPAW_ALLOCATE(dijso,(cplex_dij*qphase*lmn2_size,ndij))
# # # # #
# # # # #
# # # # ]
841 [ # # ]: 0 : spinaxis_in = [zero, zero, one]; if (present(spinaxis)) spinaxis_in = spinaxis
842 : : call pawdijso(dijso,cplex_dij,qphase,ndij,nspden,&
843 : : & pawang,pawrad(itypat),pawtab(itypat),pawxcdev,spnorbscl,&
844 : : & paw_an(iatom)%vh1,paw_an(iatom)%vxc1,znuc(itypat),paw_ij(iatom)%zora,&
845 [ # # ]: 0 : & nucdipmom=nucdipmom(1:3,iatom),spinaxis=spinaxis_in)
846 [ # # # # : 0 : if (dijso_need) paw_ij(iatom)%dijso(:,:)=dijso(:,:)
# # ]
847 [ # # # # : 0 : if (dij_need) paw_ij(iatom)%dij(:,:)=paw_ij(iatom)%dij(:,:)+dijso(:,:)
# # ]
848 [ # # ]: 0 : LIBPAW_DEALLOCATE(dijso)
849 : : end if
850 : :
851 : : end if
852 : :
853 : : ! ------------------------------------------------------------------------
854 : : ! ----------- Add Dij_{DFT+U} to Dij
855 : : ! ------------------------------------------------------------------------
856 : :
857 [ + - + + ]: 43609 : if ((dijU_need.or.dij_need).and.dijU_available) then
858 : :
859 : : ! ===== DijU already computed
860 [ + + ]: 2834 : if (paw_ij(iatom)%has_dijU==2) then
861 [ + - + + : 170996 : if (dij_need) paw_ij(iatom)%dij(:,:)=paw_ij(iatom)%dij(:,:)+paw_ij(iatom)%dijU(:,:)
+ + ]
862 : : else
863 : :
864 : : ! ===== Need to compute DijU
865 [ - + + - : 10808 : LIBPAW_ALLOCATE(dijpawu,(cplex_dij*qphase*lmn2_size,ndij))
- + + - +
- + - - +
- + - + ]
866 [ + + ]: 2702 : if (pawu_algo==PAWU_ALGO_2) then
867 : 90 : call pawdiju_euijkl(dijpawu,cplex_dij,qphase,ndij,pawrhoij(iatom),pawtab(itypat))
868 : : else
869 : 2612 : lpawu=pawtab(itypat)%lpawu
870 [ - + + - : 15672 : LIBPAW_POINTER_ALLOCATE(vpawu,(cplex_dij,lpawu*2+1,lpawu*2+1,ndij))
+ - - + +
- - + + -
- + + - +
- + - - +
- + ]
871 [ + + + + : 17460 : if (usepawu>=10) vpawu=zero ! if dmft, do not apply U in DFT+U
+ + + + +
+ ]
872 : : if (usepawu< 10) then
873 : : call pawpupot(cplex_dij,ndij,paw_ij(iatom)%noccmmp,paw_ij(iatom)%nocctot,&
874 : 2463 : & pawprtvol,pawtab(itypat),vpawu)
875 : : end if
876 [ + + ]: 2612 : if (natvshift_==0) then
877 : 2084 : call pawdiju(dijpawu,cplex_dij,qphase,ndij,nsppol,pawtab(itypat),vpawu)
878 : : else
879 : : call pawdiju(dijpawu,cplex_dij,qphase,ndij,nsppol,pawtab(itypat),vpawu,&
880 : : & natvshift=natvshift_,atvshift=atvshift(:,:,iatom_tot),&
881 [ + - - + ]: 528 : & fatvshift=fatvshift)
882 : : end if
883 [ - + ]: 2612 : LIBPAW_POINTER_DEALLOCATE(vpawu)
884 : : end if
885 [ + + + + : 1110604 : if (dijU_need) paw_ij(iatom)%dijU(:,:)=dijpawu(:,:)
+ + ]
886 [ + - + + : 1524808 : if (dij_need) paw_ij(iatom)%dij(:,:)=paw_ij(iatom)%dij(:,:)+dijpawu(:,:)
+ + ]
887 [ - + ]: 2702 : LIBPAW_DEALLOCATE(dijpawu)
888 : : end if
889 : :
890 : : end if
891 : :
892 : : ! ------------------------------------------------------------------------
893 : : ! ----------- Add Dij_{local exact-exchange} to Dij
894 : : ! ------------------------------------------------------------------------
895 : :
896 [ + - + + ]: 43609 : if ((dijexxc_need.or.dij_need).and.dijexxc_available) then
897 : :
898 : : ! ===== DijEXXC already computed
899 [ - + ]: 42 : if (paw_ij(iatom)%has_dijexxc==2) then
900 [ # # ]: 0 : if (dij_need) paw_ij(iatom)%dij(1:cplex_dij*lmn2_size,:)= &
901 : : & paw_ij(iatom)%dij(1:cplex_dij*lmn2_size,:) &
902 [ # # # # ]: 0 : & +paw_ij(iatom)%dijexxc(1:cplex_dij*lmn2_size,:)
903 : : else
904 : :
905 : : ! ===== Need to compute DijEXXC
906 [ - + + - : 168 : LIBPAW_ALLOCATE(dijexxc,(cplex_dij*lmn2_size,ndij))
- + + - +
- + - - +
- + - + ]
907 [ + - ]: 42 : if (pawxcdev/=0) then
908 [ - + ]: 42 : if (paw_ij(iatom)%has_exexch_pot/=2) then
909 [ # # # # : 0 : LIBPAW_POINTER_ALLOCATE(vpawx,(1,lmn2_size,ndij))
# # # # #
# # # # #
# # ]
910 : 0 : call pawxpot(ndij,pawprtvol,pawrhoij(iatom),pawtab(itypat),vpawx)
911 : : else
912 : 42 : vpawx=>paw_ij(iatom)%vpawx
913 : : end if
914 [ - + + - : 126 : LIBPAW_ALLOCATE(lmselect,(lm_size))
+ - + - -
+ - + -
+ ]
915 [ + + ]: 1092 : lmselect(:)=paw_an(iatom)%lmselect(:)
916 [ - + - - : 42 : if (ipositron/=0) lmselect(:)=(lmselect(:).or.electronpositron_lmselect(1:lm_size,iatom))
- - - - ]
917 : : call pawdijexxc(dijexxc,cplex_dij,qphase,lmselect,ndij,nspden,nsppol,&
918 : 42 : & pawang,pawrad(itypat),pawtab(itypat),vpawx,paw_an(iatom)%vxc_ex)
919 [ - + ]: 42 : LIBPAW_DEALLOCATE(lmselect)
920 [ - + ]: 42 : if (paw_ij(iatom)%has_exexch_pot/=2) then
921 [ # # ]: 0 : LIBPAW_POINTER_DEALLOCATE(vpawx)
922 : : end if
923 [ - + - - : 42 : if (dijexxc_need) paw_ij(iatom)%dijexxc(:,:)=dijexxc(:,:)
- - ]
924 [ + - ]: 42 : if (dij_need) paw_ij(iatom)%dij(1:cplex_dij*lmn2_size,:)= &
925 : : & paw_ij(iatom)%dij(1:cplex_dij*lmn2_size,:) &
926 [ + + + + ]: 14490 : & +dijexxc(1:cplex_dij*lmn2_size,:)
927 [ - + ]: 42 : LIBPAW_DEALLOCATE(dijexxc)
928 : : end if
929 : : end if
930 : :
931 : : end if
932 : :
933 : : ! ------------------------------------------------------------------------
934 : : ! ----------- Add Dij background contribution to the total Dij
935 : : ! ------------------------------------------------------------------------
936 : :
937 [ + - + + ]: 43609 : if (dij_need.and.pawtab(itypat)%usepotzero==1 ) then
938 [ + + ]: 126 : do idij=1,min(nsploop,2)
939 : : klmn1=1
940 [ + + ]: 1134 : do klmn=1,lmn2_size
941 : 1008 : paw_ij(iatom)%dij(klmn1,idij)=paw_ij(iatom)%dij(klmn1,idij)+pawtab(itypat)%gammaij(klmn)*charge/ucvol
942 : 1071 : klmn1=klmn1+cplex_dij*qphase
943 : : end do
944 : : end do
945 : : end if
946 : :
947 : :
948 : : ! ------------------------------------------------------------------------
949 : : ! ----------- Compute Dijxc_hat
950 : : ! ------------------------------------------------------------------------
951 : :
952 [ + + ]: 43609 : if (dijxchat_need) then
953 : :
954 [ + - ]: 31 : if (usexcnhat/=0) then
955 [ - + + - : 124 : LIBPAW_ALLOCATE(dijxchat,(cplex_dij*lmn2_size,ndij))
- + + - +
- + - - +
- + - + ]
956 : : call pawdijhat(dijxchat,cplex_dij,1,gprimd,iatom_tot,&
957 : : & natom,ndij,nfft,nfftot,nspden,nsppol,pawang,pawfgrtab(iatom),&
958 [ - + - - : 31 : & pawtab(itypat),vxc,qphon,ucvol,xred,mpi_comm_grid=my_comm_grid)
- - - - -
+ ]
959 [ + + + + ]: 1673 : paw_ij(iatom)%dijxc_hat(1:cplex_dij*lmn2_size,:)=dijxchat(1:cplex_dij*lmn2_size,:)
960 [ - + ]: 31 : LIBPAW_DEALLOCATE(dijxchat)
961 : :
962 : : else ! usexcnhat=0
963 [ # # # # ]: 0 : paw_ij(iatom)%dijxc_hat=zero
964 : : end if
965 : :
966 : : end if
967 : :
968 : : ! ------------------------------------------------------------------------
969 : : ! ----------- Compute Dijxc_val
970 : : ! ------------------------------------------------------------------------
971 : :
972 [ + + ]: 43609 : if (dijxcval_need) then
973 : :
974 [ - + + - : 124 : LIBPAW_ALLOCATE(dijxcval,(cplex_dij*lmn2_size,ndij))
- + + - +
- + - - +
- + - + ]
975 : : ! Note that usexcnhat=0 for this call (no compensation term)
976 [ + - ]: 31 : if (pawxcdev/=0) then
977 [ - + + - : 93 : LIBPAW_ALLOCATE(lmselect,(lm_size))
+ - + - -
+ - + -
+ ]
978 [ + + ]: 454 : lmselect(:)=paw_an(iatom)%lmselect(:)
979 [ - + - - : 31 : if (ipositron/=0) lmselect(:)=(lmselect(:).or.electronpositron_lmselect(1:lm_size,iatom))
- - - - ]
980 : : call pawdijxcm(dijxcval,cplex_dij,1,lmselect,ndij,nspden,nsppol,&
981 : : & pawang,pawrad(itypat),pawtab(itypat),paw_an(iatom)%vxc1_val,&
982 : 31 : & paw_an(iatom)%vxct1_val,0)
983 [ - + ]: 31 : LIBPAW_DEALLOCATE(lmselect)
984 : : else
985 : : call pawdijxc(dijxcval,cplex_dij,1,ndij,nspden,nsppol,&
986 : : & pawang,pawrad(itypat),pawtab(itypat),paw_an(iatom)%vxc1_val,&
987 : 0 : & paw_an(iatom)%vxct1_val,0,0)
988 : : end if
989 [ + + + + ]: 1673 : paw_ij(iatom)%dijxc_val(1:cplex_dij*lmn2_size,:)=dijxcval(1:cplex_dij*lmn2_size,:)
990 [ - + ]: 31 : LIBPAW_DEALLOCATE(dijxcval)
991 : :
992 : : end if
993 : :
994 : : ! ------------------------------------------------------------------------
995 : :
996 : : ! Update some flags
997 [ + - + - ]: 43609 : if (dij_need.and.paw_ij(iatom)%has_dij>=1) paw_ij(iatom)%has_dij=2
998 [ + + - + ]: 43609 : if (dij0_need.and.paw_ij(iatom)%has_dij0>=1) paw_ij(iatom)%has_dij0=2
999 [ - + - - ]: 43609 : if (dijfock_need.and.paw_ij(iatom)%has_dijfock>=1) paw_ij(iatom)%has_dijfock=2
1000 : :
1001 [ - + - - ]: 43609 : if (dijhartree_need.and.paw_ij(iatom)%has_dijhartree>=1) paw_ij(iatom)%has_dijhartree=2
1002 [ + + + + ]: 43609 : if (dijxc_need.and.paw_ij(iatom)%has_dijxc>=1) paw_ij(iatom)%has_dijxc=2
1003 [ + + + + ]: 43609 : if (dijhat_need.and.paw_ij(iatom)%has_dijhat>=1) paw_ij(iatom)%has_dijhat=2
1004 [ - + - - ]: 43609 : if (dijnd_need.and.paw_ij(iatom)%has_dijnd>=1) paw_ij(iatom)%has_dijnd=2
1005 [ - + - - ]: 43609 : if (dijso_need.and.paw_ij(iatom)%has_dijso>=1) paw_ij(iatom)%has_dijso=2
1006 [ + + + + ]: 43609 : if (dijU_need.and.paw_ij(iatom)%has_dijU>=1) paw_ij(iatom)%has_dijU=2
1007 [ - + - - ]: 43609 : if (dijexxc_need.and.paw_ij(iatom)%has_dijexxc>=1) paw_ij(iatom)%has_dijexxc=2
1008 [ + + + - ]: 43609 : if (dijxchat_need.and.paw_ij(iatom)%has_dijxc_hat>=1) paw_ij(iatom)%has_dijxc_hat=2
1009 [ + + + - ]: 63438 : if (dijxcval_need.and.paw_ij(iatom)%has_dijxc_val>=1) paw_ij(iatom)%has_dijxc_val=2
1010 : :
1011 : : !End loop over atoms
1012 : : end do ! iatom
1013 : :
1014 : : !------------------------------------------------------------------------
1015 : :
1016 : : !Final printing
1017 [ + + ]: 19829 : if (paral_atom) then
1018 : : call paw_ij_print(paw_ij,unit=std_out,pawprtvol=pawprtvol,pawspnorb=pawspnorb,&
1019 : : & comm_atom=my_comm_atom,mpi_atmtab=my_atmtab,natom=natom,&
1020 : 6332 : & mode_paral='PERS',enunit=enunit,ipert=ipert)
1021 : : else
1022 : : call paw_ij_print(paw_ij,unit=std_out,pawprtvol=pawprtvol,pawspnorb=pawspnorb,&
1023 : 13497 : & mode_paral='COLL',enunit=enunit,ipert=ipert)
1024 : : end if
1025 : :
1026 : : !Free temporary storage
1027 [ + + ]: 19829 : if (v_dijhat_allocated) then
1028 [ - + ]: 10578 : LIBPAW_POINTER_DEALLOCATE(v_dijhat)
1029 : : end if
1030 [ + + ]: 63438 : do iatom=1,my_natom
1031 [ + + ]: 43609 : if (paw_ij(iatom)%has_dij0==-1) then
1032 [ - + ]: 1997 : LIBPAW_DEALLOCATE(paw_ij(iatom)%dij0)
1033 : 1997 : paw_ij(iatom)%has_dij0=0
1034 : : end if
1035 [ - + ]: 43609 : if (paw_ij(iatom)%has_dijfock==-1) then
1036 [ # # ]: 0 : LIBPAW_DEALLOCATE(paw_ij(iatom)%dijfock)
1037 : 0 : paw_ij(iatom)%has_dijfock=0
1038 : : end if
1039 : :
1040 [ - + ]: 43609 : if (paw_ij(iatom)%has_dijhartree==-1) then
1041 [ # # ]: 0 : LIBPAW_DEALLOCATE(paw_ij(iatom)%dijhartree)
1042 : 0 : paw_ij(iatom)%has_dijhartree=0
1043 : : end if
1044 [ + + ]: 43609 : if (paw_ij(iatom)%has_dijxc==-1) then
1045 [ - + ]: 1993 : LIBPAW_DEALLOCATE(paw_ij(iatom)%dijxc)
1046 : 1993 : paw_ij(iatom)%has_dijxc=0
1047 : : end if
1048 [ + + ]: 43609 : if (paw_ij(iatom)%has_dijhat==-1) then
1049 [ - + ]: 1993 : LIBPAW_DEALLOCATE(paw_ij(iatom)%dijhat)
1050 : 1993 : paw_ij(iatom)%has_dijhat=0
1051 : : end if
1052 [ - + ]: 43609 : if (paw_ij(iatom)%has_dijfr==-1) then
1053 [ # # ]: 0 : LIBPAW_DEALLOCATE(paw_ij(iatom)%dijfr)
1054 : 0 : paw_ij(iatom)%has_dijfr=0
1055 : : end if
1056 [ - + ]: 43609 : if (paw_ij(iatom)%has_dijso==-1) then
1057 [ # # ]: 0 : LIBPAW_DEALLOCATE(paw_ij(iatom)%dijso)
1058 : 0 : paw_ij(iatom)%has_dijso=0
1059 : : end if
1060 [ + + ]: 43609 : if (paw_ij(iatom)%has_dijU==-1) then
1061 [ - + ]: 1314 : LIBPAW_DEALLOCATE(paw_ij(iatom)%dijU)
1062 : 1314 : paw_ij(iatom)%has_dijU=0
1063 : : end if
1064 [ - + ]: 43609 : if (paw_ij(iatom)%has_dijexxc==-1) then
1065 [ # # ]: 0 : LIBPAW_DEALLOCATE(paw_ij(iatom)%dijexxc)
1066 : 0 : paw_ij(iatom)%has_dijexxc=0
1067 : : end if
1068 [ - + ]: 43609 : if (paw_ij(iatom)%has_dijxc_hat==-1) then
1069 [ # # ]: 0 : LIBPAW_DEALLOCATE(paw_ij(iatom)%dijxc_hat)
1070 : 0 : paw_ij(iatom)%has_dijxc_hat=0
1071 : : end if
1072 [ - + ]: 63438 : if (paw_ij(iatom)%has_dijxc_val==-1) then
1073 [ # # ]: 0 : LIBPAW_DEALLOCATE(paw_ij(iatom)%dijxc_val)
1074 : 0 : paw_ij(iatom)%has_dijxc_val=0
1075 : : end if
1076 : : end do
1077 : :
1078 : : !Destroy atom table used for parallelism
1079 : 19829 : call free_my_atmtab(my_atmtab,my_atmtab_allocated)
1080 : :
1081 [ + + - + : 41440 : end subroutine pawdij
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + ]
1082 : : !!***
1083 : :
1084 : : !----------------------------------------------------------------------
1085 : :
1086 : : !!****f* m_pawdij/pawdijhartree
1087 : : !! NAME
1088 : : !! pawdijhartree
1089 : : !!
1090 : : !! FUNCTION
1091 : : !! Compute the Hartree contribution to the PAW pseudopotential strength Dij
1092 : : !! (for one atom only)
1093 : : !!
1094 : : !! INPUTS
1095 : : !! qphase=2 if dij contains a exp(-i.q.r) phase (as in the q<>0 RF case), 1 if not
1096 : : !! nspden=number of spin density components
1097 : : !! pawrhoij <type(pawrhoij_type)>= paw rhoij occupancies (and related data) for current atom
1098 : : !! pawtab <type(pawtab_type)>=paw tabulated starting data, for current atom
1099 : : !!
1100 : : !! OUTPUT
1101 : : !! dijhartree(qphase*lmn2_size)= D_ij^Hartree terms
1102 : : !! When a exp(-i.q.r) phase is included (qphase=2):
1103 : : !! dij(1:lmn2_size,:)
1104 : : !! contains the real part of the phase, i.e. D_ij*cos(q.r)
1105 : : !! dij(lmn2_size+1:2*lmn2_size,:)
1106 : : !! contains the imaginary part of the phase, i.e. D_ij*sin(q.r)
1107 : : !!
1108 : : !! SOURCE
1109 : :
1110 [ - + ]: 54213 : subroutine pawdijhartree(dijhartree,qphase,nspden,pawrhoij,pawtab,&
1111 : : & is_sym)
1112 : :
1113 : : !Arguments ---------------------------------------------
1114 : : !scalars
1115 : : integer,intent(in) :: nspden,qphase
1116 : : logical,intent(in),optional :: is_sym
1117 : : !arrays
1118 : : real(dp),intent(out) :: dijhartree(:)
1119 : : type(pawrhoij_type),intent(in) :: pawrhoij
1120 : : type(pawtab_type),intent(in) :: pawtab
1121 : :
1122 : : !Local variables ---------------------------------------
1123 : : !scalars
1124 : : logical :: eijkl_is_sym
1125 : : integer :: cplex_rhoij,iq,iq0_dij,iq0_rhoij,irhoij,ispden,jrhoij,klmn,klmn1,lmn2_size,nspdiag
1126 : : real(dp) :: ro
1127 : : character(len=500) :: msg
1128 : : !arrays
1129 : :
1130 : : ! *************************************************************************
1131 : :
1132 : : !Check data consistency
1133 [ - + ]: 54213 : if (size(dijhartree,1)/=qphase*pawtab%lmn2_size) then
1134 : 0 : msg='invalid size for DijHartree!'
1135 : 0 : LIBPAW_BUG(msg)
1136 : : end if
1137 [ - + ]: 54213 : if (pawrhoij%qphase<qphase) then
1138 : 0 : msg='pawrhoij%qphase must be >=qphase!'
1139 : 0 : LIBPAW_BUG(msg)
1140 : : end if
1141 : :
1142 : : !Initialization
1143 [ + + ]: 2926326 : dijhartree=zero
1144 : 54213 : lmn2_size=pawrhoij%lmn2_size
1145 : 54213 : cplex_rhoij=pawrhoij%cplex_rhoij
1146 : 54213 : eijkl_is_sym=.true.
1147 [ + + ]: 54213 : if(present(is_sym)) eijkl_is_sym=is_sym
1148 : :
1149 : : !Loop over (diagonal) spin-components
1150 [ + + ]: 54213 : nspdiag=1;if (nspden==2) nspdiag=2
1151 [ + + ]: 115798 : do ispden=1,nspdiag
1152 : :
1153 : : !Loop over phase exp(iqr) phase real/imaginary part
1154 [ + + ]: 178591 : do iq=1,qphase
1155 : : !First loop: we store the real part in dij(1 -> lmn2_size)
1156 : : !2nd loop: we store the imaginary part in dij(lmn2_size+1 -> 2*lmn2_size)
1157 [ + + ]: 62793 : iq0_dij=merge(0,lmn2_size,iq==1)
1158 : 62793 : iq0_rhoij=cplex_rhoij*iq0_dij
1159 : :
1160 : : !Loop over rhoij elements
1161 : 62793 : jrhoij=iq0_rhoij+1
1162 [ + + ]: 2144275 : do irhoij=1,pawrhoij%nrhoijsel
1163 : 2019897 : klmn=pawrhoij%rhoijselect(irhoij)
1164 : :
1165 : 2019897 : ro=pawrhoij%rhoijp(jrhoij,ispden)*pawtab%dltij(klmn)
1166 : : !print *, "debug: irhoij, ro, pawtab%eijkl(klmn,klmn)", irhoij, ro, pawtab%eijkl(klmn,klmn)
1167 : :
1168 : : !Diagonal k=l
1169 : 2019897 : dijhartree(iq0_dij+klmn)=dijhartree(iq0_dij+klmn)+ro*pawtab%eijkl(klmn,klmn)
1170 : :
1171 : : !k<=l
1172 [ + + ]: 113429358 : do klmn1=1,klmn-1
1173 : 113429358 : dijhartree(iq0_dij+klmn1)=dijhartree(iq0_dij+klmn1)+ro*pawtab%eijkl(klmn1,klmn)
1174 : : end do
1175 : :
1176 : : !k>l
1177 [ + + ]: 123001963 : do klmn1=klmn+1,lmn2_size
1178 [ + + ]: 123001963 : if(eijkl_is_sym) then
1179 : 115498954 : dijhartree(iq0_dij+klmn1)=dijhartree(iq0_dij+klmn1)+ro*pawtab%eijkl(klmn,klmn1)
1180 : : else
1181 : 5483112 : dijhartree(iq0_dij+klmn1)=dijhartree(iq0_dij+klmn1)+ro*pawtab%eijkl(klmn1,klmn)
1182 : : endif
1183 : : end do
1184 : :
1185 : 2082690 : jrhoij=jrhoij+cplex_rhoij
1186 : : end do !End loop over rhoij
1187 : :
1188 : : end do !End loop over q phase
1189 : :
1190 : : end do !End loop over spin
1191 : :
1192 : 54213 : end subroutine pawdijhartree
1193 : : !!***
1194 : :
1195 : : !----------------------------------------------------------------------
1196 : :
1197 : : !!****f* m_pawdij/pawdijfock
1198 : : !! NAME
1199 : : !! pawdijfock
1200 : : !!
1201 : : !! FUNCTION
1202 : : !! Compute Fock exact-exchange contribution(s) to the PAW pseudopotential strength Dij
1203 : : !! (for one atom only)
1204 : : !!
1205 : : !! INPUTS
1206 : : !! hyb_mixing=hybrid mixing coefficient for the Fock contribution
1207 : : !! hyb_mixing_sr=hybrid mixing coefficient for the short-range Fock contribution
1208 : : !! qphase=2 if dij contains a exp(-i.q.r) phase (as in the q<>0 RF case), 1 if not
1209 : : !! ndij= number of spin components dor Fdij
1210 : : !! pawrhoij <type(pawrhoij_type)>= paw rhoij occupancies (and related data) for current atom
1211 : : !! pawtab <type(pawtab_type)>=paw tabulated starting data, for current atom
1212 : : !!
1213 : : !! OUTPUT
1214 : : !! dijfock_vv(qphase*lmn2_size,ndij)= D_ij^fock terms for valence-valence interactions
1215 : : !! dijfock_cv(qphase*lmn2_size,ndij)= D_ij^fock terms for core-valence interactions
1216 : : !! When a exp(-i.q.r) phase is included (qphase=2):
1217 : : !! dij(1:lmn2_size,:)
1218 : : !! contains the real part of the phase, i.e. D_ij*cos(q.r)
1219 : : !! dij(lmn2_size+1:2*lmn2_size,:)
1220 : : !! contains the imaginary part of the phase, i.e. D_ij*sin(q.r)
1221 : : !!
1222 : : !! NOTES:
1223 : : !! WARNING: What follows has been tested only for cases where nsppol=1 and 2, nspden=1 and 2 with nspinor=1.
1224 : : !!
1225 : : !! SOURCE
1226 : :
1227 [ - + - + ]: 620 : subroutine pawdijfock(dijfock_vv,dijfock_cv,cplex_dij,qphase,hyb_mixing,hyb_mixing_sr,ndij,pawrhoij,pawtab)
1228 : :
1229 : : !Arguments ---------------------------------------------
1230 : : !scalars
1231 : : integer,intent(in) :: cplex_dij,ndij,qphase
1232 : : real(dp),intent(in) :: hyb_mixing,hyb_mixing_sr
1233 : : !arrays
1234 : : real(dp),intent(out) :: dijfock_vv(:,:),dijfock_cv(:,:)
1235 : : type(pawrhoij_type),intent(in) :: pawrhoij
1236 : : type(pawtab_type),intent(in),target :: pawtab
1237 : :
1238 : : !Local variables ---------------------------------------
1239 : : !scalars
1240 : : integer :: cplex_rhoij,iq,iq0_dij,iq0_rhoij,ispden,irhokl,jrhokl,ilmn_i,jlmn_j,ilmn_k,jlmn_l
1241 : : integer :: klmn_kl,klmn_ij,klmn_il,klmn_kj,klmn1,nsp,lmn2_size
1242 : : real(dp) :: ro,dij_up,dij_dn,dij_updn_r,dij_updn_i
1243 : : character(len=500) :: msg
1244 : : !arrays
1245 : 620 : real(dp),allocatable :: dijfock_vv_tmp(:,:)
1246 : 620 : real(dp),pointer :: eijkl(:,:)
1247 : :
1248 : : ! *************************************************************************
1249 : :
1250 : : !Useful data
1251 : 620 : lmn2_size=pawtab%lmn2_size
1252 : 620 : cplex_rhoij=pawrhoij%cplex_rhoij
1253 : :
1254 : : !Check data consistency
1255 [ - + ]: 620 : if (size(dijfock_vv,1)/=qphase*cplex_dij*lmn2_size.or.size(dijfock_vv,2)/=ndij) then
1256 : 0 : msg='invalid sizes for Dijfock_vv!'
1257 : 0 : LIBPAW_BUG(msg)
1258 : : end if
1259 [ + - - + ]: 620 : if (size(dijfock_cv,1)/=qphase*cplex_dij*lmn2_size.or.size(dijfock_cv,2)/=ndij) then
1260 : 0 : msg='invalid sizes for Dijfock_cv!'
1261 : 0 : LIBPAW_BUG(msg)
1262 : : end if
1263 [ - + ]: 620 : if (pawrhoij%qphase<qphase) then
1264 : 0 : msg='pawrhoij%qphase must be >=qphase!'
1265 : 0 : LIBPAW_BUG(msg)
1266 : : end if
1267 [ - + - - ]: 620 : if (ndij==4.and.cplex_dij==1) then
1268 : 0 : msg='When ndij=4, cplex_dij must be =2!'
1269 : 0 : LIBPAW_BUG(msg)
1270 : : end if
1271 : :
1272 [ + + - + ]: 620 : if (abs(hyb_mixing)>tol8 .and. abs(hyb_mixing_sr)>tol8) then
1273 : 0 : msg='invalid hybrid functional'
1274 : 0 : LIBPAW_BUG(msg)
1275 : : else
1276 [ + + ]: 620 : if (abs(hyb_mixing)>tol8) then
1277 : 466 : eijkl => pawtab%eijkl
1278 [ - + ]: 154 : else if (abs(hyb_mixing_sr)>tol8) then
1279 : 154 : eijkl => pawtab%eijkl_sr
1280 : : end if
1281 : : end if
1282 : :
1283 : : !Init memory
1284 [ + + + + : 46770 : dijfock_vv=zero ; dijfock_cv=zero
+ + + + ]
1285 : :
1286 : : ! ===== Valence-valence contribution =====
1287 : :
1288 [ - + ]: 620 : nsp=pawrhoij%nsppol;if (pawrhoij%nspden==4) nsp=4
1289 [ - + + - : 2480 : LIBPAW_ALLOCATE(dijfock_vv_tmp,(lmn2_size,nsp))
- + + - +
- + - - +
- + ]
1290 [ + + + + ]: 23385 : dijfock_vv_tmp=zero
1291 : :
1292 : : !Loop over phase exp(iqr) phase real/imaginary part
1293 [ + + ]: 1240 : do iq=1,qphase
1294 : : !First loop: we store the real part in dij(1 -> lmn2_size)
1295 : : !2nd loop: we store the imaginary part in dij(lmn2_size+1 -> 2*lmn2_size)
1296 [ - + ]: 620 : iq0_dij=merge(0,lmn2_size,iq==1) ; iq0_rhoij=cplex_rhoij*iq0_dij
1297 : :
1298 : : !Loop over spin components
1299 [ + + ]: 1386 : do ispden=1,nsp
1300 : :
1301 : : !Loop on the non-zero elements rho_kl
1302 : 766 : jrhokl=iq0_rhoij+1
1303 [ + + ]: 10090 : do irhokl=1,pawrhoij%nrhoijsel
1304 : 8704 : klmn_kl=pawrhoij%rhoijselect(irhokl)
1305 : 8704 : ilmn_k=pawtab%indklmn(7,klmn_kl)
1306 : 8704 : jlmn_l=pawtab%indklmn(8,klmn_kl)
1307 : :
1308 : 8704 : ro=pawrhoij%rhoijp(jrhokl,ispden)*pawtab%dltij(klmn_kl)
1309 : :
1310 : : !Contribution to the element (k,l) of dijfock
1311 : 8704 : dijfock_vv_tmp(klmn_kl,ispden)=dijfock_vv_tmp(klmn_kl,ispden)-ro*eijkl(klmn_kl,klmn_kl)
1312 : :
1313 : : !Contribution to the element (i,j) of dijfock with (i,j) < (k,l)
1314 : : ! We remind that i<j and k<l by construction
1315 [ + + ]: 140227 : do klmn_ij=1,klmn_kl-1
1316 : 131523 : ilmn_i=pawtab%indklmn(7,klmn_ij)
1317 : 131523 : jlmn_j=pawtab%indklmn(8,klmn_ij)
1318 : : !In this case, i < l
1319 : 131523 : klmn_il=jlmn_l*(jlmn_l-1)/2+ilmn_i
1320 : : !For (k,j), we compute index of (k,j) or index of (j,k)
1321 [ + + ]: 131523 : if (ilmn_k>jlmn_j) then
1322 : 61788 : klmn_kj=ilmn_k*(ilmn_k-1)/2+jlmn_j
1323 : : else
1324 : 69735 : klmn_kj=jlmn_j*(jlmn_j-1)/2+ilmn_k
1325 : : end if
1326 : 140227 : dijfock_vv_tmp(klmn_ij,ispden)=dijfock_vv_tmp(klmn_ij,ispden)-ro*eijkl(klmn_il,klmn_kj)
1327 : : end do
1328 : :
1329 : : !Contribution to the element (i,j) of dijfock with (i,j) > (k,l)
1330 : : ! We remind that i<j and k<l by construction
1331 [ + + ]: 165090 : do klmn_ij=klmn_kl+1,lmn2_size
1332 : 156386 : ilmn_i=pawtab%indklmn(7,klmn_ij)
1333 : 156386 : jlmn_j=pawtab%indklmn(8,klmn_ij)
1334 : : !In this case, k < j
1335 : 156386 : klmn_kj=jlmn_j*(jlmn_j-1)/2+ilmn_k
1336 : : !For (i,l), we compute index of (i,l) or index of (l,i)
1337 [ + + ]: 156386 : if (ilmn_i>jlmn_l) then
1338 : 68395 : klmn_il=ilmn_i*(ilmn_i-1)/2+jlmn_l
1339 : : else
1340 : 87991 : klmn_il=jlmn_l*(jlmn_l-1)/2+ilmn_i
1341 : : end if
1342 : 165090 : dijfock_vv_tmp(klmn_ij,ispden)=dijfock_vv_tmp(klmn_ij,ispden)-ro*eijkl(klmn_kj,klmn_il)
1343 : : end do
1344 : :
1345 : 9470 : jrhokl=jrhokl+cplex_rhoij
1346 : : end do !End loop over rhoij
1347 : :
1348 : : end do !ispden
1349 : :
1350 : : ! Regular case: copy spin component into Dij
1351 [ - + - - ]: 1240 : if (ndij/=4.or.nsp/=4) then
1352 [ + + ]: 1386 : do ispden=1,nsp
1353 : 766 : klmn1=iq0_dij+1
1354 [ + + ]: 23385 : do klmn_ij=1,lmn2_size
1355 : 21999 : dijfock_vv(klmn1,ispden)=dijfock_vv_tmp(klmn_ij,ispden)
1356 : 22765 : klmn1=klmn1+cplex_dij
1357 : : end do
1358 : : end do
1359 : : ! Antiferro case: copy up component into down one
1360 [ + + - + ]: 620 : if (ndij==2.and.nsp==1) then
1361 : 0 : klmn1=iq0_dij+1
1362 [ # # ]: 0 : do klmn_ij=1,lmn2_size
1363 : 0 : dijfock_vv(klmn1,2)=dijfock_vv_tmp(klmn_ij,1)
1364 : 0 : klmn1=klmn1+cplex_dij
1365 : : end do
1366 : : end if
1367 : : else
1368 : : !Non-collinear: from (rhoij,m_ij) to rhoij^(alpha,beta)
1369 : : !rhoij= (rhoij^11+rhoij^22)
1370 : : !mij_x= (rhoij^12+rhoij^21)
1371 : : !mij_y=i.(rhoij^12+rhoij^21)
1372 : : !mij_z= (rhoij^11-rhoij^22)
1373 : 0 : klmn1=iq0_dij+1
1374 [ # # ]: 0 : do klmn_ij=1,lmn2_size
1375 : 0 : dij_up=half*(dijfock_vv_tmp(klmn_ij,1)+dijfock_vv_tmp(klmn_ij,4))
1376 : 0 : dij_dn=half*(dijfock_vv_tmp(klmn_ij,1)-dijfock_vv_tmp(klmn_ij,4))
1377 : 0 : dij_updn_r= half*dijfock_vv_tmp(klmn_ij,2)
1378 : 0 : dij_updn_i=-half*dijfock_vv_tmp(klmn_ij,3)
1379 : 0 : dijfock_vv(klmn1 ,1)= dij_up
1380 : 0 : dijfock_vv(klmn1 ,2)= dij_dn
1381 : 0 : dijfock_vv(klmn1 ,3)= dij_updn_r
1382 : 0 : dijfock_vv(klmn1+1,3)= dij_updn_i
1383 : 0 : dijfock_vv(klmn1 ,4)= dij_updn_r
1384 : 0 : dijfock_vv(klmn1+1,4)=-dij_updn_i
1385 : 0 : klmn1=klmn1+cplex_dij
1386 : : end do
1387 : : end if
1388 : :
1389 : : end do ! qphase
1390 : :
1391 : : ! ===== Core-valence contribution =====
1392 : :
1393 [ + + ]: 1386 : do ispden=1,pawrhoij%nsppol
1394 [ + + ]: 2152 : do iq=1,qphase
1395 [ - + ]: 766 : iq0_dij=merge(0,cplex_dij*lmn2_size,iq==1)
1396 : 766 : klmn1=iq0_dij+1
1397 [ + + ]: 23531 : do klmn_ij=1,lmn2_size
1398 : 21999 : dijfock_cv(klmn1,ispden)=pawtab%ex_cvij(klmn_ij)
1399 : 22765 : klmn1=klmn1+cplex_dij
1400 : : end do
1401 : : end do
1402 : : end do
1403 : :
1404 : : !Antiferro case: copy up component into down one
1405 [ + + - + ]: 620 : if (ndij==2.and.pawrhoij%nsppol==1) then
1406 [ # # ]: 0 : dijfock_cv(:,2)=dijfock_cv(:,1)
1407 : : end if
1408 : :
1409 : : !Apply mixing factors
1410 [ + + ]: 620 : if (abs(hyb_mixing)>tol8) then
1411 [ + + + + ]: 17173 : dijfock_vv(:,:) = hyb_mixing*dijfock_vv(:,:)
1412 [ + - ]: 154 : else if (abs(hyb_mixing_sr)>tol8) then
1413 [ + + + + ]: 6212 : dijfock_vv(:,:) = hyb_mixing_sr*dijfock_vv(:,:)
1414 : : end if
1415 [ + + + + ]: 23385 : dijfock_cv(:,:) = (hyb_mixing+hyb_mixing_sr)*dijfock_cv(:,:)
1416 : :
1417 : : !Free temporary memory spaces
1418 [ - + ]: 620 : LIBPAW_DEALLOCATE(dijfock_vv_tmp)
1419 : :
1420 [ + - ]: 620 : end subroutine pawdijfock
1421 : : !!***
1422 : :
1423 : : !----------------------------------------------------------------------
1424 : :
1425 : : !!****f* m_pawdij/pawdijxc
1426 : : !! NAME
1427 : : !! pawdijxc
1428 : : !!
1429 : : !! FUNCTION
1430 : : !! Compute the eXchange-Correlation contribution to the PAW pseudopotential strength Dij,
1431 : : !! using densities and potential expressed on a (r,theta,phi) grid
1432 : : !! (for one atom only):
1433 : : !! D_ij^XC= < Phi_i|Vxc( n1+ nc[+nhat])| Phi_j>
1434 : : !! -<tPhi_i|Vxc(tn1+tnc[+nhat])|tPhi_j>
1435 : : !! -Intg_omega [ Vxc(tn1+tnc[+nhat])(r). Sum_L(Qij^L(r)). dr]
1436 : : !!
1437 : : !! INPUTS
1438 : : !! cplex_dij=2 if dij is COMPLEX (as in the spin-orbit case), 1 if dij is REAL
1439 : : !! qphase=2 if dij contains a exp(-i.q.r) phase (as in the q<>0 RF case), 1 if not
1440 : : !! ndij= number of spin components
1441 : : !! nspden=number of spin density components
1442 : : !! nsppol=number of independent spin WF components
1443 : : !! pawang <type(pawang_type)>=paw angular mesh and related data, for current atom
1444 : : !! pawrad <type(pawrad_type)>=paw radial mesh and related data, for current atom
1445 : : !! pawtab <type(pawtab_type)>=paw tabulated starting data
1446 : : !! usekden=1 if kinetic energy density contribution has to be included (mGGA)
1447 : : !! usexcnhat= 1 if compensation density is included in Vxc, 0 otherwise
1448 : : !! vxc1(qphase*mesh_size,angl_size,nspden)=all-electron on-site XC potential for current atom
1449 : : !! given on a (r,theta,phi) grid
1450 : : !! vxct1(qphase*mesh_size,angl_size,nspden)=all-electron on-site XC potential for current atom
1451 : : !! given on a (r,theta,phi) grid
1452 : : !! [vxctau1(qphase*mesh_size,angl_size,nspden)]=1st deriv. of XC energy wrt to kinetic energy density
1453 : : !! (all electron) - metaGGA only
1454 : : !! [vxcttau1(qphase*mesh_size,angl_size,nspden)]=1st deriv. of XC energy wrt to kinetic energy density
1455 : : !! (pseudo) - metaGGA only
1456 : : !!
1457 : : !! OUTPUT
1458 : : !! dijxc(cplex_dij*qphase*lmn2_size,ndij)= D_ij^XC terms
1459 : : !! When Dij is complex (cplex_dij=2):
1460 : : !! dij(2*i-1,:) contains the real part, dij(2*i,:) contains the imaginary part
1461 : : !! When a exp(-i.q.r) phase is included (qphase=2):
1462 : : !! dij(1:cplex_dij*lmn2_size,:)
1463 : : !! contains the real part of the phase, i.e. D_ij*cos(q.r)
1464 : : !! dij(cplex_dij*lmn2_size+1:2*cplex_dij*lmn2_size,:)
1465 : : !! contains the imaginary part of the phase, i.e. D_ij*sin(q.r)
1466 : : !!
1467 : : !! SOURCE
1468 : :
1469 [ - + ]: 2704 : subroutine pawdijxc(dijxc,cplex_dij,qphase,ndij,nspden,nsppol,&
1470 [ - + - + ]: 2704 : & pawang,pawrad,pawtab,vxc1,vxct1,usexcnhat,usekden,&
1471 [ + - + + : 2704 : & vxctau1,vxcttau1) ! optional
- + + - +
+ - + ]
1472 : :
1473 : : !Arguments ---------------------------------------------
1474 : : !scalars
1475 : : integer,intent(in) :: cplex_dij,ndij,nspden,nsppol,qphase,usekden,usexcnhat
1476 : : type(pawang_type),intent(in) :: pawang
1477 : : !arrays
1478 : : real(dp),intent(in) :: vxc1(:,:,:),vxct1(:,:,:)
1479 : : real(dp),intent(in),optional :: vxctau1(:,:,:),vxcttau1(:,:,:)
1480 : : real(dp),intent(out) :: dijxc(:,:)
1481 : : type(pawrad_type),intent(in) :: pawrad
1482 : : type(pawtab_type),intent(in) :: pawtab
1483 : :
1484 : : !Local variables ---------------------------------------
1485 : : !scalars
1486 : : integer :: angl_size,basis_size,idij,idijend
1487 : : integer :: ii,ij_size,ilm,ils,ils1,ilslm,ipts,ir,ir1,isel,ispden
1488 : : integer :: jlm,j0lm,klmn1,klmn2,klmn,klm,kln,l_size,lm0,lmax,lmin,lm_size,lmn2_size
1489 : : integer :: iln,jln,j0ln
1490 : : integer :: mesh_size,mm,nsploop
1491 : : real(dp) :: tmp,vi,vr,vxcijhat,vxcijhat_i,vxctauij
1492 : : character(len=500) :: msg
1493 : : !arrays
1494 : 2704 : real(dp),allocatable :: dijxc_idij(:),ff(:),gg(:)
1495 : 2704 : real(dp),allocatable :: vxcij1(:),vxcij2(:),vxctauij1(:),yylmr(:,:),yylmgr(:,:)
1496 : :
1497 : : ! *************************************************************************
1498 : :
1499 : : !Useful data
1500 : 2704 : lm_size=pawtab%lcut_size**2
1501 : 2704 : lmn2_size=pawtab%lmn2_size
1502 : 2704 : basis_size=pawtab%basis_size
1503 : 2704 : ij_size=pawtab%ij_size
1504 : 2704 : l_size=pawtab%l_size
1505 : 2704 : mesh_size=pawtab%mesh_size
1506 : 2704 : angl_size=pawang%angl_size
1507 : :
1508 : : !Check data consistency
1509 [ + - - + ]: 2704 : if (size(dijxc,1)/=cplex_dij*qphase*lmn2_size.or.size(dijxc,2)/=ndij) then
1510 : 0 : msg='invalid sizes for Dijxc !'
1511 : 0 : LIBPAW_BUG(msg)
1512 : : end if
1513 : : if (size(vxc1,1)/=qphase*mesh_size.or.size(vxct1,1)/=qphase*mesh_size.or.&
1514 : : & size(vxc1,2)/=angl_size.or.size(vxct1,2)/=angl_size.or.&
1515 [ + - + - : 2704 : & size(vxc1,3)/=nspden.or.size(vxct1,3)/=nspden) then
+ - + - +
- - + ]
1516 : 0 : msg='invalid sizes for vxc1 or vxct1 !'
1517 : 0 : LIBPAW_BUG(msg)
1518 : : end if
1519 : :
1520 : : !Check if MetaGGA is activated
1521 [ + + ]: 2704 : if (usekden==1) then
1522 [ - + ]: 428 : if (.not.present(vxctau1)) then
1523 : 0 : msg="vxctau1 needs to be present!"
1524 : 0 : LIBPAW_BUG(msg)
1525 [ + + - + ]: 1712 : else if (size(vxctau1)==0) then
1526 : 0 : msg="vxctau1 needs to be allocated!"
1527 : 0 : LIBPAW_BUG(msg)
1528 : : end if
1529 [ - + ]: 428 : if (.not.present(vxcttau1)) then
1530 : 0 : msg="vxcttau1 needs to be present!"
1531 : 0 : LIBPAW_BUG(msg)
1532 [ + + - + ]: 1712 : else if (size(vxcttau1)==0) then
1533 : 0 : msg="vxcttau1 needs to be allocated!"
1534 : 0 : LIBPAW_BUG(msg)
1535 : : end if
1536 : : end if
1537 : :
1538 : : !Precompute products Ylm*Ylpmp (and Grad(Ylm).Grad(Ylpmp) if mGGA)
1539 [ + + ]: 199471 : lmax=1+maxval(pawtab%indklmn(4,1:lmn2_size))
1540 [ + - - + : 10816 : LIBPAW_ALLOCATE(yylmr,(lmax**2*(lmax**2+1)/2,angl_size))
+ - - + +
- + - + -
- + - + ]
1541 [ - + + - : 10816 : LIBPAW_ALLOCATE(yylmgr,(lmax**2*(lmax**2+1)/2,angl_size*usekden))
+ + + - +
- + + - +
- + ]
1542 [ + + ]: 418744 : do ipts=1,angl_size
1543 [ + + ]: 5579232 : do jlm=1,lmax**2
1544 : 5160488 : j0lm=jlm*(jlm-1)/2
1545 [ + + ]: 52375288 : do ilm=1,jlm
1546 : 46798760 : klm=j0lm+ilm
1547 : 51959248 : yylmr(klm,ipts)=pawang%ylmr(ilm,ipts)*pawang%ylmr(jlm,ipts)
1548 : : end do
1549 : : end do
1550 : : end do
1551 [ + + ]: 2704 : if (usekden==1) then
1552 [ + + + + ]: 17049356 : yylmgr(:,:)=zero
1553 [ + + ]: 67196 : do ipts=1,angl_size
1554 [ + + ]: 1466828 : do jlm=1,lmax**2
1555 : 1399632 : j0lm=jlm*(jlm-1)/2
1556 [ + + ]: 18448560 : do ilm=1,jlm
1557 : 16982160 : klm=j0lm+ilm
1558 [ + + ]: 69328272 : do ii=1,3
1559 : : yylmgr(klm,ipts)=yylmgr(klm,ipts) &
1560 : 67928640 : & +pawang%ylmrgr(ii,ilm,ipts)*pawang%ylmrgr(ii,jlm,ipts)
1561 : : end do
1562 : : end do
1563 : : end do
1564 : : end do
1565 : : end if
1566 : :
1567 : : !Init memory
1568 [ + + + + ]: 547847 : dijxc=zero
1569 [ - + + - : 8112 : LIBPAW_ALLOCATE(dijxc_idij,(qphase*lmn2_size))
+ - + - -
+ - + ]
1570 [ - + + - : 8112 : LIBPAW_ALLOCATE(vxcij1,(qphase*ij_size))
+ - + - -
+ - + ]
1571 [ - + + - : 8112 : LIBPAW_ALLOCATE(vxcij2,(qphase*l_size))
+ - + - -
+ - + ]
1572 [ + + + - : 8112 : LIBPAW_ALLOCATE(vxctauij1,(qphase*ij_size*usekden))
+ - + + -
+ - + ]
1573 [ - + + - : 8112 : LIBPAW_ALLOCATE(ff,(mesh_size))
+ - + - -
+ - + ]
1574 [ - + + - : 5408 : LIBPAW_ALLOCATE(gg,(mesh_size))
- + - + ]
1575 [ + + + + : 63285 : vxcij1=zero;vxcij2=zero;vxctauij1=zero
+ + ]
1576 : :
1577 : : !----------------------------------------------------------
1578 : : !Loop over spin components
1579 : : !----------------------------------------------------------
1580 [ + + ]: 2704 : nsploop=nsppol;if (ndij==4) nsploop=4
1581 [ + + ]: 7631 : do idij=1,nsploop
1582 [ + + + + : 7631 : if (idij<=nsppol.or.(nspden==4.and.idij<=3)) then
+ + ]
1583 : :
1584 : 4486 : idijend=idij+idij/3
1585 [ + + ]: 9071 : do ispden=idij,idijend
1586 : :
1587 [ + + ]: 363505 : dijxc_idij=zero
1588 : :
1589 : : ! ----------------------------------------------------------
1590 : : ! Loop on angular mesh
1591 : : ! ----------------------------------------------------------
1592 [ + + ]: 708725 : do ipts=1,angl_size
1593 : :
1594 : : ! ===== Vxc_ij_1 (tmp) =====
1595 [ + + ]: 10233572 : vxcij1=zero
1596 [ + + ]: 704140 : if (qphase==1) then
1597 [ + + ]: 9471572 : do kln=1,ij_size
1598 : : ff(1:mesh_size)= &
1599 : : & vxc1(1:mesh_size,ipts,ispden)*pawtab%phiphj(1:mesh_size,kln) &
1600 [ + + ]: 10311627512 : & -vxct1(1:mesh_size,ipts,ispden)*pawtab%tphitphj(1:mesh_size,kln)
1601 : 9471572 : call simp_gen(vxcij1(kln),ff,pawrad)
1602 : : end do
1603 : : !if Meta GGA add 1/2*[<nabla_phi_i|vxctau1|nabla_phi_j>
1604 : : ! -<nabla_tphi_i|vxcttau1|nabla_tphi_j>]
1605 [ + + ]: 668860 : if (usekden==1) then
1606 [ + + ]: 433680 : do jln=1,basis_size
1607 : 366912 : j0ln=jln*(jln-1)/2
1608 [ + + ]: 1650480 : do iln=1,jln
1609 : 1216800 : kln=j0ln+iln
1610 : : ff(2:mesh_size)=(vxctau1(2:mesh_size,ipts,ispden)*pawtab%phiphj(2:mesh_size,kln) &
1611 : : & -vxcttau1(2:mesh_size,ipts,ispden)*pawtab%tphitphj(2:mesh_size,kln)) &
1612 [ + + ]: 1759452240 : & /pawrad%rad(2:mesh_size)**2
1613 : 1216800 : call pawrad_deducer0(ff,mesh_size,pawrad)
1614 : 1216800 : call simp_gen(vxctauij1(kln),ff,pawrad)
1615 : : ff(1:mesh_size)=vxctau1(1:mesh_size,ipts,ispden) &
1616 : : & *pawtab%nablaphi(1:mesh_size,iln)*pawtab%nablaphi(1:mesh_size,jln) &
1617 : : & -vxcttau1(1:mesh_size,ipts,ispden) &
1618 [ + + ]: 1760669040 : & *pawtab%tnablaphi(1:mesh_size,iln)*pawtab%tnablaphi(1:mesh_size,jln)
1619 : 1216800 : call simp_gen(vxctauij,ff,pawrad)
1620 : 1583712 : vxcij1(kln)=vxcij1(kln)+half*vxctauij
1621 : : end do
1622 : : end do
1623 : : end if
1624 : :
1625 : : else
1626 [ + + ]: 398640 : do kln=1,ij_size
1627 [ + + ]: 439242240 : do ir=1,mesh_size
1628 : 438878880 : ir1=2*ir
1629 : : ff(ir)= &
1630 : : & vxc1(ir1-1,ipts,ispden)*pawtab%phiphj(ir,kln) &
1631 : 438878880 : & -vxct1(ir1-1,ipts,ispden)*pawtab%tphitphj(ir,kln)
1632 : : gg(ir)= &
1633 : : & vxc1(ir1,ipts,ispden)*pawtab%phiphj(ir,kln) &
1634 : 439242240 : & -vxct1(ir1,ipts,ispden)*pawtab%tphitphj(ir,kln)
1635 : : end do
1636 : 363360 : call simp_gen(vxcij1(2*kln-1),ff,pawrad)
1637 : 398640 : call simp_gen(vxcij1(2*kln ),gg,pawrad)
1638 : : end do
1639 : : !if Meta GGA add 1/2*[<nabla_phi_i|vxctau1|nabla_phi_j>
1640 : : ! -<nabla_tphi_i|vxcttau|nabla_tphi_j>]
1641 [ - + ]: 35280 : if (usekden==1) then
1642 [ # # ]: 0 : do jln=1,basis_size
1643 : 0 : j0ln=jln*(jln-1)/2
1644 [ # # ]: 0 : do iln=1,jln
1645 : 0 : kln=j0ln+iln
1646 [ # # ]: 0 : do ir=2,mesh_size
1647 : 0 : ir1=2*ir
1648 : : ff(ir)=vxctau1(ir1-1,ipts,ispden)*pawtab%phiphj(ir,kln) &
1649 : 0 : & -vxcttau1(ir1-1,ipts,ispden)*pawtab%tphitphj(ir,kln)
1650 : : gg(ir)=vxctau1(ir1,ipts,ispden)*pawtab%phiphj(ir,kln) &
1651 : 0 : & -vxcttau1(ir1,ipts,ispden)*pawtab%tphitphj(ir,kln)
1652 : : end do
1653 : 0 : call pawrad_deducer0(ff,mesh_size,pawrad)
1654 : 0 : call pawrad_deducer0(gg,mesh_size,pawrad)
1655 : 0 : call simp_gen(vxctauij1(2*kln-1),ff,pawrad)
1656 : 0 : call simp_gen(vxctauij1(2*kln ),gg,pawrad)
1657 [ # # ]: 0 : do ir=1,mesh_size
1658 : 0 : ir1=2*ir
1659 : : ff(ir)=vxctau1(ir1-1,ipts,ispden) &
1660 : : & *pawtab%nablaphi(ir,iln)*pawtab%nablaphi(ir,jln) &
1661 : : & -vxcttau1(ir1-1,ipts,ispden) &
1662 : 0 : & *pawtab%tnablaphi(ir,iln)*pawtab%tnablaphi(ir,jln)
1663 : : gg(ir)=vxctau1(ir1,ipts,ispden) &
1664 : : & *pawtab%nablaphi(ir,iln)*pawtab%nablaphi(ir,jln) &
1665 : : & -vxcttau1(ir1,ipts,ispden) &
1666 : 0 : & *pawtab%tnablaphi(ir,iln)*pawtab%tnablaphi(ir,jln)
1667 : : end do
1668 : 0 : call simp_gen(vxctauij,ff,pawrad)
1669 : 0 : vxcij1(2*kln-1)=vxcij1(2*kln-1)+half*vxctauij
1670 : 0 : call simp_gen(vxctauij,gg,pawrad)
1671 : 0 : vxcij1(2*kln)=vxcij1(2*kln)+half*vxctauij
1672 : : end do
1673 : : end do
1674 : : end if
1675 : :
1676 : : end if
1677 : :
1678 : : ! ===== Vxc_ij_2 (tmp) =====
1679 [ + + ]: 3225760 : vxcij2=zero
1680 [ + + ]: 704140 : if (usexcnhat/=0) then
1681 [ + + ]: 51440 : if (qphase==1) then
1682 [ + + ]: 305760 : do ils=1,l_size
1683 : : ff(1:mesh_size)=vxct1(1:mesh_size,ipts,ispden) &
1684 : : & *pawtab%shapefunc(1:mesh_size,ils) &
1685 [ + + ]: 250684720 : & *pawrad%rad(1:mesh_size)**2
1686 : 305760 : call simp_gen(vxcij2(ils),ff,pawrad)
1687 : : end do
1688 : : else
1689 [ + + ]: 2880 : do ils=1,l_size
1690 [ + + ]: 1428000 : do ir=1,mesh_size
1691 : 1425600 : ir1=2*ir
1692 : 1425600 : tmp=pawtab%shapefunc(ir,ils)*pawrad%rad(ir)**2
1693 : 1425600 : ff(ir)=vxct1(ir1-1,ipts,ispden)*tmp
1694 : 1428000 : gg(ir)=vxct1(ir1 ,ipts,ispden)*tmp
1695 : : end do
1696 : 2400 : call simp_gen(vxcij2(2*ils-1),ff,pawrad)
1697 : 2880 : call simp_gen(vxcij2(2*ils ),gg,pawrad)
1698 : : end do
1699 : : end if
1700 : : end if
1701 : :
1702 : : ! ===== Integrate Vxc_ij_1 and Vxc_ij_2 over the angular mesh =====
1703 : : ! ===== and accumulate in total Vxc_ij =====
1704 [ + + ]: 708725 : if (qphase==1) then
1705 [ + + ]: 51513676 : do klmn=1,lmn2_size
1706 : 50844816 : klm=pawtab%indklmn(1,klmn);kln=pawtab%indklmn(2,klmn)
1707 : 50844816 : lmin=pawtab%indklmn(3,klmn);lmax=pawtab%indklmn(4,klmn)
1708 : : dijxc_idij(klmn)=dijxc_idij(klmn)+vxcij1(kln) &
1709 : 50844816 : & *pawang%angwgth(ipts)*yylmr(klm,ipts)*four_pi
1710 [ + + ]: 50844816 : if (usekden==1) then
1711 : : dijxc_idij(klmn)=dijxc_idij(klmn)+half*vxctauij1(kln) &
1712 : 9142848 : & *pawang%angwgth(ipts)*yylmgr(klm,ipts)*four_pi
1713 : : end if
1714 [ + + ]: 51513676 : if (usexcnhat/=0) then
1715 : 8714160 : vxcijhat=zero
1716 [ + - + + ]: 27161680 : do ils=lmin,lmax,2
1717 : 18447520 : lm0=ils**2+ils+1
1718 : 18447520 : vr=four_pi*pawang%angwgth(ipts)*vxcij2(ils+1)
1719 [ + + ]: 113284080 : do mm=-ils,ils
1720 : 86122400 : ilslm=lm0+mm;isel=pawang%gntselect(ilslm,klm)
1721 [ + + ]: 104569920 : if (isel>0) then
1722 : 18039840 : tmp=pawang%ylmr(ilslm,ipts)*pawtab%qijl(ilslm,klmn)
1723 : 18039840 : vxcijhat=vxcijhat+vr*tmp
1724 : : end if
1725 : : end do
1726 : : end do
1727 : 8714160 : dijxc_idij(klmn)=dijxc_idij(klmn)-vxcijhat
1728 : : end if
1729 : : end do ! Loop klmn
1730 : : else
1731 : : klmn1=1
1732 [ + + ]: 1434960 : do klmn=1,lmn2_size
1733 : 1399680 : klm=pawtab%indklmn(1,klmn);kln=pawtab%indklmn(2,klmn)
1734 : 1399680 : lmin=pawtab%indklmn(3,klmn);lmax=pawtab%indklmn(4,klmn)
1735 : 1399680 : tmp=pawang%angwgth(ipts)*yylmr(klm,ipts)*four_pi
1736 : 1399680 : dijxc_idij(klmn1 )=dijxc_idij(klmn1 )+vxcij1(2*kln-1)*tmp
1737 : 1399680 : dijxc_idij(klmn1+1)=dijxc_idij(klmn1+1)+vxcij1(2*kln )*tmp
1738 [ - + ]: 1399680 : if (usekden==1) then
1739 : 0 : tmp=pawang%angwgth(ipts)*yylmgr(klm,ipts)*four_pi
1740 : 0 : dijxc_idij(klmn1 )=dijxc_idij(klmn1 )+half*vxctauij1(2*kln-1)*tmp
1741 : 0 : dijxc_idij(klmn1+1)=dijxc_idij(klmn1+1)+half*vxctauij1(2*kln )*tmp
1742 : : end if
1743 [ + + ]: 1399680 : if (usexcnhat/=0) then
1744 : 82080 : vxcijhat=zero;vxcijhat_i=zero
1745 [ + - + + ]: 255840 : do ils=lmin,lmax,2
1746 : 173760 : lm0=ils**2+ils+1;ils1=2*(ils+1)
1747 : 173760 : vr=four_pi*pawang%angwgth(ipts)*vxcij2(ils1-1)
1748 : 173760 : vi=four_pi*pawang%angwgth(ipts)*vxcij2(ils1 )
1749 [ + + ]: 1067040 : do mm=-ils,ils
1750 : 811200 : ilslm=lm0+mm;isel=pawang%gntselect(ilslm,klm)
1751 [ + + ]: 984960 : if (isel>0) then
1752 : 169920 : tmp=pawang%ylmr(ilslm,ipts)*pawtab%qijl(ilslm,klmn)
1753 : 169920 : vxcijhat =vxcijhat +vr*tmp
1754 : 169920 : vxcijhat_i=vxcijhat_i+vi*tmp
1755 : : end if
1756 : : end do
1757 : : end do
1758 : 82080 : dijxc_idij(klmn1 )=dijxc_idij(klmn1 )-vxcijhat
1759 : 82080 : dijxc_idij(klmn1+1)=dijxc_idij(klmn1+1)-vxcijhat_i
1760 : : end if
1761 : 1434960 : klmn1=klmn1+qphase
1762 : : end do ! Loop klmn
1763 : : end if
1764 : :
1765 : : ! ----------------------------------------------------------
1766 : : ! End loop on angular points
1767 : : end do
1768 : :
1769 : : ! ----------------------------------------------------------
1770 : : ! Deduce some part of Dij according to symmetries
1771 : : ! ----------------------------------------------------------
1772 : :
1773 : : !if ispden=1 => real part of D^11_ij
1774 : : !if ispden=2 => real part of D^22_ij
1775 : : !if ispden=3 => real part of D^12_ij
1776 : : !if ispden=4 => imaginary part of D^12_ij
1777 : 4585 : klmn1=max(1,ispden-2);klmn2=1
1778 [ + + ]: 351481 : do klmn=1,lmn2_size
1779 : 346896 : dijxc(klmn1,idij)=dijxc_idij(klmn2)
1780 : 346896 : klmn1=klmn1+cplex_dij
1781 : 351481 : klmn2=klmn2+qphase
1782 : : end do
1783 [ + + ]: 9071 : if (qphase==2) then
1784 : : !Same storage with exp^(-i.q.r) phase
1785 : 244 : klmn1=max(1,ispden-2)+lmn2_size*cplex_dij;klmn2=2
1786 [ + + ]: 12268 : do klmn=1,lmn2_size
1787 : 12024 : dijxc(klmn1,idij)=dijxc_idij(klmn2)
1788 : 12024 : klmn1=klmn1+cplex_dij
1789 : 12268 : klmn2=klmn2+qphase
1790 : : end do
1791 : : endif
1792 : :
1793 : : end do !ispden
1794 : :
1795 : : !Non-collinear: D_ij(:,4)=D^21_ij=D^12_ij^*
1796 [ + + + - ]: 441 : else if (nspden==4.and.idij==4) then
1797 [ + + ]: 33957 : dijxc(:,idij)=dijxc(:,idij-1)
1798 [ + - ]: 99 : if (cplex_dij==2) then
1799 [ + - ]: 99 : do klmn=2,lmn2_size*cplex_dij,cplex_dij
1800 [ + + ]: 16929 : dijxc(klmn,idij)=-dijxc(klmn,idij)
1801 : : end do
1802 [ - + ]: 99 : if (qphase==2) then
1803 [ # # ]: 0 : do klmn=2+lmn2_size*cplex_dij,2*lmn2_size*cplex_dij,cplex_dij
1804 [ # # ]: 0 : dijxc(klmn,idij)=-dijxc(klmn,idij)
1805 : : end do
1806 : : end if
1807 : : end if
1808 : :
1809 : : !Antiferro: D_ij(:,2)=D^down_ij=D^up_ij
1810 [ + - + + ]: 342 : else if (nsppol==1.and.idij==2) then
1811 [ + + ]: 32082 : dijxc(:,idij)=dijxc(:,idij-1)
1812 : : end if
1813 : :
1814 : : !----------------------------------------------------------
1815 : : !End loop on spin density components
1816 : : end do
1817 : :
1818 : : !Free temporary memory spaces
1819 [ - + ]: 2704 : LIBPAW_DEALLOCATE(yylmr)
1820 [ - + ]: 2704 : LIBPAW_DEALLOCATE(yylmgr)
1821 [ - + ]: 2704 : LIBPAW_DEALLOCATE(dijxc_idij)
1822 [ - + ]: 2704 : LIBPAW_DEALLOCATE(vxcij1)
1823 [ - + ]: 2704 : LIBPAW_DEALLOCATE(vxcij2)
1824 [ - + ]: 2704 : LIBPAW_DEALLOCATE(vxctauij1)
1825 [ - + ]: 2704 : LIBPAW_DEALLOCATE(ff)
1826 [ - + ]: 2704 : LIBPAW_DEALLOCATE(gg)
1827 : :
1828 : 2704 : end subroutine pawdijxc
1829 : : !!***
1830 : :
1831 : : !----------------------------------------------------------------------
1832 : :
1833 : : !!****f* m_pawdij/pawdijxcm
1834 : : !! NAME
1835 : : !! pawdijxcm
1836 : : !!
1837 : : !! FUNCTION
1838 : : !! Compute the eXchange-Correlation contribution to the PAW pseudopotential strength Dij,
1839 : : !! using densities and potential expressed as (l,m) spherical moments
1840 : : !! (for one atom only):
1841 : : !! D_ij^XC= < Phi_i|Vxc( n1+ nc[+nhat])| Phi_j>
1842 : : !! -<tPhi_i|Vxc(tn1+tnc[+nhat])|tPhi_j>
1843 : : !! -Intg_omega [ Vxc(tn1+tnc[+nhat])(r). Sum_L(Qij^L(r)). dr]
1844 : : !!
1845 : : !! INPUTS
1846 : : !! cplex_dij=2 if dij is COMPLEX (as in the spin-orbit case), 1 if dij is REAL
1847 : : !! qphase=2 if dij contains a exp(-i.q.r) phase (as in the q<>0 RF case), 1 if not
1848 : : !! lmselect(lm_size)=select the non-zero LM-moments of on-site potentials
1849 : : !! ndij= number of spin components
1850 : : !! nspden=number of spin density components
1851 : : !! nsppol=number of independent spin WF components
1852 : : !! pawang <type(pawang_type)>=paw angular mesh and related data, for current atom
1853 : : !! pawrad <type(pawrad_type)>=paw radial mesh and related data, for current atom
1854 : : !! pawtab <type(pawtab_type)>=paw tabulated starting data
1855 : : !! vxc1(qphase*mesh_size,lm_size,nspden)=all-electron on-site XC potential for current atom
1856 : : !! given on (l,m) spherical moments
1857 : : !! vxct1(qphase*mesh_size,lm_size,nspden)=all-electron on-site XC potential for current atom
1858 : : !! given on (l,m) spherical moments
1859 : : !! usexcnhat= 1 if compensation density is included in Vxc, 0 otherwise
1860 : : !!
1861 : : !! OUTPUT
1862 : : !! dijxc(cplex_dij*qphase*lmn2_size,ndij)= D_ij^XC terms
1863 : : !! When Dij is complex (cplex_dij=2):
1864 : : !! dij(2*i-1,:) contains the real part, dij(2*i,:) contains the imaginary part
1865 : : !! When a exp(-i.q.r) phase is included (qphase=2):
1866 : : !! dij(1:cplex_dij*lmn2_size,:)
1867 : : !! contains the real part of the phase, i.e. D_ij*cos(q.r)
1868 : : !! dij(cplex_dij*lmn2_size+1:2*cplex_dij*lmn2_size,:)
1869 : : !! contains the imaginary part of the phase, i.e. D_ij*sin(q.r)
1870 : : !!
1871 : : !! SOURCE
1872 : :
1873 [ - + - + ]: 40936 : subroutine pawdijxcm(dijxc,cplex_dij,qphase,lmselect,ndij,nspden,nsppol,&
1874 [ - + - + ]: 40936 : & pawang,pawrad,pawtab,vxc1,vxct1,usexcnhat)
1875 : :
1876 : : !Arguments ---------------------------------------------
1877 : : !scalars
1878 : : integer,intent(in) :: cplex_dij,ndij,nspden,nsppol,qphase,usexcnhat
1879 : : type(pawang_type),intent(in) :: pawang
1880 : : !arrays
1881 : : logical :: lmselect(:)
1882 : : real(dp),intent(in) :: vxc1(:,:,:),vxct1(:,:,:)
1883 : : real(dp),intent(out) :: dijxc(:,:)
1884 : : type(pawrad_type),intent(in) :: pawrad
1885 : : type(pawtab_type),intent(in) :: pawtab
1886 : :
1887 : : !Local variables ---------------------------------------
1888 : : !scalars
1889 : : integer :: idij,idijend,ij_size,ir,ir1,isel,ispden,klm,klm1,klmn,klmn1,klmn2,kln
1890 : : integer :: lm_size,lmn2_size,ll,mesh_size,nsploop
1891 : : real(dp) :: tmp,vxcij2,vxcij2_i
1892 : : character(len=500) :: msg
1893 : : !arrays
1894 : 40936 : real(dp),allocatable :: dijxc_idij(:),ff(:),gg(:),vxcij1(:)
1895 : :
1896 : : ! *************************************************************************
1897 : :
1898 : : !Useful data
1899 : 40936 : lm_size=pawtab%lcut_size**2
1900 : 40936 : lmn2_size=pawtab%lmn2_size
1901 : 40936 : ij_size=pawtab%ij_size
1902 : 40936 : mesh_size=pawtab%mesh_size
1903 : :
1904 : : !Check data consistency
1905 [ + - - + ]: 40936 : if (size(dijxc,1)/=cplex_dij*qphase*lmn2_size.or.size(dijxc,2)/=ndij) then
1906 : 0 : msg='invalid sizes for Dijxc !'
1907 : 0 : LIBPAW_BUG(msg)
1908 : : end if
1909 [ - + ]: 40936 : if (size(lmselect)/=lm_size) then
1910 : 0 : msg='invalid size for lmselect !'
1911 : 0 : LIBPAW_BUG(msg)
1912 : : end if
1913 : : if (size(vxc1,1)/=qphase*mesh_size.or.size(vxct1,1)/=qphase*mesh_size.or.&
1914 : : & size(vxc1,2)/=lm_size.or.size(vxct1,2)/=lm_size.or.&
1915 [ + - + - : 40936 : & size(vxc1,3)/=nspden.or.size(vxct1,3)/=nspden) then
+ - + - +
- - + ]
1916 : 0 : msg='invalid sizes for vxc1 or vxct1 !'
1917 : 0 : LIBPAW_BUG(msg)
1918 : : end if
1919 : :
1920 : : !Init memory
1921 [ + + + + ]: 4967354 : dijxc=zero
1922 [ - + + - : 122808 : LIBPAW_ALLOCATE(dijxc_idij,(qphase*lmn2_size))
+ - + - -
+ - + ]
1923 [ - + + - : 122808 : LIBPAW_ALLOCATE(vxcij1,(qphase*ij_size))
+ - + - -
+ - + ]
1924 [ - + + - : 122808 : LIBPAW_ALLOCATE(ff,(mesh_size))
+ - + - -
+ - + ]
1925 [ - + + - : 81872 : LIBPAW_ALLOCATE(gg,(mesh_size))
- + - + ]
1926 : :
1927 : : !----------------------------------------------------------
1928 : : !Loop over spin components
1929 : : !----------------------------------------------------------
1930 [ + + ]: 40936 : nsploop=nsppol;if (ndij==4) nsploop=4
1931 [ + + ]: 93717 : do idij=1,nsploop
1932 [ + + + + : 93717 : if (idij<=nsppol.or.(nspden==4.and.idij<=3)) then
+ + ]
1933 : :
1934 : 47424 : idijend=idij+idij/3
1935 [ + + ]: 96173 : do ispden=idij,idijend
1936 : :
1937 [ + + ]: 3364696 : dijxc_idij=zero
1938 : :
1939 : : ! ----------------------------------------------------------
1940 : : ! Summing over (l,m) moments
1941 : : ! ----------------------------------------------------------
1942 [ + + ]: 648412 : do klm=1,lm_size
1943 [ + + ]: 648412 : if (lmselect(klm)) then
1944 : :
1945 : : ! ===== Vxc_ij_1 (tmp) =====
1946 [ + + ]: 7439483 : vxcij1=zero
1947 [ + + ]: 439258 : if (qphase==1) then
1948 [ + + ]: 7383119 : do kln=1,ij_size
1949 : : ff(1:mesh_size)= &
1950 : : & vxc1(1:mesh_size,klm,ispden)*pawtab%phiphj(1:mesh_size,kln) &
1951 [ + + ]: 6364388306 : & -vxct1(1:mesh_size,klm,ispden)*pawtab%tphitphj(1:mesh_size,kln)
1952 : 7383119 : call simp_gen(vxcij1(kln),ff,pawrad)
1953 : : end do
1954 : : else ! qphase==2
1955 [ + + ]: 29524 : do kln=1,ij_size
1956 [ + + ]: 13017400 : do ir=1,mesh_size
1957 : 12990560 : ir1=2*ir
1958 : : ff(ir)= &
1959 : : & vxc1(ir1-1,klm,ispden)*pawtab%phiphj(ir,kln) &
1960 : 12990560 : & -vxct1(ir1-1,klm,ispden)*pawtab%tphitphj(ir,kln)
1961 : : gg(ir)= &
1962 : : & vxc1(ir1,klm,ispden)*pawtab%phiphj(ir,kln) &
1963 : 13017400 : & -vxct1(ir1,klm,ispden)*pawtab%tphitphj(ir,kln)
1964 : : end do
1965 : 26840 : call simp_gen(vxcij1(2*kln-1),ff,pawrad)
1966 : 29524 : call simp_gen(vxcij1(2*kln ),gg,pawrad)
1967 : : end do
1968 : : end if
1969 : :
1970 : : ! ===== Vxc_ij_2 (tmp) =====
1971 : 439258 : vxcij2=zero;vxcij2_i=zero
1972 [ + + ]: 439258 : if (usexcnhat/=0) then
1973 : 225281 : ll=1+int(sqrt(dble(klm)-0.1_dp))
1974 [ + + ]: 225281 : if (qphase==1) then
1975 : : ff(1:mesh_size)=vxct1(1:mesh_size,klm,ispden) &
1976 : : & *pawtab%shapefunc(1:mesh_size,ll) &
1977 [ + + ]: 147750389 : & *pawrad%rad(1:mesh_size)**2
1978 : 222597 : call simp_gen(vxcij2,ff,pawrad)
1979 : : else ! qphase==2
1980 [ + + ]: 1301740 : do ir=1,mesh_size
1981 : 1299056 : ir1=2*ir
1982 : 1299056 : tmp=pawtab%shapefunc(ir,ll)*pawrad%rad(ir)**2
1983 : 1299056 : ff(ir)=vxct1(ir1-1,klm,ispden)*tmp
1984 : 1301740 : gg(ir)=vxct1(ir1 ,klm,ispden)*tmp
1985 : : end do
1986 : 2684 : call simp_gen(vxcij2 ,ff,pawrad)
1987 : 2684 : call simp_gen(vxcij2_i,gg,pawrad)
1988 : : end if
1989 : : end if
1990 : :
1991 : : ! ===== Accumulate over klm moments Vxc_ij_1 and Vxc_ij_2 =====
1992 : : ! ===== into total Vxc_ij =====
1993 [ + + ]: 439258 : if (qphase==1) then
1994 [ + + ]: 49791577 : do klmn=1,lmn2_size
1995 : 49355003 : klm1=pawtab%indklmn(1,klmn)
1996 : 49355003 : kln=pawtab%indklmn(2,klmn)
1997 : 49355003 : isel=pawang%gntselect(klm,klm1)
1998 [ + + ]: 49355003 : if (isel>0) &
1999 : 4593662 : & dijxc_idij(klmn)=dijxc_idij(klmn)+vxcij1(kln)*pawang%realgnt(isel)
2000 [ + + ]: 49355003 : if (usexcnhat/=0) &
2001 : 30339957 : dijxc_idij(klmn)=dijxc_idij(klmn)-pawtab%qijl(klm,klmn)*vxcij2
2002 : : end do ! Loop klmn
2003 : : else ! qphase==2
2004 : : klmn1=1
2005 [ + + ]: 99308 : do klmn=1,lmn2_size
2006 : 96624 : klm1=pawtab%indklmn(1,klmn)
2007 : 96624 : kln=pawtab%indklmn(2,klmn)
2008 : 96624 : isel=pawang%gntselect(klm,klm1)
2009 [ + + ]: 96624 : if (isel>0) then
2010 : : dijxc_idij(klmn1 )=dijxc_idij(klmn1) &
2011 : 15450 : & +vxcij1(2*kln-1)*pawang%realgnt(isel)
2012 : : dijxc_idij(klmn1+1)=dijxc_idij(klmn1+1) &
2013 : 15450 : & +vxcij1(2*kln )*pawang%realgnt(isel)
2014 : : end if
2015 [ + - ]: 96624 : if (usexcnhat/=0) then
2016 : : dijxc_idij(klmn1 )=dijxc_idij(klmn1) &
2017 : 96624 : & -pawtab%qijl(klm,klmn)*vxcij2
2018 : : dijxc_idij(klmn1+1)=dijxc_idij(klmn1+1) &
2019 : 96624 : & -pawtab%qijl(klm,klmn)*vxcij2_i
2020 : : end if
2021 : 99308 : klmn1=klmn1+qphase
2022 : : end do ! Loop klmn
2023 : : end if
2024 : :
2025 : : end if ! klm selection
2026 : : end do ! Loop klm
2027 : :
2028 : : ! ----------------------------------------------------------
2029 : : ! Deduce some part of Dij according to symmetries
2030 : : ! ----------------------------------------------------------
2031 : :
2032 : : !if ispden=1 => real part of D^11_ij
2033 : : !if ispden=2 => real part of D^22_ij
2034 : : !if ispden=3 => real part of D^12_ij
2035 : : !if ispden=4 => imaginary part of D^12_ij
2036 : 48749 : klmn1=max(1,ispden-2);klmn2=1
2037 [ + + ]: 3352744 : do klmn=1,lmn2_size
2038 : 3303995 : dijxc(klmn1,idij)=dijxc_idij(klmn2)
2039 : 3303995 : klmn1=klmn1+cplex_dij
2040 : 3352744 : klmn2=klmn2+qphase
2041 : : end do
2042 [ + + ]: 96173 : if (qphase==2) then
2043 : : !Same storage with exp^(-i.q.r) phase
2044 : 332 : klmn1=max(1,ispden-2)+lmn2_size*cplex_dij;klmn2=2
2045 [ + + ]: 12284 : do klmn=1,lmn2_size
2046 : 11952 : dijxc(klmn1,idij)=dijxc_idij(klmn2)
2047 : 11952 : klmn1=klmn1+cplex_dij
2048 : 12284 : klmn2=klmn2+qphase
2049 : : end do
2050 : : endif
2051 : :
2052 : : end do !ispden
2053 : :
2054 : : !Non-collinear: D_ij(:,4)=D^21_ij=D^12_ij^*
2055 [ + + + - ]: 5357 : else if (nspden==4.and.idij==4) then
2056 [ + + ]: 459821 : dijxc(:,idij)=dijxc(:,idij-1)
2057 [ + - ]: 1325 : if (cplex_dij==2) then
2058 [ - + ]: 1325 : do klmn=2,lmn2_size*cplex_dij,cplex_dij
2059 [ + + ]: 229248 : dijxc(klmn,idij)=-dijxc(klmn,idij)
2060 : : end do
2061 [ - + ]: 1325 : if (qphase==2) then
2062 [ # # ]: 0 : do klmn=2+lmn2_size*cplex_dij,2*lmn2_size*cplex_dij,cplex_dij
2063 [ # # ]: 0 : dijxc(klmn,idij)=-dijxc(klmn,idij)
2064 : : end do
2065 : : end if
2066 : : end if
2067 : :
2068 : : !Antiferro: D_ij(:,2)=D^down_ij=D^up_ij
2069 [ + - + + ]: 4032 : else if (nsppol==1.and.idij==2) then
2070 [ + + ]: 157720 : dijxc(:,idij)=dijxc(:,idij-1)
2071 : : end if
2072 : :
2073 : : !----------------------------------------------------------
2074 : : !End loop on spin density components
2075 : : end do
2076 : :
2077 : : !Free temporary memory spaces
2078 [ - + ]: 40936 : LIBPAW_DEALLOCATE(dijxc_idij)
2079 [ - + ]: 40936 : LIBPAW_DEALLOCATE(vxcij1)
2080 [ - + ]: 40936 : LIBPAW_DEALLOCATE(ff)
2081 [ - + ]: 40936 : LIBPAW_DEALLOCATE(gg)
2082 : :
2083 : 40936 : end subroutine pawdijxcm
2084 : : !!***
2085 : :
2086 : : !----------------------------------------------------------------------
2087 : :
2088 : : !!****f* m_pawdij/pawdijhat
2089 : : !! NAME
2090 : : !! pawdijhat
2091 : : !!
2092 : : !! FUNCTION
2093 : : !! Compute the "hat" contribution to the PAW pseudopotential strength Dij,
2094 : : !! i.e. the compensation charge contribution (for one atom only):
2095 : : !! D_ij^hat=Intg_R [ V(r). Sum_L(Qij^L(r)). dr]
2096 : : !!
2097 : : !! INPUTS
2098 : : !! cplex_dij=2 if dij is COMPLEX (as in the spin-orbit case), 1 if dij is REAL
2099 : : !! qphase=2 if dij contains a exp(-i.q.r) phase (as in the q<>0 RF case), 1 if not
2100 : : !! gprimd(3,3)=dimensional primitive translations for reciprocal space
2101 : : !! iatom=absolute index of current atom (between 1 and natom)
2102 : : !! natom=total number of atoms
2103 : : !! ndij= number of spin components
2104 : : !! ngrid=number of points of the real space grid (FFT, WVL, ...) treated by current proc
2105 : : !! ngridtot=total number of points of the real space grid (FFT, WVL, ...)
2106 : : !! For the FFT grid, this should be equal to ngfft1*ngfft2*ngfft3
2107 : : !! nspden=number of spin density components
2108 : : !! nsppol=number of independent spin WF components
2109 : : !! pawang <type(pawang_type)>=paw angular mesh and related data
2110 : : !! pawfgrtab<type(pawfgrtab_type)>=atomic data given on fine rectangular grid for current atom
2111 : : !! pawtab(ntypat) <type(pawtab_type)>=paw tabulated starting data, for current atom
2112 : : !! Pot(qphase*ngrid,nspden)=potential on real space grid
2113 : : !! qphon(3)=(RF calculations only) - wavevector of the phonon
2114 : : !! ucvol=unit cell volume
2115 : : !! xred(3,my_natom)= reduced atomic coordinates
2116 : : !!
2117 : : !! OUTPUT
2118 : : !! dijhat(cplex_dij*qphase*lmn2_size,ndij)= D_ij^hat terms
2119 : : !! When Dij is complex (cplex_dij=2):
2120 : : !! dij(2*i-1,:) contains the real part, dij(2*i,:) contains the imaginary part
2121 : : !! When a exp(-i.q.r) phase is included (qphase=2):
2122 : : !! dij(1:cplex_dij*lmn2_size,:)
2123 : : !! contains the real part of the phase, i.e. D_ij*cos(q.r)
2124 : : !! dij(cplex_dij*lmn2_size+1:2*cplex_dij*lmn2_size,:)
2125 : : !! contains the imaginary part of the phase, i.e. D_ij*sin(q.r)
2126 : : !!
2127 : : !! SOURCE
2128 : :
2129 [ - + ]: 43640 : subroutine pawdijhat(dijhat,cplex_dij,qphase,gprimd,iatom,&
2130 : : & natom,ndij,ngrid,ngridtot,nspden,nsppol,pawang,pawfgrtab,&
2131 : 43640 : & pawtab,Pot,qphon,ucvol,xred,&
2132 : : & mpi_comm_grid) ! Optional argument
2133 : :
2134 : : !Arguments ---------------------------------------------
2135 : : !scalars
2136 : : integer,intent(in) :: cplex_dij,iatom,natom,ndij
2137 : : integer,intent(in) :: ngrid,ngridtot,nspden,nsppol,qphase
2138 : : integer,intent(in),optional :: mpi_comm_grid
2139 : : real(dp),intent(in) :: ucvol
2140 : : type(pawang_type),intent(in) :: pawang
2141 : : type(pawfgrtab_type),intent(inout) :: pawfgrtab
2142 : : !arrays
2143 : : real(dp),intent(in) :: gprimd(3,3),Pot(qphase*ngrid,nspden),qphon(3),xred(3,natom)
2144 : : real(dp),intent(out) :: dijhat(:,:)
2145 : : type(pawtab_type),intent(in) :: pawtab
2146 : :
2147 : : !Local variables ---------------------------------------
2148 : : !scalars
2149 : : integer :: ic,idij,idijend,ier,ils,ilslm,ilslm1,isel,ispden,jc,klm,klmn,klmn1,klmn2
2150 : : integer :: lm0,lm_size,lmax,lmin,lmn2_size,mm,my_comm_grid,nfgd,nsploop,optgr0
2151 : : logical :: has_qphase,qne0
2152 : : real(dp) :: vi,vr
2153 : : character(len=500) :: msg
2154 : : !arrays
2155 : : real(dp) :: rdum1(1),rdum2(2)
2156 : 43640 : real(dp),allocatable :: dijhat_idij(:),prod(:)
2157 : :
2158 : : ! *************************************************************************
2159 : :
2160 : : !Useful data
2161 : 43640 : lm_size=pawtab%lcut_size**2
2162 : 43640 : lmn2_size=pawtab%lmn2_size
2163 : 43640 : nfgd=pawfgrtab%nfgd
2164 : 43640 : qne0=(qphon(1)**2+qphon(2)**2+qphon(3)**2>=1.d-15)
2165 [ + + - + ]: 43640 : has_qphase=(qne0.and.qphase==2)
2166 [ + - ]: 43640 : my_comm_grid=xmpi_comm_self;if (present(mpi_comm_grid)) my_comm_grid=mpi_comm_grid
2167 : :
2168 : : !Check data consistency
2169 [ + - - + ]: 43640 : if (size(dijhat,1)/=cplex_dij*qphase*lmn2_size.or.size(dijhat,2)/=ndij) then
2170 : 0 : msg='invalid sizes for Dijhat !'
2171 : 0 : LIBPAW_BUG(msg)
2172 : : end if
2173 : :
2174 : : !Eventually compute g_l(r).Y_lm(r) factors for the current atom (if not already done)
2175 [ + + ]: 43640 : if (pawfgrtab%gylm_allocated==0) then
2176 [ + - ]: 9 : if (allocated(pawfgrtab%gylm)) then
2177 : 9 : LIBPAW_DEALLOCATE(pawfgrtab%gylm)
2178 : : end if
2179 [ - + + - : 36 : LIBPAW_ALLOCATE(pawfgrtab%gylm,(nfgd,lm_size))
- + + - +
- + - - +
- + - + ]
2180 : 9 : pawfgrtab%gylm_allocated=2;optgr0=1
2181 : 9 : call pawgylm(pawfgrtab%gylm,rdum1,rdum2,lm_size,nfgd,optgr0,0,0,pawtab,pawfgrtab%rfgd)
2182 : : end if
2183 : :
2184 : : !Eventually compute exp(i.q.r) factors for the current atom (if not already done)
2185 [ + + - + ]: 43640 : if (has_qphase.and.pawfgrtab%expiqr_allocated==0) then
2186 [ # # ]: 0 : if (pawfgrtab%rfgd_allocated==0) then
2187 : 0 : msg='pawfgrtab()%rfgd array must be allocated !'
2188 : 0 : LIBPAW_BUG(msg)
2189 : : end if
2190 [ # # ]: 0 : if (allocated(pawfgrtab%expiqr)) then
2191 : 0 : LIBPAW_DEALLOCATE(pawfgrtab%expiqr)
2192 : : end if
2193 [ # # # # : 0 : LIBPAW_ALLOCATE(pawfgrtab%expiqr,(2,nfgd))
# # # # #
# # # #
# ]
2194 : 0 : call pawexpiqr(pawfgrtab%expiqr,gprimd,nfgd,qphon,pawfgrtab%rfgd,xred(:,iatom))
2195 : 0 : pawfgrtab%expiqr_allocated=2
2196 : : end if
2197 : :
2198 : : !Init memory
2199 [ + + + + ]: 5515201 : dijhat=zero
2200 [ - + + - : 130920 : LIBPAW_ALLOCATE(prod,(qphase*lm_size))
+ - + - -
+ - + ]
2201 [ - + + - : 130920 : LIBPAW_ALLOCATE(dijhat_idij,(qphase*lmn2_size))
+ - + - -
+ - + ]
2202 : :
2203 : : !----------------------------------------------------------
2204 : : !Loop over spin components
2205 : : !----------------------------------------------------------
2206 [ + + ]: 43640 : nsploop=nsppol;if (ndij==4) nsploop=4
2207 [ + + ]: 101348 : do idij=1,nsploop
2208 [ + + + + : 101348 : if (idij<=nsppol.or.(nspden==4.and.idij<=3)) then
+ + ]
2209 : :
2210 : 51910 : idijend=idij+idij/3
2211 [ + + ]: 105244 : do ispden=idij,idijend
2212 : :
2213 : : ! ------------------------------------------------------
2214 : : ! Compute Int[V(r).g_l(r).Y_lm(r)]
2215 : : ! ------------------------------------------------------
2216 : : ! Note for non-collinear magnetism:
2217 : : ! We compute Int[V^(alpha,beta)(r).g_l(r).Y_lm(r)]
2218 : : ! Remember: if nspden=4, V is stored as : V^11, V^22, V^12, i.V^21
2219 : :
2220 [ + + ]: 717110 : prod=zero
2221 : :
2222 : : ! ===== Standard case ============================
2223 [ + + ]: 53334 : if (.not.has_qphase) then
2224 [ - + ]: 52758 : if (qphase==1) then
2225 [ + + ]: 705398 : do ilslm=1,lm_size
2226 [ + + ]: 2103793027 : do ic=1,nfgd
2227 : 2103087629 : vr=Pot(pawfgrtab%ifftsph(ic),ispden)
2228 : 2103740269 : prod(ilslm)=prod(ilslm)+vr*pawfgrtab%gylm(ic,ilslm)
2229 : : end do
2230 : : end do
2231 : : else
2232 : : ilslm1=1
2233 [ # # ]: 0 : do ilslm=1,lm_size
2234 [ # # ]: 0 : do ic=1,nfgd
2235 : 0 : jc=2*pawfgrtab%ifftsph(ic)
2236 : 0 : vr=Pot(jc-1,ispden);vi=Pot(jc,ispden)
2237 : 0 : prod(ilslm1 )=prod(ilslm1 )+vr*pawfgrtab%gylm(ic,ilslm)
2238 : 0 : prod(ilslm1+1)=prod(ilslm1+1)+vi*pawfgrtab%gylm(ic,ilslm)
2239 : : end do
2240 : 0 : ilslm1=ilslm1+qphase
2241 : : end do
2242 : : end if
2243 : :
2244 : : ! ===== Including Exp(iqr) phase (DFPT only) =====
2245 : : else
2246 [ + - ]: 576 : if (qphase==1) then
2247 [ # # ]: 0 : do ilslm=1,lm_size
2248 [ # # ]: 0 : do ic=1,nfgd
2249 : 0 : vr=Pot(pawfgrtab%ifftsph(ic),ispden)
2250 : : prod(ilslm)=prod(ilslm)+vr*pawfgrtab%gylm(ic,ilslm)&
2251 : 0 : & *pawfgrtab%expiqr(1,ic)
2252 : : end do
2253 : : end do
2254 : : else
2255 : : ilslm1=1
2256 [ + + ]: 6144 : do ilslm=1,lm_size
2257 [ + + ]: 9280812 : do ic=1,nfgd
2258 : 9275244 : jc=2*pawfgrtab%ifftsph(ic)
2259 : 9275244 : vr=Pot(jc-1,ispden);vi=Pot(jc,ispden)
2260 : : prod(ilslm1 )=prod(ilslm1 )+pawfgrtab%gylm(ic,ilslm)&
2261 : 9275244 : & *(vr*pawfgrtab%expiqr(1,ic)-vi*pawfgrtab%expiqr(2,ic))
2262 : : prod(ilslm1+1)=prod(ilslm1+1)+pawfgrtab%gylm(ic,ilslm)&
2263 : 9280812 : & *(vr*pawfgrtab%expiqr(2,ic)+vi*pawfgrtab%expiqr(1,ic))
2264 : : end do
2265 : 6144 : ilslm1=ilslm1+qphase
2266 : : end do
2267 : : end if
2268 : : end if
2269 : :
2270 : : ! Scaling factor (unit volume)
2271 [ + + ]: 717110 : prod=prod*ucvol/dble(ngridtot)
2272 : :
2273 : : ! Reduction in case of parallelism
2274 [ + + ]: 53334 : if (xmpi_comm_size(my_comm_grid)>1) then
2275 : 1588 : call xmpi_sum(prod,my_comm_grid,ier)
2276 : : end if
2277 : :
2278 : : ! ----------------------------------------------------------
2279 : : ! Compute Sum_(i,j)_LM { q_ij^L Int[V(r).g_l(r).Y_lm(r)] }
2280 : : ! ----------------------------------------------------------
2281 : : ! Note for non-collinear magnetism:
2282 : : ! We compute Sum_(i,j)_LM { q_ij^L Int[V^(alpha,beta)(r).g_l(r).Y_lm(r)] }
2283 : :
2284 [ + + ]: 3728201 : dijhat_idij=zero
2285 : :
2286 [ + + ]: 53334 : if (qphase==1) then
2287 [ + + ]: 3679673 : do klmn=1,lmn2_size
2288 : 3626915 : klm =pawtab%indklmn(1,klmn)
2289 : 3626915 : lmin=pawtab%indklmn(3,klmn)
2290 : 3626915 : lmax=pawtab%indklmn(4,klmn)
2291 [ + - + + ]: 10878723 : do ils=lmin,lmax,2
2292 : 7199050 : lm0=ils**2+ils+1
2293 [ + + ]: 42629873 : do mm=-ils,ils
2294 : 31803908 : ilslm=lm0+mm;isel=pawang%gntselect(ilslm,klm)
2295 [ + + ]: 31803908 : if (isel>0) dijhat_idij(klmn)=dijhat_idij(klmn) &
2296 : 14165887 : & +prod(ilslm)*pawtab%qijl(ilslm,klmn)
2297 : : end do
2298 : : end do
2299 : : end do
2300 : : else
2301 [ + + ]: 24552 : do klmn=1,lmn2_size
2302 : 23976 : klmn1=2*klmn-1
2303 : 23976 : klm =pawtab%indklmn(1,klmn)
2304 : 23976 : lmin=pawtab%indklmn(3,klmn)
2305 : 23976 : lmax=pawtab%indklmn(4,klmn)
2306 [ + - + + ]: 64704 : do ils=lmin,lmax,2
2307 : 40152 : lm0=ils**2+ils+1
2308 [ + + ]: 195768 : do mm=-ils,ils
2309 : 131640 : ilslm=lm0+mm;ilslm1=2*ilslm;isel=pawang%gntselect(ilslm,klm)
2310 [ + + ]: 171792 : if (isel>0) then
2311 : 36648 : dijhat_idij(klmn1 )=dijhat_idij(klmn1 )+prod(ilslm1-1)*pawtab%qijl(ilslm,klmn)
2312 : 36648 : dijhat_idij(klmn1+1)=dijhat_idij(klmn1+1)+prod(ilslm1 )*pawtab%qijl(ilslm,klmn)
2313 : : end if
2314 : : end do
2315 : : end do
2316 : : end do
2317 : : end if
2318 : :
2319 : : ! ----------------------------------------------------------
2320 : : ! Deduce some part of Dij according to symmetries
2321 : : ! ----------------------------------------------------------
2322 : :
2323 : : !if ispden=1 => real part of D^11_ij
2324 : : !if ispden=2 => real part of D^22_ij
2325 : : !if ispden=3 => real part of D^12_ij
2326 : : !if ispden=4 => imaginary part of D^12_ij
2327 : 53334 : klmn1=max(1,ispden-2);klmn2=1
2328 [ + + ]: 3704225 : do klmn=1,lmn2_size
2329 : 3650891 : dijhat(klmn1,idij)=dijhat_idij(klmn2)
2330 : 3650891 : klmn1=klmn1+cplex_dij
2331 : 3704225 : klmn2=klmn2+qphase
2332 : : end do
2333 [ + + ]: 105244 : if (qphase==2) then
2334 : : !Same storage with exp^(-i.q.r) phase
2335 : 576 : klmn1=max(1,ispden-2)+lmn2_size*cplex_dij;klmn2=2
2336 [ + + ]: 24552 : do klmn=1,lmn2_size
2337 : 23976 : dijhat(klmn1,idij)=dijhat_idij(klmn2)
2338 : 23976 : klmn1=klmn1+cplex_dij
2339 : 24552 : klmn2=klmn2+qphase
2340 : : end do
2341 : : endif
2342 : :
2343 : : end do !ispden
2344 : :
2345 : : !Non-collinear: D_ij(:,4)=D^21_ij=D^12_ij^*
2346 [ + + + - ]: 5798 : else if (nspden==4.and.idij==4) then
2347 [ + + ]: 493778 : dijhat(:,idij)=dijhat(:,idij-1)
2348 [ + - ]: 1424 : if (cplex_dij==2) then
2349 [ + - ]: 1424 : do klmn=2,lmn2_size*cplex_dij,cplex_dij
2350 [ + + ]: 246177 : dijhat(klmn,idij)=-dijhat(klmn,idij)
2351 : : end do
2352 [ - + ]: 1424 : if (qphase==2) then
2353 [ # # ]: 0 : do klmn=2+lmn2_size*cplex_dij,2*lmn2_size*cplex_dij,cplex_dij
2354 [ # # ]: 0 : dijhat(klmn,idij)=-dijhat(klmn,idij)
2355 : : end do
2356 : : end if
2357 : : end if
2358 : :
2359 : : !Antiferro: D_ij(:,2)=D^down_ij=D^up_ij
2360 [ + - + + ]: 4374 : else if (nsppol==1.and.idij==2) then
2361 [ + + ]: 189802 : dijhat(:,idij)=dijhat(:,idij-1)
2362 : : end if
2363 : :
2364 : : !----------------------------------------------------------
2365 : : !End loop on spin density components
2366 : : end do
2367 : :
2368 : : !Free temporary memory spaces
2369 [ - + ]: 43640 : LIBPAW_DEALLOCATE(prod)
2370 [ - + ]: 43640 : LIBPAW_DEALLOCATE(dijhat_idij)
2371 [ + + ]: 43640 : if (pawfgrtab%gylm_allocated==2) then
2372 [ - + ]: 9 : LIBPAW_DEALLOCATE(pawfgrtab%gylm)
2373 [ - + ]: 9 : LIBPAW_ALLOCATE(pawfgrtab%gylm,(0,0))
2374 : 9 : pawfgrtab%gylm_allocated=0
2375 : : end if
2376 [ - + ]: 43640 : if (pawfgrtab%expiqr_allocated==2) then
2377 [ # # ]: 0 : LIBPAW_DEALLOCATE(pawfgrtab%expiqr)
2378 [ # # ]: 0 : LIBPAW_ALLOCATE(pawfgrtab%expiqr,(0,0))
2379 : 0 : pawfgrtab%expiqr_allocated=0
2380 : : end if
2381 : :
2382 : 43640 : end subroutine pawdijhat
2383 : : !!***
2384 : :
2385 : : !----------------------------------------------------------------------
2386 : :
2387 : : !!****f* m_pawdij/pawdijnd
2388 : : !! NAME
2389 : : !! pawdijnd
2390 : : !!
2391 : : !! FUNCTION
2392 : : !! Compute the nuclear dipole contribution to the PAW
2393 : : !! pseudopotential strength Dij
2394 : : !! (for one atom only)
2395 : : !!
2396 : : !! INPUTS
2397 : : !! cplex_dij=2 if dij is COMPLEX (as in the spin-orbit case), 1 if dij is REAL
2398 : : !! ndij= number of spin components
2399 : : !! nucdipmom(3) nuclear magnetic dipole moment for current atom
2400 : : !! pawrad <type(pawrad_type)>=paw radial mesh and related data, for current atom
2401 : : !! pawtab <type(pawtab_type)>=paw tabulated starting data, for current atom
2402 : : !!
2403 : : !! OUTPUT
2404 : : !! dijnd(cplex_dij*lmn2_size,ndij)= nuclear dipole moment Dij terms
2405 : : !! cplex_dij=2 must be 2
2406 : : !! dij(2*i-1,:) contains the real part,
2407 : : !! dij(2*i ,:) contains the imaginary part
2408 : : !!
2409 : : !! NOTES
2410 : : !! On-site contribution of a nuclear magnetic dipole moment at $R$. Hamiltonian is
2411 : : !! $H=(1/2m_e)(p - q_e A)^2 + V$ in SI units, and vector potential $A$ is
2412 : : !! $A=(\mu_0/4\pi) m\times (r-R)/|r-R|^3 = (\mu_0/4\pi) L_R\cdot m/|r-R|^3$ where
2413 : : !! $L_R$ is the on-site orbital angular momentum and $m$ is the nuclear magnetic
2414 : : !! dipole moment. Second order term in A is ignored. In atomic units the on-site term
2415 : : !! is \alpha^2 L_R\cdot m/|r-R|^3, where \alpha is the fine structure constant.
2416 : : !!
2417 : : !!
2418 : : !! SOURCE
2419 : :
2420 [ - + ]: 639 : subroutine pawdijnd(dijnd,cplex_dij,gprimd,iatom,natom,ndij,nspden,nucdipmom,&
2421 [ - + - + ]: 639 : & pawang,pawrad,pawtab,pawxcdev,qphase,vh1,vxc1,xred,znuc,zora)
2422 : :
2423 : : !Arguments ---------------------------------------------
2424 : : !scalars
2425 : : integer,intent(in) :: cplex_dij,iatom,natom,ndij,nspden,pawxcdev,qphase,zora
2426 : : real(dp),intent(in) :: znuc
2427 : : type(pawang_type),intent(in) :: pawang
2428 : : type(pawrad_type),intent(in) :: pawrad
2429 : : type(pawtab_type),target,intent(in) :: pawtab
2430 : : !arrays
2431 : : real(dp),intent(out) :: dijnd(:,:)
2432 : : real(dp),intent(in) :: gprimd(3,3),nucdipmom(3,natom)
2433 : : real(dp),intent(in) :: vh1(:,:,:),vxc1(:,:,:),xred(3,natom)
2434 : :
2435 : : !Local variables ---------------------------------------
2436 : : !scalars
2437 : : integer :: angl_size,idir,ii,ij_size,il,ilmn,im,imesh
2438 : : integer :: jatom,jl,jlmn,jm,klmn,kln,lm_size,lmn2_size ! klm,
2439 : : integer :: mesh_size
2440 : : real(dp) :: rc,rr,rt
2441 : : real(dp), parameter :: HalfFineStruct2=half/InvFineStruct**2
2442 : : complex(dp) :: cmatrixelement,lms
2443 : : logical :: usezora
2444 : : !arrays
2445 : 639 : integer,pointer :: indlmn(:,:),indklmn(:,:)
2446 : 639 : real(dp),allocatable :: ff(:),intgr3(:),v1(:),zk1(:)
2447 : : character(len=500) :: msg
2448 : : ! *************************************************************************
2449 : :
2450 : : !Useful data
2451 : 639 : angl_size=pawang%angl_size
2452 : 639 : indklmn => pawtab%indklmn
2453 : 639 : indlmn => pawtab%indlmn
2454 : 639 : mesh_size=pawtab%mesh_size
2455 : 639 : ij_size=pawtab%ij_size
2456 : 639 : lm_size=pawtab%lcut_size**2
2457 : 639 : lmn2_size=pawtab%lmn2_size
2458 : 639 : usezora=((zora.EQ.1).OR.(zora.EQ.3))
2459 : :
2460 : : !write(std_out,'(a,I4,L4)')'JWZ debug pawdijnd zora use_zora ', &
2461 : : ! & zora,usezora
2462 : :
2463 : : !Check data consistency
2464 : 639 : if (cplex_dij/=2) then
2465 : 0 : msg='cplex_dij must be 2 for nuclear dipole moments !'
2466 : 0 : LIBPAW_BUG(msg)
2467 : : end if
2468 [ + - - + ]: 639 : if (size(dijnd,1)/=cplex_dij*pawtab%lmn2_size.or.size(dijnd,2)/=ndij) then
2469 : 0 : msg='invalid sizes for Dijnd !'
2470 : 0 : LIBPAW_BUG(msg)
2471 : : end if
2472 : :
2473 [ - + + - : 1917 : LIBPAW_ALLOCATE(zk1,(mesh_size))
+ - + - -
+ - + ]
2474 [ + + ]: 639 : if(usezora) then
2475 [ + - + - : 118 : if (size(vh1,1)/=qphase*mesh_size.or.size(vh1,2)<1.or.size(vh1,3)<1) then
- + ]
2476 : 0 : msg='invalid sizes for vh1!'
2477 : 0 : LIBPAW_BUG(msg)
2478 : : end if
2479 : : if (size(vxc1,1)/=qphase*mesh_size.or.size(vxc1,3)/=nspden.or.&
2480 [ + - + - : 118 : & (size(vxc1,2)/=angl_size.and.pawxcdev==0).or.&
+ - - + -
- ]
2481 [ + - ]: 118 : & (size(vxc1,2)/=lm_size.and.pawxcdev/=0)) then
2482 : 0 : msg='invalid sizes for vxc1!'
2483 : 0 : LIBPAW_BUG(msg)
2484 : : end if
2485 : :
2486 [ - + + - : 236 : LIBPAW_ALLOCATE(v1,(mesh_size))
- + - + ]
2487 : 118 : call pawv1(mesh_size,nspden,pawang,pawxcdev,v1,vh1,vxc1)
2488 [ - + + + ]: 164504 : zk1 = one/(one - HalfFineStruct2*v1)
2489 [ - + ]: 118 : LIBPAW_DEALLOCATE(v1)
2490 : : !! replace v1 potential with -Z/r for distances < r_c, the
2491 : : !! classical electron radius. This is an accurate replacement
2492 : : !! with better analytic properties at r=0.
2493 : 118 : rc=two*HalfFineStruct2
2494 : 118 : rt=znuc*rc
2495 : :
2496 : : ! replace k at short range with Coulomb potential version
2497 [ + - ]: 3520 : do ii=1,mesh_size
2498 : 3520 : rr=pawrad%rad(ii)
2499 [ + + ]: 3520 : if (rr>rc) exit
2500 [ + + ]: 3520 : if (rr<tol8) then
2501 : 118 : zk1(ii)=zero
2502 : : else
2503 : 3284 : zk1(ii)=one/(one+rt/(two*rr))
2504 : : end if
2505 : : end do
2506 : : end if
2507 : :
2508 [ + + + + ]: 113789 : dijnd = zero
2509 : :
2510 : : !-------------------------------------------------------------------
2511 : : ! Computation of (<phi_i|phi_j>-<tphi_i|tphi_j>)/r^3 radial integral
2512 : : !-------------------------------------------------------------------
2513 : :
2514 [ - + + - : 1917 : LIBPAW_ALLOCATE(intgr3,(ij_size))
+ - + - -
+ - + ]
2515 : :
2516 [ - + + - : 1278 : LIBPAW_ALLOCATE(ff,(mesh_size))
- + - + ]
2517 [ + + ]: 7029 : do kln=1,ij_size
2518 [ + + ]: 8322240 : do imesh = 2, mesh_size
2519 : 8315850 : rr = pawrad%rad(imesh)
2520 : 8322240 : ff(imesh)=(pawtab%phiphj(imesh,kln)- pawtab%tphitphj(imesh,kln))/(rr**3)
2521 : : end do !imesh
2522 [ + + + + ]: 1647890 : if (usezora) ff(2:mesh_size)=ff(2:mesh_size)*zk1(2:mesh_size)
2523 : 6390 : call pawrad_deducer0(ff,mesh_size,pawrad)
2524 : 7029 : call simp_gen(intgr3(kln),ff,pawrad)
2525 : : end do
2526 [ - + ]: 639 : LIBPAW_DEALLOCATE(ff)
2527 : :
2528 : : !---------------------------
2529 : : ! accumulate matrix elements
2530 : : !---------------------------
2531 [ + + ]: 23643 : do klmn=1,lmn2_size
2532 : :
2533 : 23004 : ilmn=indklmn(7,klmn)
2534 : 23004 : jlmn=indklmn(8,klmn)
2535 : :
2536 : 23004 : il=indlmn(1,ilmn)
2537 : 23004 : jl=indlmn(1,jlmn)
2538 : :
2539 : 23004 : im=indlmn(2,ilmn)
2540 : 23004 : jm=indlmn(2,jlmn)
2541 : 23004 : kln=indklmn(2,klmn)
2542 : :
2543 : : ! Matrix elements of interest are <S_l'm'|L_i|S_lm>
2544 : : ! these are zero if l' /= l and also if l' == l == 0
2545 [ + + ]: 23004 : if ( il /= jl ) cycle
2546 [ + + ]: 15336 : if ( il == 0 ) cycle
2547 : :
2548 [ + + ]: 54315 : do idir = 1, 3
2549 : :
2550 : : ! this loop accumulates a dot product so if no dipole moment in direction idir, nothing to do
2551 [ + + ]: 40257 : if( ABS(nucdipmom(idir,iatom)) .LT. tol8 ) cycle
2552 : :
2553 : 13419 : call slxyzs(il,im,idir,jl,jm,lms)
2554 : :
2555 : 13419 : cmatrixelement = FineStructureConstant2*lms*nucdipmom(idir,iatom)*intgr3(kln)
2556 : 13419 : dijnd(2*klmn-1,1) = dijnd(2*klmn-1,1) + real(cmatrixelement)
2557 : 63261 : dijnd(2*klmn ,1) = dijnd(2*klmn ,1) + aimag(cmatrixelement)
2558 : :
2559 : : end do ! end loop over idir
2560 : :
2561 : : end do ! end loop over basis states
2562 : :
2563 [ - + ]: 639 : LIBPAW_DEALLOCATE(intgr3)
2564 : :
2565 : : ! loop over other atoms to compute A.A term. Note this is "on-site only" with
2566 : : ! phi*phij, no tphi*tphij, because this term is not present in the planewave
2567 : : ! getghc
2568 [ + + ]: 1716 : do jatom=1,natom
2569 [ + + ]: 1077 : if (jatom .EQ. iatom) cycle ! no self term
2570 [ + + + + : 1432 : if (.NOT. ANY(ABS(nucdipmom(:,jatom))>tol8)) cycle ! skip neighbors without dipoles
+ + ]
2571 : :
2572 : : call pawdijaa(dijnd,gprimd,iatom,jatom,mesh_size,natom,nucdipmom,&
2573 : 1716 : & pawang,pawrad,pawtab,usezora,xred,zk1)
2574 : :
2575 : : end do
2576 : :
2577 : : ! in case of ndij > 1, note that there is no spin-flip in this term
2578 : : ! so therefore down-down = up-up, and up-down and down-up terms are still zero
2579 [ + + + + ]: 23031 : if(ndij > 1) dijnd(:,2)=dijnd(:,1)
2580 : :
2581 [ + - ]: 639 : if(allocated(zk1)) then
2582 : 639 : LIBPAW_DEALLOCATE(zk1)
2583 : : end if
2584 : :
2585 [ - + ]: 639 : end subroutine pawdijnd
2586 : : !!***
2587 : :
2588 : : !----------------------------------------------------------------------
2589 : :
2590 : : !!****f* m_pawdij/pawdijaa
2591 : : !! NAME
2592 : : !! pawdijaa
2593 : : !!
2594 : : !! FUNCTION
2595 : : !! Compute the Dipole-Dipole contribution to the PAW
2596 : : !! pseudopotential strength Dij
2597 : : !! (for one atom only)
2598 : : !!
2599 : : !! INPUTS
2600 : : !!
2601 : : !! OUTPUT
2602 : : !!
2603 : : !! NOTES
2604 : : !!
2605 : : !! SOURCE
2606 : :
2607 : 480 : subroutine pawdijaa(dijnd,gprimd,iatom,jatom,mesh_size,natom,nucdipmom,&
2608 [ - + ]: 240 : & pawang,pawrad,pawtab,usezora,xred,zk1)
2609 : :
2610 : : !Arguments ---------------------------------------------
2611 : : !scalars
2612 : : integer,intent(in) :: iatom,jatom,mesh_size,natom
2613 : : logical,intent(in) :: usezora
2614 : : type(pawang_type),intent(in) :: pawang
2615 : : type(pawrad_type),intent(in) :: pawrad
2616 : : type(pawtab_type),target,intent(in) :: pawtab
2617 : : !arrays
2618 : : real(dp),intent(in) :: gprimd(3,3),nucdipmom(3,natom),xred(3,natom),zk1(mesh_size)
2619 : : real(dp),intent(inout) :: dijnd(:,:)
2620 : :
2621 : : !Local variables ---------------------------------------
2622 : : !scalars
2623 : : integer :: angmom,iaa,ignt,ignt23,ij_size,imesh,info
2624 : : integer :: klmn,klm,klm2,klm23,klm3,klm3a,klm3b,klm4,kln,l2,l3,l4
2625 : : integer :: m1dir,m2dir,m2,m3,m3a,m3b,m4,my_lmax,my_lsizemax,my_ngnt
2626 : : real(dp) :: aa1a,aa1b,aa2a,aa2b,dr,rr,aa1a_fac,aa1b_fac,aa2a_fac,aa2b_fac
2627 : : real(dp) :: m1m2,m12d
2628 : : real(dp), parameter :: c1=sqrt(four_pi/15.0d0)
2629 : : real(dp), parameter :: c2=sqrt(four_pi/5.0d0)
2630 : : real(dp), parameter :: c3=sqrt(four_pi)
2631 : : real(dp), parameter :: FineStruct4=one/InvFineStruct**4
2632 : : !arrays
2633 : : integer :: ipiv(3)
2634 : : integer,parameter :: s1map(3)=[1,-1,0]
2635 : 240 : integer,pointer :: indlmn(:,:),indklmn(:,:)
2636 : : integer,allocatable :: my_gntselect(:,:)
2637 : : real(dp) :: d2ij(3,3,9),rprimd(3,3),rvec(3,1),rvec_len(1),work(3)
2638 : 240 : real(dp),allocatable :: aaint(:,:,:),ff(:),my_realgnt(:),ylm_rvec(:,:)
2639 : :
2640 : : ! *************************************************************************
2641 : :
2642 : : !Useful data
2643 : 240 : indklmn => pawtab%indklmn
2644 : 240 : indlmn => pawtab%indlmn
2645 : 240 : ij_size=pawtab%ij_size
2646 [ + + ]: 960 : m1m2 = DOT_PRODUCT(nucdipmom(1:3,iatom),nucdipmom(1:3,jatom))
2647 : :
2648 : : ! spherical harmonic representation of \hat{r}\hat{r}
2649 : 240 : d2ij = zero
2650 : 240 : d2ij(1,2,5)=c1; d2ij(2,1,5)=c1 ! xy/r^2 = c1*S_{2,-2}
2651 : 240 : d2ij(2,3,6)=c1; d2ij(3,2,6)=c1 ! yz/r^2 = c1*S_{2,-1}
2652 : 240 : d2ij(1,3,8)=c1; d2ij(3,1,8)=c1 ! xz/r^2 = c1*S_{2,+1}
2653 : 240 : d2ij(3,3,1)=c3/three; d2ij(3,3,7)=two*c2/three ! zz/r^2 = c3/3 S_{00} + 2c2/3 S_{20}
2654 : 240 : d2ij(1,1,1)=c3/three; d2ij(1,1,7)=-c2/three; d2ij(1,1,9)=c1 ! xx/r^2 = c3/3 S_00-c2/3 S_20 + c1 S-{2,2}
2655 : 240 : d2ij(2,2,1)=c3/three; d2ij(2,2,7)=-c2/three; d2ij(2,2,9)=-c1 ! xx/r^2 = c3/3 S_00-c2/3 S_20 - c1 S-{2,2}
2656 : :
2657 : : ! need set of Gaunt integrals two larger than usual
2658 : 240 : my_lmax=pawang%l_max+2
2659 : 240 : my_lsizemax=2*my_lmax-1
2660 [ - + + - : 960 : LIBPAW_ALLOCATE(my_gntselect,((2*my_lmax-1)**2,my_lmax**2*(my_lmax**2+1)/2))
+ - - + +
- + - + -
- + - + ]
2661 [ - + + - : 720 : LIBPAW_ALLOCATE(my_realgnt,((2*my_lmax-1)**2*my_lmax**4))
+ - + - -
+ - + ]
2662 : 240 : call realgaunt(my_lmax,my_ngnt,my_gntselect,my_realgnt)
2663 : :
2664 : : ! obtain rprimd by inversion of gprimd
2665 : : ! have to use elaborate lapack calls because we are inside libpaw
2666 : 240 : rprimd=gprimd
2667 : 240 : call dgetrf(3,3,rprimd,3,ipiv,info)
2668 : 240 : call dgetri(3,rprimd,3,ipiv,work,3,info)
2669 : :
2670 : : ! rvec is R2-R1 where R2,R1 are the two atoms with dipoles
2671 [ + + + + : 3840 : rvec(1:3,1)=MATMUL(rprimd,(xred(:,jatom)-xred(:,iatom)))
+ + ]
2672 [ + + ]: 960 : rvec_len(1) = SQRT(DOT_PRODUCT(rvec(:,1),rvec(:,1)))
2673 : 240 : dr = rvec_len(1)
2674 : :
2675 : : ! generate Ylm's for rvec
2676 [ - + + - : 720 : LIBPAW_ALLOCATE(ylm_rvec,(my_lsizemax**2,1))
+ - + - -
+ - + ]
2677 : 240 : call initylmr(my_lsizemax,1,1,rvec_len,1,rvec,ylm_rvec)
2678 : :
2679 : : ! compute radial integrals
2680 [ - + + - : 1200 : LIBPAW_ALLOCATE(aaint,(ij_size,my_lsizemax,2))
- + + - +
- + - + -
- + - + ]
2681 [ - + + - : 720 : LIBPAW_ALLOCATE(ff,(mesh_size))
+ - + - -
+ - + ]
2682 : :
2683 [ + + ]: 720 : do iaa = 1, 2
2684 : : ! note here l2 = angmom + 1
2685 [ + + ]: 4080 : do l2 = 1, my_lsizemax
2686 : 3360 : angmom = l2 - 1
2687 [ + + ]: 37440 : do kln=1,ij_size
2688 [ + + ]: 41137600 : do imesh = 2, mesh_size
2689 : 41104000 : rr = pawrad%rad(imesh)
2690 : : ! integrand for r^(angmom-iaa)/dr^(angmom+1) * 1/(dr^2 - r^2)
2691 : : ff(imesh)=pawtab%phiphj(imesh,kln)*&
2692 : 41137600 : & rr**(angmom-iaa)/((dr*dr-rr*rr)*dr**(angmom+1))
2693 : : end do !imesh
2694 [ + + ]: 41137600 : ff(2:mesh_size) = four_pi*ff(2:mesh_size)
2695 [ + + + + ]: 15646400 : if (usezora) ff(2:mesh_size)=ff(2:mesh_size)*zk1(2:mesh_size)
2696 : 33600 : call pawrad_deducer0(ff,mesh_size,pawrad)
2697 : 36960 : call simp_gen(aaint(kln,l2,iaa),ff,pawrad)
2698 : : end do
2699 : : end do
2700 : : end do
2701 [ - + ]: 240 : LIBPAW_DEALLOCATE(ff)
2702 : :
2703 : : ! term Ia factor: 1/2 \alpha^4 m1\cdot\m2
2704 : 240 : aa1a_fac = half*FineStruct4*m1m2
2705 : : ! term Ib factor: -1/2 \alpha^4 (4\pi/3) m1\cdot\m2
2706 : 240 : aa1b_fac = -half*FineStruct4*four_pi*m1m2/three
2707 : : ! term IIa factor: -1/2 \alpha^4
2708 : 240 : aa2a_fac = -half*FineStruct4
2709 : : ! term IIb factor: 1/2 \alpha^4 (4\pi/3)
2710 : 240 : aa2b_fac = half*FineStruct4*four_pi/three
2711 : :
2712 [ + + ]: 8880 : do klmn=1,pawtab%lmn2_size
2713 : 8640 : klm=indklmn(2,klmn); kln=indklmn(2,klmn)
2714 : :
2715 : 8640 : aa1a=zero
2716 : 8640 : aa1b=zero
2717 : : ! Term Ia, Ib
2718 : : ! note l2 here really is the angular momentum
2719 [ + + ]: 27360 : do l2 = indklmn(3,klmn),indklmn(4,klmn)
2720 [ + + ]: 82080 : do m2=-l2,l2
2721 : 54720 : klm2=LMPACK(l2,m2)
2722 : 54720 : ignt=my_gntselect(klm2,klm)
2723 [ + + ]: 73440 : if (ignt > 0) then
2724 : : ! note that aaint second index is angmom + 1, so l2+1 here
2725 : 11280 : aa1a = aa1a + aa1a_fac*my_realgnt(ignt)*ylm_rvec(klm2,1)*aaint(kln,l2+1,1)
2726 : :
2727 [ + + ]: 38400 : do l4=abs(l2-1),l2+1
2728 [ + + ]: 158640 : do m4=-l4,l4
2729 : 120240 : klm4=LMPACK(l4,m4)
2730 : 120240 : l3=1
2731 [ + + ]: 508080 : do m3=-l3,l3
2732 : 360720 : klm3=LMPACK(l3,m3)
2733 : 360720 : klm23=MATPACK(klm2,klm3)
2734 : 360720 : ignt23=my_gntselect(klm4,klm23)
2735 [ + + ]: 480960 : if (ignt23 > 0) then
2736 : : aa1b = aa1b + aa1b_fac*aaint(kln,l4+1,2)*&
2737 : : & dr*ylm_rvec(klm4,1)*ylm_rvec(klm3,1)*&
2738 : 56880 : & my_realgnt(ignt)*my_realgnt(ignt23)
2739 : : end if ! ignt23
2740 : : end do ! m3
2741 : : end do ! m4
2742 : : end do ! l4
2743 : : end if ! ignt
2744 : : end do ! loop on mm
2745 : : end do ! loop on ll
2746 : :
2747 : : aa2a=0
2748 [ + + ]: 27360 : do l2 = indklmn(3,klmn),indklmn(4,klmn)
2749 [ + + ]: 82080 : do m2=-l2,l2
2750 : 54720 : klm2=LMPACK(l2,m2)
2751 : 54720 : ignt=my_gntselect(klm2,klm)
2752 [ + + ]: 73440 : if (ignt > 0) then
2753 [ + + ]: 51360 : do l4=abs(l2-2),l2+2
2754 [ + + ]: 251760 : do m4=-l4,l4
2755 : 200400 : klm4=LMPACK(l4,m4)
2756 [ + + ]: 841680 : do l3=0,2
2757 [ + + ]: 2605200 : do m3=-l3,l3
2758 : 1803600 : klm3=LMPACK(l3,m3)
2759 : 1803600 : klm23=MATPACK(klm2,klm3)
2760 : 1803600 : ignt23=my_gntselect(klm4,klm23)
2761 [ + + ]: 2404800 : if (ignt23 > 0) then
2762 [ + + ]: 669120 : do m1dir=1,3
2763 [ + + ]: 2174640 : do m2dir=1,3
2764 : 1505520 : m12d=nucdipmom(m1dir,iatom)*nucdipmom(m2dir,jatom)
2765 [ + + ]: 1505520 : if (abs(m12d)<tol8) cycle
2766 [ + + ]: 167280 : if (abs(d2ij(m1dir,m2dir,klm3))<tol8) cycle
2767 : : aa2a=aa2a+m12d*aa2a_fac*aaint(kln,l4+1,1)*&
2768 : : & d2ij(m1dir,m2dir,klm3)*ylm_rvec(klm4,1)*&
2769 : 2007360 : & my_realgnt(ignt)*my_realgnt(ignt23)
2770 : : end do ! m2dir
2771 : : end do ! m1dir
2772 : : end if ! ignt23
2773 : : end do ! m3
2774 : : end do ! l3
2775 : : end do ! m4
2776 : : end do ! l4
2777 : : end if ! ignt
2778 : : end do ! loop on mm
2779 : : end do ! loop on ll
2780 : :
2781 : : aa2b=0
2782 [ + + ]: 27360 : do l2 = indklmn(3,klmn),indklmn(4,klmn)
2783 [ + + ]: 82080 : do m2=-l2,l2
2784 : 54720 : klm2=LMPACK(l2,m2)
2785 : 54720 : ignt=my_gntselect(klm2,klm)
2786 [ + + ]: 73440 : if (ignt > 0) then
2787 [ + + ]: 38400 : do l4=abs(l2-1),l2+1
2788 [ + + ]: 158640 : do m4=-l4,l4
2789 : 120240 : klm4=LMPACK(l4,m4)
2790 [ + + ]: 508080 : do m1dir=1,3
2791 : 360720 : l3=1; m3a=s1map(m1dir)
2792 : 360720 : klm3a=LMPACK(l3,m3a)
2793 : 360720 : klm23=MATPACK(klm2,klm3a)
2794 : 360720 : ignt23=my_gntselect(klm4,klm23)
2795 [ + + ]: 480960 : if (ignt23 > 0) then
2796 [ + + ]: 227520 : do m2dir=1,3
2797 : 170640 : m12d=nucdipmom(m1dir,iatom)*nucdipmom(m2dir,jatom)
2798 [ + + ]: 170640 : if (abs(m12d)<tol8) cycle
2799 : 17040 : m3b=s1map(m2dir)
2800 : 17040 : klm3b=LMPACK(l3,m3b)
2801 : : aa2b=aa2b+m12d*aa2b_fac*aaint(kln,l4+1,2)*&
2802 : : dr*my_realgnt(ignt)*my_realgnt(ignt23)*&
2803 : 227520 : ylm_rvec(klm4,1)*ylm_rvec(klm3b,1)
2804 : : end do ! m2dir
2805 : : end if ! ignt23
2806 : : end do ! m1dir
2807 : : end do ! m4
2808 : : end do ! l4
2809 : : end if ! ignt
2810 : : end do ! loop on mm
2811 : : end do ! loop on ll
2812 : :
2813 : 8880 : dijnd(2*klmn-1,1) = dijnd(2*klmn-1,1) + aa1a + aa1b + aa2a + aa2b
2814 : :
2815 : : end do ! loop on klmn
2816 : :
2817 [ - + ]: 240 : LIBPAW_DEALLOCATE(my_gntselect)
2818 [ - + ]: 240 : LIBPAW_DEALLOCATE(my_realgnt)
2819 [ - + ]: 240 : LIBPAW_DEALLOCATE(aaint)
2820 [ - + ]: 240 : LIBPAW_DEALLOCATE(ylm_rvec)
2821 : :
2822 : 480 : end subroutine pawdijaa
2823 : : !!***
2824 : :
2825 : : !----------------------------------------------------------------------
2826 : :
2827 : :
2828 : : !!****f* m_pawdij/pawdijso
2829 : : !! NAME
2830 : : !! pawdijso
2831 : : !!
2832 : : !! FUNCTION
2833 : : !! Compute the spin-orbit contribution to the PAW
2834 : : !! pseudopotential strength Dij and also the nuclear dipole
2835 : : !! spin interactions.
2836 : : !! (for one atom only)
2837 : : !!
2838 : : !! INPUTS
2839 : : !! cplex_dij=2 if dij is COMPLEX (as in the spin-orbit case), 1 if dij is REAL
2840 : : !! qphase=2 if dij contains a exp(-i.q.r) phase (as in the q<>0 RF case), 1 if not
2841 : : !! ndij= number of spin components for Dij^SO
2842 : : !! nspden=number of spin density components
2843 : : !! paw_an <type(paw_an_type)>=paw arrays given on angular mesh, for current atom
2844 : : !! pawang <type(pawang_type)>=paw angular mesh and related data
2845 : : !! pawrad <type(pawrad_type)>=paw radial mesh and related data, for current atom
2846 : : !! pawtab <type(pawtab_type)>=paw tabulated starting data, for current atom
2847 : : !! pawxcdev=Choice of XC development (0=no dev. (use of angular mesh) ; 1 or 2=dev. on moments)
2848 : : !! spnorbscl=scaling factor for spin-orbit coupling
2849 : : !! vh1(qphase*mesh_size,v_size,nspden)=all-electron on-site Hartree potential for current atom
2850 : : !! only spherical moment is used
2851 : : !! vxc1(qphase*mesh_size,v_size,nspden)=all-electron on-site XC potential for current atom
2852 : : !! given on a (r,theta,phi) grid (v_size=angl_size)
2853 : : !! or on (l,m) spherical moments (v_size=lm_size)
2854 : : !! znuc=nuclear charge
2855 : : !! zora=use of zora terms
2856 : : !!
2857 : : !! OUTPUT
2858 : : !! dijso(cplex_dij*qphase*lmn2_size,ndij)= spin-orbit Dij terms
2859 : : !! Dij^SO is complex, so cplex_dij=2 must be 2:
2860 : : !! dij(2*i-1,:) contains the real part
2861 : : !! dij(2*i,:) contains the imaginary part
2862 : : !! Dij^SO is represented with 4 components:
2863 : : !! dijso(:,:,1) contains Dij_SO^up-up
2864 : : !! dijso(:,:,2) contains Dij_SO^dn-dn
2865 : : !! dijso(:,:,3) contains Dij_SO^up-dn
2866 : : !! dijso(:,:,4) contains Dij_SO^dn-up
2867 : : !! When a exp(-i.q.r) phase is included (qphase=2):
2868 : : !! dij(1:cplex_dij*lmn2_size,:)
2869 : : !! contains the real part of the phase, i.e. D_ij*cos(q.r)
2870 : : !! dij(cplex_dij*lmn2_size+1:2*cplex_dij*lmn2_size,:)
2871 : : !! contains the imaginary part of the phase, i.e. D_ij*sin(q.r)
2872 : : !!
2873 : : !! SOURCE
2874 : :
2875 [ - + ]: 2220 : subroutine pawdijso(dijso,cplex_dij,qphase,ndij,nspden,pawang,pawrad,pawtab,&
2876 [ - + - + ]: 2220 : & pawxcdev,spnorbscl,vh1,vxc1,znuc,zora,&
2877 : : & nucdipmom,spinaxis)
2878 : :
2879 : : !Arguments ---------------------------------------------
2880 : : !scalars
2881 : : integer,intent(in) :: cplex_dij,ndij,nspden,pawxcdev,qphase,zora
2882 : : real(dp),intent(in) :: spnorbscl,znuc
2883 : : type(pawang_type),intent(in) :: pawang
2884 : : type(pawrad_type),intent(in) :: pawrad
2885 : : type(pawtab_type),target,intent(in) :: pawtab
2886 : : !arrays
2887 : : real(dp),intent(out) :: dijso(:,:)
2888 : : real(dp),intent(in) :: vh1(:,:,:),vxc1(:,:,:)
2889 : : real(dp),optional,intent(in) :: nucdipmom(3)
2890 : : real(dp),optional,intent(in) :: spinaxis(3)
2891 : : !Local variables ---------------------------------------
2892 : : !scalars
2893 : : integer :: angl_size,gs1,gs2,idij,ii,ij_size,ilm,jlm,ispden
2894 : : integer :: klm,klmn,klmn1,kln
2895 : : integer :: lm_size,lmn2_size,mdir,mesh_size,ngnt,sdir
2896 : : real(dp), parameter :: HalfFineStruct2=half/InvFineStruct**2
2897 : : real(dp) :: alpha,beta,fact,me1,me2,rc,rr,rt,sme,cb2,sb2
2898 : : logical :: has_nucdipmom,use_soc,use_sd,use_fc
2899 : : character(len=500) :: msg
2900 : : !arrays
2901 : 2220 : integer,pointer :: indklmn(:,:)
2902 : : real(dp) :: spinaxis_in(3)
2903 : 2220 : real(dp),allocatable :: dijnd_rad(:,:),dijso_rad(:),dkdr(:),dv1dr(:),dyadic(:,:,:,:)
2904 : 2220 : real(dp),allocatable :: v1(:),zk1(:),z_intgd(:),z_kernel(:)
2905 : : complex(dp) :: D(2,2),Drot(2,2),U(2,2),ep,em
2906 : :
2907 : : ! *************************************************************************
2908 : :
2909 : : !Useful data
2910 : 2220 : lm_size=pawtab%lcut_size**2
2911 : 2220 : lmn2_size=pawtab%lmn2_size
2912 : 2220 : ij_size=pawtab%ij_size
2913 : 2220 : angl_size=pawang%angl_size
2914 : 2220 : mesh_size=pawtab%mesh_size
2915 : 2220 : indklmn => pawtab%indklmn
2916 : :
2917 : 2220 : select case(zora)
2918 : : case(-3)
2919 : : use_soc=.TRUE.; use_sd=.FALSE.; use_fc=.TRUE.
2920 : : case(-2)
2921 : : use_soc=.TRUE.; use_sd=.TRUE.; use_fc=.FALSE.
2922 : : case(-1)
2923 : : use_soc=.TRUE.; use_sd=.FALSE.; use_fc=.FALSE.
2924 : : case(1)
2925 : : ! this case really shouldn't appear as zora 1 means kinetic only and
2926 : : ! no spin terms
2927 : : use_soc=.FALSE.; use_sd=.FALSE.; use_fc=.FALSE.
2928 : : case(2)
2929 : : use_soc=.TRUE.; use_sd=.TRUE.; use_fc=.TRUE.
2930 : : case(3)
2931 : : use_soc=.TRUE.; use_sd=.TRUE.; use_fc=.TRUE.
2932 : : ! the default case is a bit strange because of the legacy
2933 : : ! feature that, although SOC in just one of several ZORA terms,
2934 : : ! historically it was treated as "stand alone" by abinit.
2935 : : ! so, this routine can be triggered in abinit by "pawspnorb 1"
2936 : : ! without the use of the zora variable, so if we get to this point
2937 : : ! in the code with zora=0, we still have the legacy
2938 : : ! pawspnorb case to deal with
2939 : : case default
2940 : 2220 : use_soc=.TRUE.; use_sd=.FALSE.; use_fc=.FALSE.
2941 : : end select
2942 : :
2943 : : !write(std_out,'(a,3L4)')'JWZ debug pawdijso use_soc use_sd use_fc : ',&
2944 : : ! & use_soc,use_sd,use_fc
2945 : :
2946 : : !Check data consistency
2947 [ - + ]: 2220 : if (qphase/=1) then
2948 : 0 : msg='qphase=2 not yet available in pawdijso!'
2949 : 0 : LIBPAW_BUG(msg)
2950 : : end if
2951 [ - + ]: 2220 : if (cplex_dij/=2) then
2952 : 0 : msg='cplex_dij must be 2 for spin-orbit coupling!'
2953 : 0 : LIBPAW_BUG(msg)
2954 : : end if
2955 [ - + ]: 2220 : if (ndij/=4) then
2956 : 0 : msg='ndij must be 4 for spin-orbit coupling!'
2957 : 0 : LIBPAW_BUG(msg)
2958 : : end if
2959 [ - + ]: 2220 : if (pawang%use_ls_ylm==0) then
2960 : 0 : msg='pawang%use_ls_ylm should be /=0!'
2961 : 0 : LIBPAW_BUG(msg)
2962 : : end if
2963 [ + - - + ]: 2220 : if (size(dijso,1)/=cplex_dij*qphase*lmn2_size.or.size(dijso,2)/=ndij) then
2964 : 0 : msg='invalid sizes for DijSO!'
2965 : 0 : LIBPAW_BUG(msg)
2966 : : end if
2967 [ + - + - : 2220 : if (size(vh1,1)/=qphase*mesh_size.or.size(vh1,2)<1.or.size(vh1,3)<1) then
- + ]
2968 : 0 : msg='invalid sizes for vh1!'
2969 : 0 : LIBPAW_BUG(msg)
2970 : : end if
2971 : : if (size(vxc1,1)/=qphase*mesh_size.or.size(vxc1,3)/=nspden.or.&
2972 [ + - + + : 2220 : & (size(vxc1,2)/=angl_size.and.pawxcdev==0).or.&
+ - + + -
+ ]
2973 [ + - ]: 2220 : & (size(vxc1,2)/=lm_size.and.pawxcdev/=0)) then
2974 : 0 : msg='invalid sizes for vxc1!'
2975 : 0 : LIBPAW_BUG(msg)
2976 : : end if
2977 [ + - ]: 2220 : if (present(nucdipmom)) then
2978 [ + + + + ]: 8380 : has_nucdipmom = ANY(ABS(nucdipmom(:))>tol8)
2979 : : else
2980 : : has_nucdipmom=.FALSE.
2981 : : end if
2982 : :
2983 : : !------------------------------------------------------------------------
2984 : : !----------- Allocations and initializations
2985 : : !------------------------------------------------------------------------
2986 : :
2987 : : ! classical electron radius \alpha^2
2988 : 2220 : rc=two*HalfFineStruct2
2989 : :
2990 [ - + + - : 6660 : LIBPAW_ALLOCATE(v1,(mesh_size))
+ - + - -
+ - + ]
2991 : 2220 : call pawv1(mesh_size,nspden,pawang,pawxcdev,v1,vh1,vxc1)
2992 : :
2993 [ - + + - : 4440 : LIBPAW_ALLOCATE(dv1dr,(mesh_size))
- + - + ]
2994 : 2220 : call nderiv_gen(dv1dr,v1,pawrad)
2995 : :
2996 [ - + + - : 4440 : LIBPAW_ALLOCATE(zk1,(mesh_size))
- + - + ]
2997 [ - + + + ]: 2567356 : zk1 = one/(one - HalfFineStruct2*v1)
2998 [ - + ]: 2220 : LIBPAW_DEALLOCATE(v1)
2999 : :
3000 [ - + + - : 4440 : LIBPAW_ALLOCATE(dkdr,(mesh_size))
- + - + ]
3001 [ - + + + ]: 2567356 : dkdr = HalfFineStruct2*zk1*zk1*dv1dr
3002 [ - + ]: 2220 : LIBPAW_DEALLOCATE(dv1dr)
3003 : :
3004 : : !! replace v1 potential with -Z/r for distances < r_c, the
3005 : : !! classical electron radius. This is an accurate replacement
3006 : : !! with better analytic properties at r=0.
3007 : 2220 : rt=znuc*rc
3008 : : ! replace k and dk/dr at short range with Coulomb potential version
3009 [ + - ]: 54540 : do ii=1,mesh_size
3010 : 54540 : rr=pawrad%rad(ii)
3011 [ + + ]: 54540 : if (rr>rc) exit
3012 [ + + ]: 54540 : if (rr<tol8) then
3013 : 2220 : zk1(ii)=zero; dkdr(ii)=two/rt
3014 : : else
3015 : 50100 : zk1(ii)=one/(one+rt/(two*rr))
3016 : 50100 : dkdr(ii)=two*rt/(two*rr+rt)**2
3017 : : end if
3018 : : end do
3019 : :
3020 : : !------------------------------------------------------------------------
3021 : : !----- radial integrals
3022 : : !------------------------------------------------------------------------
3023 : :
3024 [ - + + - : 4440 : LIBPAW_ALLOCATE(z_kernel,(mesh_size))
- + - + ]
3025 [ - + + - : 4440 : LIBPAW_ALLOCATE(z_intgd,(mesh_size))
- + - + ]
3026 : :
3027 : : ! spin-orbit kernel
3028 [ + - ]: 2220 : if (use_soc) then
3029 [ - + + - : 6660 : LIBPAW_ALLOCATE(dijso_rad,(ij_size))
+ - + - -
+ - + ]
3030 [ + + ]: 2562916 : z_kernel(2:mesh_size) = dkdr(2:mesh_size)/pawrad%rad(2:mesh_size)
3031 : 2220 : call pawrad_deducer0(z_kernel,mesh_size,pawrad)
3032 [ + + ]: 36279 : do kln=1,ij_size
3033 [ + - - + : 37436057 : z_intgd = z_kernel*pawtab%phiphj(1:mesh_size,kln)
- - + + ]
3034 : 36279 : call simp_gen(dijso_rad(kln),z_intgd,pawrad)
3035 : : end do
3036 [ + + ]: 36279 : dijso_rad(:)=spnorbscl*dijso_rad(:)
3037 : : end if
3038 : :
3039 : : ! nuclear dipole kernels
3040 [ + + ]: 2220 : if (has_nucdipmom) then
3041 [ - + + - : 900 : LIBPAW_ALLOCATE(dijnd_rad,(2,ij_size))
+ - + - -
+ - + ]
3042 [ + + + + ]: 9300 : dijnd_rad(:,:)=zero
3043 : : ! -\alpha^2 K(r)/r^3
3044 [ + + ]: 377000 : z_kernel(2:mesh_size) = -rc*zk1(2:mesh_size)/pawrad%rad(2:mesh_size)**3
3045 : 300 : call pawrad_deducer0(z_kernel,mesh_size,pawrad)
3046 [ + + ]: 3300 : do kln=1,ij_size
3047 [ + - - + : 3776000 : z_intgd = z_kernel*pawtab%phiphj(1:mesh_size,kln)
- - + + ]
3048 : 3300 : call simp_gen(dijnd_rad(1,kln),z_intgd,pawrad)
3049 : : end do
3050 : : ! \alpha^2 K'(r)/r^2
3051 [ + + ]: 377000 : z_kernel(2:mesh_size) = rc*dkdr(2:mesh_size)/pawrad%rad(2:mesh_size)**2
3052 : 300 : call pawrad_deducer0(z_kernel,mesh_size,pawrad)
3053 [ + + ]: 3300 : do kln=1,ij_size
3054 [ + - - + : 3776000 : z_intgd = z_kernel*pawtab%phiphj(1:mesh_size,kln)
- - + + ]
3055 : 3300 : call simp_gen(dijnd_rad(2,kln),z_intgd,pawrad)
3056 : : end do
3057 : : end if ! nuclear dipole radial integrals
3058 : :
3059 [ - + ]: 2220 : LIBPAW_DEALLOCATE(z_kernel)
3060 [ - + ]: 2220 : LIBPAW_DEALLOCATE(z_intgd)
3061 [ - + ]: 2220 : LIBPAW_DEALLOCATE(zk1)
3062 [ - + ]: 2220 : LIBPAW_DEALLOCATE(dkdr)
3063 : :
3064 : : !------------------------------------------------------------------------
3065 : : !----- compute dyadics if necessary
3066 : : !------------------------------------------------------------------------
3067 [ + + ]: 2220 : if (has_nucdipmom) then
3068 : 300 : gs1=size(pawang%gntselect,1)
3069 : 300 : gs2=size(pawang%gntselect,2)
3070 : 300 : ngnt=size(pawang%realgnt)
3071 [ - + + - : 1200 : LIBPAW_ALLOCATE(dyadic,(3,3,gs2,2))
+ - + - +
- - + -
+ ]
3072 : : ! dyadic(:,:,:,1) : (1 - 3\hat{r}\hat{r})
3073 : : ! dyadic(:,:,:,2) : (1 - \hat{r}\hat{r})
3074 : : call make_dyadic(one,three,dyadic(1:3,1:3,1:gs2,1),pawang%gntselect,&
3075 : 300 : gs1,gs2,gs2,ngnt,pawang%realgnt)
3076 : : call make_dyadic(one,one,dyadic(1:3,1:3,1:gs2,2),pawang%gntselect,&
3077 : 300 : gs1,gs2,gs2,ngnt,pawang%realgnt)
3078 : : end if
3079 : :
3080 : : !------------------------------------------------------------------------
3081 : : !----- Loop over density components
3082 : : !------------------------------------------------------------------------
3083 [ + + + + ]: 1858996 : dijso=zero
3084 [ + - ]: 2220 : if (use_soc) then
3085 [ + + ]: 11100 : do idij=1,ndij
3086 : :
3087 : : ! ------------------------------------------------------------------------
3088 : : ! ----- Computation of Dij_so
3089 : : ! ------------------------------------------------------------------------
3090 : 8880 : klmn1=1
3091 [ + + ]: 11100 : if (mod(idij,2)==1) then
3092 : 4440 : ispden=(1+idij)/2
3093 [ + + ]: 466414 : do klmn=1,lmn2_size
3094 [ + + ]: 461974 : if (indklmn(3,klmn)==0) then ! il==jl
3095 : 223946 : klm=indklmn(1,klmn);kln=indklmn(2,klmn)
3096 : 223946 : ilm=indklmn(5,klmn);jlm=indklmn(6,klmn)
3097 [ + + ]: 223946 : fact=dijso_rad(kln);if (ilm>jlm) fact=-fact
3098 : 223946 : dijso(klmn1 ,idij)=fact*pawang%ls_ylm(1,klm,ispden)
3099 : 223946 : dijso(klmn1+1,idij)=fact*pawang%ls_ylm(2,klm,ispden)
3100 : : end if
3101 : 466414 : klmn1=klmn1+cplex_dij
3102 : : end do
3103 [ + + ]: 4440 : else if (idij==2) then
3104 [ + + ]: 233207 : do klmn=1,lmn2_size
3105 [ + + ]: 230987 : if (indklmn(3,klmn)==0) then ! il==jl
3106 : 111973 : dijso(klmn1 ,2)=-dijso(klmn1 ,1)
3107 : 111973 : dijso(klmn1+1,2)=-dijso(klmn1+1,1)
3108 : : end if
3109 : 233207 : klmn1=klmn1+cplex_dij
3110 : : end do
3111 [ + - ]: 2220 : else if (idij==4) then
3112 [ + + ]: 233207 : do klmn=1,lmn2_size
3113 [ + + ]: 230987 : if (indklmn(3,klmn)==0) then ! il==jl
3114 : 111973 : dijso(klmn1 ,4)=-dijso(klmn1 ,3)
3115 : 111973 : dijso(klmn1+1,4)= dijso(klmn1+1,3)
3116 : : end if
3117 : 233207 : klmn1=klmn1+cplex_dij
3118 : : end do
3119 : : end if
3120 : : end do ! ----- End loop over idij
3121 [ - + ]: 2220 : LIBPAW_DEALLOCATE(dijso_rad)
3122 : : end if ! end use_soc condition
3123 : :
3124 : : ! add nucdipmom terms if present
3125 [ + + ]: 2220 : if(has_nucdipmom) then
3126 : : klmn1=1
3127 [ + + ]: 11100 : do klmn=1,lmn2_size
3128 : 10800 : klm=indklmn(1,klmn); kln=indklmn(2,klmn)
3129 [ + + ]: 43200 : do mdir=1,3
3130 [ + + ]: 32400 : if (abs(nucdipmom(mdir))<tol8) cycle
3131 [ + + ]: 54000 : do sdir=1,3
3132 : 32400 : me1=zero;me2=zero
3133 [ + - ]: 32400 : if(use_sd) me1=nucdipmom(mdir)*dijnd_rad(1,kln)*dyadic(mdir,sdir,klm,1)
3134 [ + - ]: 32400 : if(use_fc) me2=nucdipmom(mdir)*dijnd_rad(2,kln)*dyadic(mdir,sdir,klm,2)
3135 : 32400 : sme = half*(me1+me2)
3136 : 32400 : select case(sdir)
3137 : : case(1) !Sx operator
3138 : 10800 : dijso(klmn1,3)=dijso(klmn1,3)+sme
3139 : 10800 : dijso(klmn1,4)=dijso(klmn1,4)+sme
3140 : : case(2) !Sy operator
3141 : 10800 : dijso(klmn1+1,3)=dijso(klmn1+1,3)-sme
3142 : 10800 : dijso(klmn1+1,4)=dijso(klmn1+1,4)+sme
3143 : : case(3) !Sz operator
3144 : 10800 : dijso(klmn1,1)=dijso(klmn1,1)+sme
3145 [ + + + ]: 32400 : dijso(klmn1,2)=dijso(klmn1,2)-sme
3146 : : end select
3147 : : end do ! loop on sdir
3148 : : end do ! loop on mdir
3149 : 11100 : klmn1=klmn1+cplex_dij
3150 : : end do !loop on klmn
3151 [ - + ]: 300 : LIBPAW_DEALLOCATE(dyadic)
3152 [ - + ]: 300 : LIBPAW_DEALLOCATE(dijnd_rad)
3153 : : end if
3154 : :
3155 [ + - ]: 2220 : spinaxis_in = [zero, zero, one]; if (present(spinaxis)) spinaxis_in = spinaxis
3156 : :
3157 [ + - ]: 2220 : if (ndij >= 4) then
3158 : :
3159 : 2220 : call geteuler(spinaxis_in,alpha,beta)
3160 : :
3161 [ + - - + ]: 2220 : if (.not.(abs(alpha) < tol8 .and. abs(beta) < tol8)) then
3162 : :
3163 : 0 : cb2 = cos(half*beta); sb2 = sin(half*beta)
3164 : 0 : em = exp(-j_dpc*half*alpha); ep = conjg(em)
3165 : 0 : U(1,1) = cb2 * em; U(1,2) = -sb2 * em
3166 : 0 : U(2,1) = sb2 * ep; U(2,2) = cb2 * ep
3167 : :
3168 : : ! spinaxis rotation assumes qphase=1
3169 : 0 : klmn1 = 1
3170 [ # # ]: 0 : do klmn = 1, lmn2_size
3171 : :
3172 : 0 : D(1,1) = cmplx(dijso(klmn1,1), dijso(klmn1+1,1), kind=dp)
3173 : 0 : D(2,2) = cmplx(dijso(klmn1,2), dijso(klmn1+1,2), kind=dp)
3174 : 0 : D(1,2) = cmplx(dijso(klmn1,3), dijso(klmn1+1,3), kind=dp)
3175 : 0 : D(2,1) = cmplx(dijso(klmn1,4), dijso(klmn1+1,4), kind=dp)
3176 : :
3177 [ # # # # : 0 : Drot(:,:) = matmul(conjg(transpose(U)), matmul(D(:,:), U))
# # # # #
# # # ]
3178 : :
3179 : 0 : dijso(klmn1,1) = real(Drot(1,1), kind=dp); dijso(klmn1+1,1) = aimag(Drot(1,1))
3180 : 0 : dijso(klmn1,2) = real(Drot(2,2), kind=dp); dijso(klmn1+1,2) = aimag(Drot(2,2))
3181 : 0 : dijso(klmn1,3) = real(Drot(1,2), kind=dp); dijso(klmn1+1,3) = aimag(Drot(1,2))
3182 : 0 : dijso(klmn1,4) = real(Drot(2,1), kind=dp); dijso(klmn1+1,4) = aimag(Drot(2,1))
3183 : :
3184 : 2220 : klmn1 = klmn1 + cplex_dij
3185 : : end do
3186 : : end if
3187 : : end if
3188 : :
3189 [ + - - + : 4440 : end subroutine pawdijso
- + - + ]
3190 : :
3191 : : !!***
3192 : :
3193 : : !----------------------------------------------------------------------
3194 : :
3195 : : !!****f* m_pawdij/pawdiju
3196 : : !! NAME
3197 : : !! pawdiju
3198 : : !!
3199 : : !! FUNCTION
3200 : : !! Compute the DFT+U contribution to the PAW pseudopotential strength Dij,
3201 : : !! (for one atom only):
3202 : : !! Dijpawu^{\sigma}_{mi,ni,mj,nj}=
3203 : : !! \sum_{m,m'} [vpawu^{\sigma}_{m,m'}*phiphjint_{ni,nj}^{m,m'}]=
3204 : : !! [vpawu^{\sigma}_{mi,mj}*phiphjint_{ni,nj}]
3205 : : !!
3206 : : !! INPUTS
3207 : : !! cplex_dij=2 if dij is COMPLEX (as in the spin-orbit case), 1 if dij is REAL
3208 : : !! qphase=2 if dij contains a exp(-i.q.r) phase (as in the q<>0 RF case), 1 if not
3209 : : !! ndij= number of spin components
3210 : : !! nsppol=number of independent spin WF components
3211 : : !! pawtab <type(pawtab_type)>=paw tabulated starting data, for current atom
3212 : : !! vpawu(cplex_dij,lpawu*2+1,lpawu*2+1,ndij)=moments of DFT+U potential for current atom
3213 : : !! --- Optional arguments ---
3214 : : !! atvshift(natvshift,nsppol)=potential energy shift for lm channel & spin (current atom)
3215 : : !! fatvshift=factor that multiplies atvshift
3216 : : !! natvshift=number of atomic potential energy shifts (per atom)
3217 : : !!
3218 : : !! OUTPUT
3219 : : !! dijpawu(cplex_dij*qphase*lmn2_size,ndij)= D_ij^U terms
3220 : : !! When Dij is complex (cplex_dij=2):
3221 : : !! dij(2*i-1,:) contains the real part, dij(2*i,:) contains the imaginary part
3222 : : !! When a exp(-i.q.r) phase is included (qphase=2):
3223 : : !! dij(1:cplex_dij*lmn2_size,:)
3224 : : !! contains the real part of the phase, i.e. D_ij*cos(q.r)
3225 : : !! dij(cplex_dij*lmn2_size+1:2*cplex_dij*lmn2_size,:)
3226 : : !! contains the imaginary part of the phase, i.e. D_ij*sin(q.r)
3227 : : !!
3228 : : !! SOURCE
3229 : :
3230 [ - + - + ]: 2612 : subroutine pawdiju(dijpawu,cplex_dij,qphase,ndij,nsppol,pawtab,vpawu,&
3231 [ + + + - : 2612 : & natvshift,atvshift,fatvshift) ! optional arguments
- + ]
3232 : :
3233 : : !Arguments ---------------------------------------------
3234 : : !scalars
3235 : : integer,intent(in) :: cplex_dij,ndij,nsppol,qphase
3236 : : integer,intent(in),optional :: natvshift
3237 : : real(dp),intent(in),optional :: fatvshift
3238 : : !arrays
3239 : : real(dp),intent(out) :: dijpawu(:,:)
3240 : : real(dp),intent(in) :: vpawu(:,:,:,:)
3241 : : real(dp),intent(in),optional :: atvshift(:,:)
3242 : : type(pawtab_type),intent(in) :: pawtab
3243 : :
3244 : : !Local variables ---------------------------------------
3245 : : !scalars
3246 : : integer :: icount,idij,idijeff,idijend,im1,im2,in1,in2,klmn,klmn1,lmax,lmin,lmn2_size
3247 : : integer :: lpawu,natvshift_,nsploop
3248 : : character(len=500) :: msg
3249 : : !arrays
3250 : 2612 : real(dp),allocatable :: coeffpawu(:),dijpawu_idij(:),dijsymU(:,:)
3251 : :
3252 : : ! *************************************************************************
3253 : :
3254 : : !Useful data
3255 : 2612 : lpawu=pawtab%lpawu
3256 : 2612 : lmn2_size=pawtab%lmn2_size
3257 [ + + ]: 2612 : natvshift_=0;if (present(natvshift)) natvshift_=natvshift
3258 : :
3259 : : !Check data consistency
3260 [ - + ]: 2612 : if (qphase/=1) then
3261 : 0 : msg='qphase=2 not available in pawdiju!'
3262 : 0 : LIBPAW_BUG(msg)
3263 : : end if
3264 [ + - - + ]: 2612 : if (size(dijpawu,1)/=cplex_dij*qphase*lmn2_size.or.size(dijpawu,2)/=ndij) then
3265 : 0 : msg='invalid sizes for dijpawu !'
3266 : 0 : LIBPAW_BUG(msg)
3267 : : end if
3268 : : if (size(vpawu,1)/=cplex_dij.or.size(vpawu,2)/=2*lpawu+1.or.&
3269 [ + - + - : 2612 : & size(vpawu,3)/=2*lpawu+1.or.size(vpawu,4)/=ndij) then
+ - - + ]
3270 : 0 : msg='invalid sizes for vpawu !'
3271 : 0 : LIBPAW_BUG(msg)
3272 : : end if
3273 [ + + ]: 2612 : if (natvshift_>0) then
3274 [ - + ]: 528 : if ((.not.present(atvshift)).or.(.not.present(fatvshift))) then
3275 : 0 : msg='when natvshift>0, atvshift and fatvshift arguments must be present !'
3276 : 0 : LIBPAW_BUG(msg)
3277 : : end if
3278 [ + - - + ]: 528 : if (size(atvshift,1)/=natvshift.or.size(atvshift,2)/=nsppol) then
3279 : 0 : msg='invalid sizes for atvshift !'
3280 : 0 : LIBPAW_BUG(msg)
3281 : : end if
3282 : : end if
3283 : :
3284 : : !Init memory
3285 [ + + + + ]: 1501498 : dijpawu=zero
3286 [ - + + - : 7836 : LIBPAW_ALLOCATE(dijpawu_idij,(cplex_dij*lmn2_size))
+ - + - -
+ - + ]
3287 [ - + + - : 7836 : LIBPAW_ALLOCATE(coeffpawu,(cplex_dij))
+ - + - -
+ - + ]
3288 [ + + ]: 2612 : if (ndij==4) then
3289 [ - + + - : 1899 : LIBPAW_ALLOCATE(dijsymU,(cplex_dij*lmn2_size,4))
+ - + - -
+ - + ]
3290 : : end if
3291 : :
3292 : : !Loop over spin components
3293 : : !----------------------------------------------------------
3294 [ + + ]: 2612 : nsploop=nsppol;if (ndij==4) nsploop=4
3295 [ + + ]: 8553 : do idij=1,nsploop
3296 [ + + + - : 5941 : if (idij<=nsppol.or.(ndij==4.and.idij<=3)) then
+ + ]
3297 : :
3298 : 5308 : idijend=idij+idij/3
3299 [ + + ]: 11249 : do idijeff=idij,idijend ! if ndij==4, idijeff is used to compute updn and dnup contributions
3300 : :
3301 [ + + ]: 1467382 : dijpawu_idij=zero
3302 : :
3303 : : ! Loop over (l,m,n) moments
3304 : : ! ----------------------------------------------------------
3305 : : klmn1=1
3306 [ + + ]: 1039078 : do klmn=1,lmn2_size
3307 : 1033137 : im1=pawtab%klmntomn(1,klmn)
3308 : 1033137 : im2=pawtab%klmntomn(2,klmn)
3309 : 1033137 : lmin=pawtab%indklmn(3,klmn)
3310 : 1033137 : lmax=pawtab%indklmn(4,klmn)
3311 : :
3312 : : ! Select l=lpawu
3313 [ + + + + ]: 1033137 : if (lmin==0.and.lmax==2*lpawu) then
3314 : :
3315 : : ! Check consistency
3316 : 273863 : in1=pawtab%klmntomn(3,klmn)
3317 : 273863 : in2=pawtab%klmntomn(4,klmn)
3318 : 273863 : icount=in1+(in2*(in2-1))/2
3319 [ - + ]: 273863 : if (pawtab%ij_proj<icount) then
3320 : 0 : msg='DFT+U: Problem while computing dijexxc !'
3321 : 0 : LIBPAW_BUG(msg)
3322 : : end if
3323 : :
3324 : : ! coeffpawu(:)=vpawu(:,im1,im2,idijeff) ! use real and imaginary part
3325 [ + + ]: 669746 : coeffpawu(:)=vpawu(:,im2,im1,idijeff) ! because of transposition in setnoccmmp (for the cplex_dij==2)
3326 : :
3327 [ + + + + ]: 273863 : if (natvshift_/=0.and.idij<3.and.im1==im2) then
3328 : 12464 : coeffpawu(1)=coeffpawu(1)+fatvshift*atvshift(im1,idij)
3329 : : end if
3330 [ + + ]: 273863 : if (cplex_dij==1) then !cplex_dij=nspinor=1
3331 : 151843 : dijpawu_idij(klmn1)=pawtab%phiphjint(icount)*coeffpawu(1)
3332 [ + - ]: 122020 : elseif (cplex_dij==2) then !cplex_dij=nspinor=2
3333 : 122020 : dijpawu_idij(klmn1 )=pawtab%phiphjint(icount)*coeffpawu(1)
3334 : 122020 : dijpawu_idij(klmn1+1)=pawtab%phiphjint(icount)*coeffpawu(2) ! spinor==2
3335 : : end if
3336 : :
3337 : : end if ! l selection
3338 : 1039078 : klmn1=klmn1+cplex_dij
3339 : : end do ! klmn
3340 : :
3341 [ + + ]: 1467382 : dijpawu(:,idij)=dijpawu_idij(:)
3342 [ + + + + ]: 868490 : if (ndij==4) dijsymU(:,idijeff)=dijpawu_idij(:)
3343 : :
3344 : : end do ! idijeff
3345 : :
3346 : : end if ! idij
3347 : :
3348 [ + + - + ]: 8553 : if (ndij==4.or.cplex_dij==2) then
3349 [ + + ]: 2532 : if (idij<=2) then
3350 : : dijpawu(:,idij)=dijpawu(:,idij)
3351 : : else
3352 [ + + ]: 429570 : dijpawu(:,idij)=dijsymU(:,idij)
3353 : : end if
3354 : : end if
3355 : :
3356 : : !End loop over spin components
3357 : : !----------------------------------------------------------
3358 : : end do
3359 : :
3360 : : !Free temporary memory spaces
3361 [ - + ]: 2612 : LIBPAW_DEALLOCATE(dijpawu_idij)
3362 [ - + ]: 2612 : LIBPAW_DEALLOCATE(coeffpawu)
3363 [ + + ]: 2612 : if (ndij==4) then
3364 [ - + ]: 633 : LIBPAW_DEALLOCATE(dijsymU)
3365 : : end if
3366 : :
3367 [ - + ]: 2612 : end subroutine pawdiju
3368 : : !!***
3369 : :
3370 : : !----------------------------------------------------------------------
3371 : :
3372 : : !!****f* m_pawdij/pawdiju_euijkl
3373 : : !! NAME
3374 : : !! pawdiju_euijkl
3375 : : !!
3376 : : !! FUNCTION
3377 : : !! Compute the DFT+U contribution to the PAW pseudopotential strength Dij (for one atom only).
3378 : : !! Alternative to pawdiju using the following property:
3379 : : !! D_ij^pawu^{\sigma}_{mi,ni,mj,nj}=\sum_{k,l} [rho^{\sigma}_kl*e^U_ijkl]
3380 : : !! The routine structure is similar to pawdijhartree.
3381 : : !!
3382 : : !! INPUTS
3383 : : !! cplex_dij=2 if dij is COMPLEX (as in the spin-orbit case), 1 if dij is REAL
3384 : : !! qphase=2 if dij contains a exp(-i.q.r) phase (as in the q<>0 RF case), 1 if not
3385 : : !! nspden=number of spin density components
3386 : : !! pawrhoij <type(pawrhoij_type)>= paw rhoij occupancies (and related data) for current atom
3387 : : !! pawtab <type(pawtab_type)>=paw tabulated starting data, for current atom
3388 : : !!
3389 : : !! OUTPUT
3390 : : !! diju(cplex_dij*qphase*lmn2_size,ndij)= D_ij^U terms
3391 : : !! diju_im(cplex_dij*qphase*lmn2_size,ndij)= (see below)
3392 : : !! When Dij is complex (cplex_dij=2):
3393 : : !! dij(2*i-1,:) contains the real part, dij(2*i,:) contains the imaginary part
3394 : : !! When a exp(-i.q.r) phase is included (qphase=2):
3395 : : !! dij(1:cplex_dij*lmn2_size,:)
3396 : : !! contains the real part of the phase, i.e. D_ij*cos(q.r)
3397 : : !! dij(cplex_dij*lmn2_size+1:2*cplex_dij*lmn2_size,:)
3398 : : !! contains the imaginary part of the phase, i.e. D_ij*sin(q.r)
3399 : : !!
3400 : : !! NOTES
3401 : : !! There are some subtleties :
3402 : : !! Contrary to eijkl, eu_ijkl is not invariant with respect to the permutation of i <--> j or k <--> l.
3403 : : !! Also, we have to deal with spin polarization.
3404 : : !! In the non-collinear magnetism case, the correct expression of Dij^st (s and t being spin indexes) is:
3405 : : !!
3406 : : !! D_kl^st = delta_st sum_ij rho_ij^ss eu_ijkl(1)
3407 : : !! + delta_st sum_ij rho_ij^-s-s eu_ijkl(2)
3408 : : !! + (1-delta_st) sum_ij rho_ij^st eu_ijkl(3)
3409 : : !!
3410 : : !! As only the lower triangular part of the Dij matrix is stored (i<=j), in practice we have:
3411 : : !!
3412 : : !! D_kl^st = delta_st sum_i<=j ( rho_ij^ss eu_ijkl(1) + (1-delta_ij) rho_ji^ss eu_jikl(1) )
3413 : : !! + delta_st sum_i<=j ( rho_ij^-s-s eu_ijkl(2) + (1-delta_ij) rho_ji^-s-s eu_jikl(2) )
3414 : : !! + (1-delta_st) sum_i<=j ( rho_ij^st eu_ijkl(3) + (1-delta_ij) rho_ji^st eu_jikl(3) )
3415 : : !!
3416 : : !! In the following, we will use that: (according to the rules in pawpuxinit.F90)
3417 : : !! (a) eu_ijkl + eu_jikl = eu_ijlk + eu_jilk (invariant when exchanging k <--> l)
3418 : : !! (b) eu_ijkl - eu_jikl = - eu_ijlk + eu_jilk (change of sign when exchanging k <--> l)
3419 : : !! and :
3420 : : !! (c) eu_iikl = eu_iilk (if i=j, invariant when exchanging k <--> l)
3421 : : !! (d) eu_ijkk = eu_jikk (if k=l, invariant when exchanging i <--> j)
3422 : : !!
3423 : : !! qphase=1 (ipert=0 or q=0):
3424 : : !! --------------------------
3425 : : !!
3426 : : !! --- Non-collinear case:
3427 : : !!
3428 : : !! We have:
3429 : : !! rho_ji^st = (rho_ij^ts)^*
3430 : : !! Re(rho_ji^st) = Re(rho_ij^ts)
3431 : : !! Im(rho_ji^st) = -Im(rho_ij^ts)
3432 : : !!
3433 : : !! As eu_ijkl is real one gets:
3434 : : !!
3435 : : !! Re(D_kl^st) = delta_st sum_i<=j Re(rho_ij^ss) ( eu_ijkl(1) + (1-delta_ij) eu_jikl(1) )
3436 : : !! + delta_st sum_i<=j Re(rho_ij^-s-s) ( eu_ijkl(2) + (1-delta_ij) eu_jikl(2) )
3437 : : !! + (1-delta_st) sum_i<=j ( Re(rho_ij^st) eu_ijkl(3) + (1-delta_ij) Re(rho_ij^ts) eu_jikl(3) )
3438 : : !!
3439 : : !! Im(D_kl^st) = delta_st sum_i<=j Im(rho_ij^ss) ( eu_ijkl(1) - (1-delta_ij) eu_jikl(1) )
3440 : : !! + delta_st sum_i<=j Im(rho_ij^-s-s) ( eu_ijkl(2) - (1-delta_ij) eu_jikl(2) )
3441 : : !! + (1-delta_st) sum_i<=j ( Im(rho_ij^st) eu_ijkl(3) - (1-delta_ij) Im(rho_ij^ts) eu_jikl(3) )
3442 : : !!
3443 : : !! --- Collinear case:
3444 : : !!
3445 : : !! Re(D_kl^s) = sum_i<=j Re(rho_ij^s) ( eu_ijkl(1) + (1-delta_ij) eu_jikl(1) )
3446 : : !! + sum_i<=j Re(rho_ij^-s) ( eu_ijkl(2) + (1-delta_ij) eu_jikl(2) )
3447 : : !!
3448 : : !! Im(D_kl^s) = sum_i<=j Im(rho_ij^s) ( eu_ijkl(1) - (1-delta_ij) eu_jikl(1) )
3449 : : !! + sum_i<=j Im(rho_ij^-s) ( eu_ijkl(2) - (1-delta_ij) eu_jikl(2) )
3450 : : !!
3451 : : !! Using (a) and (c) one gets:
3452 : : !! Re(D_kl^s) = Re(D_lk^s)
3453 : : !! Using (b) and (c) one gets:
3454 : : !! Im(D_kl^s) = -Im(D_lk^s)
3455 : : !!
3456 : : !! --- Without magnetism (rho_ij^up = rho_ij^down = 1/2 rho_ij^tot):
3457 : : !!
3458 : : !! Re(D_kl) = 1/2 sum_i<=j Re(rho_ij) ( eu_ijkl(1) + eu_ijkl(2) + (1-delta_ij) ( eu_jikl(1) + euijkl(2) ) )
3459 : : !!
3460 : : !! Im(D_kl) = 1/2 sum_i<=j Im(rho_ij) ( eu_ijkl(1) + eu_ijkl(2) - (1-delta_ij) ( eu_jikl(1) + euijkl(2) ) )
3461 : : !!
3462 : : !! qphase=2 (ipert>0 and q/=0) - no magnetism or collinear:
3463 : : !! -------------------------------------------------------
3464 : : !! We have:
3465 : : !! rho_ji = rhoA_ji + rhoB_ji
3466 : : !! where:
3467 : : !! rhoA_ji = rhoA_ij^*
3468 : : !! rhoB_ji = rhoB_ij
3469 : : !! So:
3470 : : !! D_kl = sum_i<=j ( rho_ij eu_ijkl + (1-delta_ij) (rhoA_ij^* + rhoB_ij) eu_jikl )
3471 : : !! As eu_ijkl is real:
3472 : : !! Re(D_kl) = sum_i<=j Re(rho_ij) ( eu_ijkl + (1-delta_ij) eu_jikl )
3473 : : !! Im(D_kl) = sum_i<=j Im(rhoB_ij) ( eu_ijkl + (1-delta_ij) eu_jikl )
3474 : : !! + sum_i<=j Im(rhoA_ij) ( eu_ijkl - (1-delta_ij) eu_jikl )
3475 : : !! We note:
3476 : : !! Im(D_kl^A) = sum_i<=j Im(rhoA_ij) ( eu_ijkl - (1-delta_ij) eu_jikl )
3477 : : !! Im(D_kl^B) = sum_i<=j Im(rhoB_ij) ( eu_ijkl + (1-delta_ij) eu_jikl )
3478 : : !! We still have:
3479 : : !! Re(D_kl) = Re(D_lk)
3480 : : !! but:
3481 : : !! Im(D_kl^A) = -Im(D_lk^A) ( using (b) and (c) )
3482 : : !! Im(D_kl^B) = Im(D_lk^B) ( using (a) and (c) )
3483 : : !!
3484 : : !! SOURCE
3485 : :
3486 [ - + ]: 312 : subroutine pawdiju_euijkl(diju,cplex_dij,qphase,ndij,pawrhoij,pawtab)
3487 : :
3488 : : !Arguments ---------------------------------------------
3489 : : !scalars
3490 : : integer,intent(in) :: cplex_dij,ndij,qphase
3491 : : !arrays
3492 : : real(dp),intent(out) :: diju(:,:)
3493 : : type(pawrhoij_type),intent(in) :: pawrhoij
3494 : : type(pawtab_type),intent(in) :: pawtab
3495 : :
3496 : : !Local variables ---------------------------------------
3497 : : !scalars
3498 : : integer :: cplex_rhoij,iq,iq0_dij,iq0_rhoij,ilmn,ilmnp,irhoij,j0lmnp,jlmn,jlmnp,jrhoij,select_euijkl
3499 : : integer :: klmn,klmnp,klmn1,lmn2_size,max_euijkl,min_euijkl,sig1,sig2,sig2p
3500 : : logical :: compute_im
3501 : : character(len=500) :: msg
3502 : : !arrays
3503 : 624 : real(dp) :: ro(2,ndij),euijkl_temp(3,2)
3504 : :
3505 : : ! *************************************************************************
3506 : :
3507 : : !Check data consistency
3508 : 312 : lmn2_size=pawrhoij%lmn2_size
3509 [ + - - + ]: 312 : if (size(diju,1)/=qphase*cplex_dij*lmn2_size.or.size(diju,2)/=ndij) then
3510 : 0 : msg='invalid sizes for diju!'
3511 : 0 : LIBPAW_BUG(msg)
3512 : : end if
3513 [ - + ]: 312 : if (pawrhoij%qphase<qphase) then
3514 : 0 : msg='pawrhoij%qphase must be >=qphase!'
3515 : 0 : LIBPAW_BUG(msg)
3516 : : end if
3517 [ - + ]: 312 : if (ndij/=pawrhoij%nspden) then
3518 : 0 : msg='pawrhoij%nspden must be equal to ndij!'
3519 : 0 : LIBPAW_BUG(msg)
3520 : : end if
3521 : :
3522 : : !Initialization
3523 [ + + + + ]: 217616 : diju=zero
3524 : 312 : cplex_rhoij=pawrhoij%cplex_rhoij
3525 : 312 : compute_im=(cplex_dij==2)
3526 : :
3527 : : !Loop over spin-components (Dij)
3528 [ + + ]: 1110 : do sig1=1,ndij
3529 : :
3530 [ + + ]: 798 : if (sig1<=2) then
3531 : : min_euijkl = 1
3532 : : max_euijkl = 2
3533 : : else
3534 : 264 : min_euijkl = 3
3535 : 264 : max_euijkl = 3
3536 : : end if
3537 : :
3538 : : !Loop over phase exp(iqr) phase real/imaginary part
3539 [ + + ]: 1908 : do iq=1,qphase
3540 : : !First loop: we store the real part in dij(1 -> lmn2_size)
3541 : : !2nd loop: we store the imaginary part in dij(lmn2_size+1 -> 2*lmn2_size)
3542 [ - + ]: 798 : iq0_dij=merge(0,cplex_dij*lmn2_size,iq==1)
3543 : 0 : iq0_rhoij=merge(0,cplex_rhoij*lmn2_size,iq==1)
3544 : :
3545 : : !Loop over rhoij elements
3546 : 798 : jrhoij=iq0_rhoij+1
3547 [ + + ]: 86972 : do irhoij=1,pawrhoij%nrhoijsel
3548 : 85376 : klmn=pawrhoij%rhoijselect(irhoij)
3549 : 85376 : ilmn=pawtab%indklmn(7,klmn)
3550 : 85376 : jlmn=pawtab%indklmn(8,klmn)
3551 : :
3552 : : !Storage of rhoij in ro (with a change of representation if nspinor=2)
3553 [ + + ]: 85376 : if (ndij==1) then ! rho_up = rho_down = 1/2 rho_tot
3554 [ + + ]: 4356 : ro(1:cplex_rhoij,1)=half*pawrhoij%rhoijp(jrhoij:jrhoij+cplex_rhoij-1,1)
3555 [ + + ]: 83198 : else if (ndij==2) then
3556 [ + + ]: 14274 : do sig2=1,ndij
3557 [ + + ]: 23790 : ro(1:cplex_rhoij,sig2)=pawrhoij%rhoijp(jrhoij:jrhoij+cplex_rhoij-1,sig2)
3558 : : end do
3559 : : else ! ndij=4
3560 : : !up up = 1/2 ( tot + z )
3561 [ + + ]: 235320 : ro(1:cplex_rhoij,1)=half*(pawrhoij%rhoijp(jrhoij:jrhoij+cplex_rhoij-1,1)+pawrhoij%rhoijp(jrhoij:jrhoij+cplex_rhoij-1,4))
3562 : : !down down = 1/2 ( tot - z )
3563 [ + + ]: 235320 : ro(1:cplex_rhoij,2)=half*(pawrhoij%rhoijp(jrhoij:jrhoij+cplex_rhoij-1,1)-pawrhoij%rhoijp(jrhoij:jrhoij+cplex_rhoij-1,4))
3564 [ - + - - ]: 78440 : if (cplex_rhoij==1) ro(2,1:2) = zero
3565 : : !up down = 1/2 ( x - i y )
3566 : 78440 : ro(1,3)= half*pawrhoij%rhoijp(jrhoij,2)
3567 : 78440 : ro(2,3)=-half*pawrhoij%rhoijp(jrhoij,3)
3568 [ + - ]: 78440 : if (cplex_rhoij==2) then
3569 : 78440 : ro(1,3)=ro(1,3)+half*pawrhoij%rhoijp(jrhoij+1,3)
3570 : 78440 : ro(2,3)=ro(2,3)+half*pawrhoij%rhoijp(jrhoij+1,2)
3571 : : end if
3572 : : !down up = 1/2 ( x + i y )
3573 : 78440 : ro(1,4)=half*pawrhoij%rhoijp(jrhoij,2)
3574 : 78440 : ro(2,4)=half*pawrhoij%rhoijp(jrhoij,3)
3575 [ - + ]: 78440 : if (cplex_rhoij==2) then
3576 : 78440 : ro(1,4)=ro(1,4)-half*pawrhoij%rhoijp(jrhoij+1,3)
3577 : 78440 : ro(2,4)=ro(2,4)+half*pawrhoij%rhoijp(jrhoij+1,2)
3578 : : end if
3579 : : end if
3580 : :
3581 [ + + ]: 1596264 : do jlmnp=1,pawtab%lmn_size
3582 : 1510888 : j0lmnp=jlmnp*(jlmnp-1)/2
3583 [ + + ]: 15781480 : do ilmnp=1,jlmnp
3584 : 14185216 : klmnp=j0lmnp+ilmnp
3585 : 14185216 : klmn1=iq0_dij+cplex_dij*(klmnp-1)+1
3586 : :
3587 [ + + ]: 56740864 : euijkl_temp(:,1) = pawtab%euijkl(:,ilmn,jlmn,ilmnp,jlmnp)
3588 [ + + ]: 56740864 : euijkl_temp(:,2) = pawtab%euijkl(:,jlmn,ilmn,ilmnp,jlmnp)
3589 : :
3590 : : !Loop over spin-components (rhoij)
3591 [ + + ]: 37566956 : do select_euijkl=min_euijkl,max_euijkl
3592 [ + + ]: 21870852 : if (sig1<=2) then ! up/up and down/down Dij components
3593 [ + + ]: 15371272 : if (ndij==1) then
3594 : : sig2=1
3595 : : else
3596 [ + + ]: 14626396 : if (select_euijkl==1) then ! Diagonal part of the spin matrix
3597 : : sig2=sig1
3598 [ + - ]: 7313198 : else if (select_euijkl==2) then ! Non-diagonal part
3599 [ + + ]: 7313198 : if (sig1==1) sig2=2
3600 : 4401475 : if (sig1==2) sig2=1
3601 : : end if
3602 : : end if
3603 : : sig2p = sig2
3604 : : else ! select_euijkl = 3
3605 : 6499580 : sig2 = sig1
3606 [ + + ]: 6499580 : if (sig1==3) sig2p=4
3607 [ + - ]: 3249790 : if (sig1==4) sig2p=3
3608 : : end if
3609 : : !Re(D_kl) = sum_i<=j Re(rho_ij) ( eu_ijlk + (1-delta_ij) eu_jilk ) = Re(D_lk)
3610 : 21870852 : diju(klmn1,sig1)=diju(klmn1,sig1)+ro(1,sig2)*euijkl_temp(select_euijkl,1)
3611 [ + + ]: 21870852 : if (ilmn/=jlmn) then
3612 : 18059094 : diju(klmn1,sig1)=diju(klmn1,sig1)+ro(1,sig2p)*euijkl_temp(select_euijkl,2)
3613 : : end if
3614 : : !Im(D_kl) = sum_i<=j Im(rho_ij) ( eu_ijlk - (1-delta_ij) eu_jilk ) = -Im(D_lk)
3615 [ + + ]: 36056068 : if (compute_im) then
3616 : 19498740 : diju(klmn1+1,sig1)=diju(klmn1+1,sig1)+ro(2,sig2)*euijkl_temp(select_euijkl,1)
3617 [ + + ]: 19498740 : if (ilmn/=jlmn) then
3618 : 17278992 : diju(klmn1+1,sig1)=diju(klmn1+1,sig1)-ro(2,sig2p)*euijkl_temp(select_euijkl,2)
3619 : : end if
3620 : : end if
3621 : : end do
3622 : :
3623 : : end do
3624 : : end do ! k,l
3625 : :
3626 : 86174 : jrhoij=jrhoij+cplex_rhoij
3627 : : end do ! i,j
3628 : :
3629 : : end do ! q phase
3630 : :
3631 : : end do !sig1
3632 : :
3633 : 312 : end subroutine pawdiju_euijkl
3634 : : !!***
3635 : :
3636 : : !----------------------------------------------------------------------
3637 : :
3638 : : !!****f* m_pawdij/pawdijexxc
3639 : : !! NAME
3640 : : !! pawdijexxc
3641 : : !!
3642 : : !! FUNCTION
3643 : : !! Compute the local Exact-Exchange contribution to the PAW pseudopotential strength Dij,
3644 : : !! using a potential expressed as (l,m) spherical moments
3645 : : !! (for one atom only; only for correlated electrons):
3646 : : !! D_ij^EXXC= < Phi_i|alpha*(VFock(correlated)-Vxc(n1_correlated)|Phi_j>
3647 : : !!
3648 : : !! INPUTS
3649 : : !! cplex_dij=2 if dij is COMPLEX (as in the spin-orbit case), 1 if dij is REAL
3650 : : !! qphase=2 if dij contains a exp(-i.q.r) phase (as in the q<>0 RF case), 1 if not
3651 : : !! lmselect(lm_size)=select the non-zero LM-moments of on-site potentials
3652 : : !! ndij= number of spin components
3653 : : !! nsppol=number of independent spin WF components
3654 : : !! pawang <type(pawang_type)>=paw angular mesh and related data
3655 : : !! pawrad <type(pawrad_type)>=paw radial mesh and related data, for current atom
3656 : : !! pawtab <type(pawtab_type)>=paw tabulated starting data, for current atom
3657 : : !! vpawx(1,lmn2_size,ndij)=moments of exact exchange potential
3658 : : !! for current atom and for correlated electrons
3659 : : !! vxc_ex(qphase*mesh_size,lm_size,nspden)=all-electron on-site XC potential for current atom
3660 : : !! taken into account only valence correlated electrons
3661 : : !!
3662 : : !! OUTPUT
3663 : : !! dijexxc(cplex_dij*lmn2_size,ndij)= D_ij^Exact-Exchange terms
3664 : : !! When Dij is complex (cplex_dij=2):
3665 : : !! dij(2*i-1,:) contains the real part, dij(2*i,:) contains the imaginary part
3666 : : !! When a exp(-i.q.r) phase is included (qphase=2):
3667 : : !! dij(1:cplex_dij*lmn2_size,:)
3668 : : !! contains the real part of the phase, i.e. D_ij*cos(q.r)
3669 : : !! dij(cplex_dij*lmn2_size+1:2*cplex_dij*lmn2_size,:)
3670 : : !! contains the imaginary part of the phase, i.e. D_ij*sin(q.r)
3671 : : !!
3672 : : !! SOURCE
3673 : :
3674 [ - + - + ]: 42 : subroutine pawdijexxc(dijexxc,cplex_dij,qphase,lmselect,ndij,nspden,nsppol,&
3675 [ - + - + ]: 42 : & pawang,pawrad,pawtab,vpawx,vxc_ex)
3676 : :
3677 : : !Arguments ---------------------------------------------
3678 : : !scalars
3679 : : integer,intent(in) :: cplex_dij,ndij,nspden,nsppol,qphase
3680 : : type(pawang_type),intent(in) :: pawang
3681 : : !arrays
3682 : : logical :: lmselect(:)
3683 : : real(dp),intent(in) :: vpawx(:,:,:),vxc_ex(:,:,:)
3684 : : real(dp),intent(out) :: dijexxc(:,:)
3685 : : type(pawrad_type),intent(in) :: pawrad
3686 : : type(pawtab_type),intent(in) :: pawtab
3687 : :
3688 : : !Local variables ---------------------------------------
3689 : : !scalars
3690 : : integer :: icount,idij,idijend,ij_size,iln,in1,in2,ir,ir1,isel,ispden,ivxc
3691 : : integer :: jln,j0ln,klm,klm1,klmn,klmn1,klmn2,kln,lexexch,ln_min,ln_max,lmax,lmin
3692 : : integer :: lm_size,lmn2_size,mesh_size,nsploop
3693 : : character(len=500) :: msg
3694 : : !arrays
3695 : 42 : real(dp),allocatable :: dijexxc_idij(:),ff(:),gg(:),vxcij1(:)
3696 : :
3697 : : ! *************************************************************************
3698 : :
3699 : : !Useful data
3700 : 42 : lm_size=pawtab%lcut_size**2
3701 : 42 : lmn2_size=pawtab%lmn2_size
3702 : 42 : ij_size=pawtab%ij_size
3703 : 42 : mesh_size=pawtab%mesh_size
3704 : 42 : lexexch=pawtab%lexexch
3705 : 42 : ln_min=pawtab%lnproju(1)
3706 : 42 : ln_max=pawtab%lnproju(pawtab%nproju)
3707 : :
3708 : : !Check data consistency
3709 [ - + ]: 42 : if (qphase==2) then
3710 : 0 : msg='pawdijexx not available for qphase=2!'
3711 : 0 : LIBPAW_BUG(msg)
3712 : : end if
3713 [ + - - + ]: 42 : if (size(dijexxc,1)/=cplex_dij*qphase*lmn2_size.or.size(dijexxc,2)/=ndij) then
3714 : 0 : msg='invalid sizes for dijexxc!'
3715 : 0 : LIBPAW_BUG(msg)
3716 : : end if
3717 [ - + ]: 42 : if (size(lmselect)/=lm_size) then
3718 : 0 : msg='invalid size for lmselect!'
3719 : 0 : LIBPAW_BUG(msg)
3720 : : end if
3721 [ + - + - : 42 : if (size(vxc_ex,1)/=qphase*mesh_size.or.size(vxc_ex,2)/=lm_size.or.&
- + ]
3722 : : & size(vxc_ex,3)/=nspden) then
3723 : 0 : msg='invalid sizes for vxc_ex!'
3724 : 0 : LIBPAW_BUG(msg)
3725 : : end if
3726 [ + - + - : 42 : if (size(vpawx,1)/=1.or.size(vpawx,2)/=lmn2_size.or.&
- + ]
3727 : : & size(vpawx,3)/=ndij) then
3728 : 0 : msg='invalid sizes for vpawx!'
3729 : 0 : LIBPAW_BUG(msg)
3730 : : end if
3731 : :
3732 : : !Init memory
3733 [ + + + + ]: 14490 : dijexxc=zero
3734 [ - + + - : 126 : LIBPAW_ALLOCATE(dijexxc_idij,(qphase*lmn2_size))
+ - + - -
+ - + ]
3735 [ - + + - : 126 : LIBPAW_ALLOCATE(vxcij1,(qphase*ij_size))
+ - + - -
+ - + ]
3736 [ - + + - : 126 : LIBPAW_ALLOCATE(ff,(mesh_size))
+ - + - -
+ - + ]
3737 [ - + + - : 84 : LIBPAW_ALLOCATE(gg,(mesh_size))
- + - + ]
3738 : :
3739 : : !----------------------------------------------------------
3740 : : !Loop over spin components
3741 : : !----------------------------------------------------------
3742 [ - + ]: 42 : nsploop=nsppol;if (ndij==4) nsploop=4
3743 [ + + ]: 84 : do idij=1,nsploop
3744 : :
3745 [ - + - - : 84 : if (idij<=nsppol.or.(ndij==4.and.idij<=3)) then
- - ]
3746 : :
3747 : 42 : idijend=idij+idij/3
3748 [ + + ]: 84 : do ispden=idij,idijend
3749 : :
3750 [ + + ]: 7224 : dijexxc_idij=zero
3751 : :
3752 : 42 : ivxc=ispden
3753 : : !Take into account nspden=1/nspinor=2 case
3754 [ + - - - ]: 42 : if (ndij/=nspden.and.ispden==2) ivxc=1
3755 [ - + - - ]: 42 : if (ndij/=nspden.and.ispden> 2) cycle
3756 : :
3757 : : ! ----------------------------------------------------------
3758 : : ! Summing over (l,m) moments
3759 : : ! ----------------------------------------------------------
3760 [ + + ]: 1092 : do klm=1,lm_size
3761 [ + + ]: 1092 : if (lmselect(klm)) then
3762 : :
3763 : : ! ===== Vxc_ij_1 (tmp) =====
3764 [ + + ]: 13420 : vxcij1=zero
3765 [ - + ]: 610 : if (qphase==1) then
3766 [ + + ]: 1830 : do jln=ln_min,ln_max
3767 : 1220 : j0ln=jln*(jln-1)/2
3768 [ + + ]: 3660 : do iln=ln_min,jln
3769 : 1830 : kln=j0ln+iln
3770 : : ff(1:mesh_size)= &
3771 [ + + ]: 1978230 : & vxc_ex(1:mesh_size,klm,ivxc)*pawtab%phiphj(1:mesh_size,kln)
3772 : 3050 : call simp_gen(vxcij1(kln),ff,pawrad)
3773 : : end do
3774 : : end do
3775 : : else
3776 [ # # ]: 0 : do jln=ln_min,ln_max
3777 : 0 : j0ln=jln*(jln-1)/2
3778 [ # # ]: 0 : do iln=ln_min,jln
3779 : 0 : kln=j0ln+iln
3780 [ # # ]: 0 : do ir=1,mesh_size
3781 : 0 : ir1=2*ir
3782 : : ff(ir)= &
3783 : 0 : & vxc_ex(ir1-1,klm,ivxc)*pawtab%phiphj(ir,kln)
3784 : : gg(ir)= &
3785 : 0 : & vxc_ex(ir1,klm,ivxc)*pawtab%phiphj(ir,kln)
3786 : : end do
3787 : 0 : call simp_gen(vxcij1(2*kln-1),ff,pawrad)
3788 : 0 : call simp_gen(vxcij1(2*kln ),gg,pawrad)
3789 : : end do
3790 : : end do
3791 : : end if
3792 : :
3793 : : ! ===== Accumulate Vxc_ij_1 over klm moments =====
3794 [ - + ]: 610 : if (qphase==1) then
3795 [ + + ]: 104920 : do klmn=1,lmn2_size
3796 : 104310 : lmin=pawtab%indklmn(3,klmn)
3797 : 104310 : lmax=pawtab%indklmn(4,klmn)
3798 [ + + + + ]: 104920 : if (lmin==0.and.lmax==2*lexexch) then
3799 : 33550 : klm1=pawtab%indklmn(1,klmn)
3800 : 33550 : kln=pawtab%indklmn(2,klmn)
3801 : 33550 : isel=pawang%gntselect(klm,klm1)
3802 [ + + ]: 33550 : if (isel>0) dijexxc_idij(klmn)=dijexxc_idij(klmn) &
3803 : 6350 : & +vxcij1(kln)*pawang%realgnt(isel)
3804 : : end if
3805 : : end do ! Loop klmn
3806 : : else ! qphase==2
3807 : : klmn1=1
3808 [ # # ]: 0 : do klmn=1,lmn2_size
3809 : 0 : lmin=pawtab%indklmn(3,klmn)
3810 : 0 : lmax=pawtab%indklmn(4,klmn)
3811 [ # # # # ]: 0 : if (lmin==0.and.lmax==2*lexexch) then
3812 : 0 : klm1=pawtab%indklmn(1,klmn)
3813 : 0 : kln=pawtab%indklmn(2,klmn)
3814 : 0 : isel=pawang%gntselect(klm,klm1)
3815 [ # # ]: 0 : if (isel>0) then
3816 : : dijexxc_idij(klmn1 )=dijexxc_idij(klmn1) &
3817 : 0 : & +vxcij1(2*kln-1)*pawang%realgnt(isel)
3818 : : dijexxc_idij(klmn1+1)=dijexxc_idij(klmn1+1) &
3819 : 0 : & +vxcij1(2*kln )*pawang%realgnt(isel)
3820 : : end if
3821 : : end if
3822 : 0 : klmn1=klmn1+qphase
3823 : : end do ! Loop klmn
3824 : : end if
3825 : :
3826 : : end if ! lmselect
3827 : : end do ! Loop klm
3828 : :
3829 : : ! Mix Hartree and GGA terms
3830 [ - + ]: 42 : if (qphase==1) then
3831 [ + + ]: 7224 : do klmn=1,lmn2_size
3832 : 7182 : lmin=pawtab%indklmn(3,klmn)
3833 : 7182 : lmax=pawtab%indklmn(4,klmn)
3834 [ + + + + ]: 7224 : if (lmin==0.and.lmax==2*lexexch) then
3835 : 2310 : in1=pawtab%klmntomn(3,klmn)
3836 : 2310 : in2=pawtab%klmntomn(4,klmn)
3837 : 2310 : icount=in1+(in2*(in2-1))/2
3838 [ - + ]: 2310 : if(pawtab%ij_proj<icount) then
3839 : 0 : msg='PAW local exact-exchange: Problem while computing dijexxc !'
3840 : 0 : LIBPAW_BUG(msg)
3841 : : end if
3842 : : dijexxc_idij(klmn)=pawtab%exchmix &
3843 : 2310 : & *(vpawx(1,klmn,idij)-dijexxc_idij(klmn))
3844 : : end if
3845 : : end do
3846 : : else ! qphase=2
3847 : : klmn1=1
3848 [ # # ]: 0 : do klmn=1,lmn2_size
3849 : 0 : lmin=pawtab%indklmn(3,klmn)
3850 : 0 : lmax=pawtab%indklmn(4,klmn)
3851 [ # # # # ]: 0 : if (lmin==0.and.lmax==2*lexexch) then
3852 : 0 : in1=pawtab%klmntomn(3,klmn)
3853 : 0 : in2=pawtab%klmntomn(4,klmn)
3854 : 0 : icount=in1+(in2*(in2-1))/2
3855 [ # # ]: 0 : if(pawtab%ij_proj<icount) then
3856 : 0 : msg='PAW local exact-exchange: Problem while computing dijexxc !'
3857 : 0 : LIBPAW_BUG(msg)
3858 : : end if
3859 : : dijexxc_idij(klmn1) =pawtab%exchmix &
3860 : 0 : & *(vpawx(1,klmn,idij)-dijexxc_idij(klmn1))
3861 : : dijexxc_idij(klmn1+1)=pawtab%exchmix &
3862 : 0 : & *(vpawx(1,klmn,idij)-dijexxc_idij(klmn1+1))
3863 : : end if
3864 : 0 : klmn1=klmn1+qphase
3865 : : end do ! Loop klmn
3866 : : end if
3867 : :
3868 : : ! ----------------------------------------------------------
3869 : : ! Deduce some part of Dij according to symmetries
3870 : : ! ----------------------------------------------------------
3871 : :
3872 : : !if ispden=1 => real part of D^11_ij
3873 : : !if ispden=2 => real part of D^22_ij
3874 : : !if ispden=3 => real part of D^12_ij
3875 : : !if ispden=4 => imaginary part of D^12_ij
3876 : 42 : klmn1=max(1,ispden-2);klmn2=1
3877 [ + + ]: 7224 : do klmn=1,lmn2_size
3878 : 7182 : dijexxc(klmn1,idij)=dijexxc_idij(klmn2)
3879 : 7182 : klmn1=klmn1+cplex_dij
3880 : 7224 : klmn2=klmn2+qphase
3881 : : end do
3882 [ - + ]: 84 : if (qphase==2) then
3883 : : !Same storage with exp^(-i.q.r) phase
3884 : 0 : klmn1=max(1,ispden-2)+lmn2_size*cplex_dij;klmn2=2
3885 [ # # ]: 0 : do klmn=1,lmn2_size
3886 : 0 : dijexxc(klmn1,idij)=dijexxc_idij(klmn2)
3887 : 0 : klmn1=klmn1+cplex_dij
3888 : 0 : klmn2=klmn2+qphase
3889 : : end do
3890 : : endif
3891 : :
3892 : : end do !ispden
3893 : :
3894 : : !Non-collinear: D_ij(:,4)=D^21_ij=D^12_ij^*
3895 [ # # # # ]: 0 : else if (nspden==4.and.idij==4) then
3896 [ # # ]: 0 : dijexxc(:,idij)=dijexxc(:,idij-1)
3897 [ # # ]: 0 : if (cplex_dij==2) then
3898 [ # # ]: 0 : do klmn=2,lmn2_size*cplex_dij,cplex_dij
3899 [ # # ]: 0 : dijexxc(klmn,idij)=-dijexxc(klmn,idij)
3900 : : end do
3901 [ # # ]: 0 : if (qphase==2) then
3902 [ # # ]: 0 : do klmn=2+lmn2_size*cplex_dij,2*lmn2_size*cplex_dij,cplex_dij
3903 [ # # ]: 0 : dijexxc(klmn,idij)=-dijexxc(klmn,idij)
3904 : : end do
3905 : : end if
3906 : : end if
3907 : :
3908 : : !Antiferro: D_ij(:,2)=D^down_ij=D^up_ij
3909 [ # # # # ]: 0 : else if (nsppol==1.and.idij==2) then
3910 [ # # ]: 0 : dijexxc(:,idij)=dijexxc(:,idij-1)
3911 : : end if
3912 : :
3913 : : !----------------------------------------------------------
3914 : : !End loop on spin density components
3915 : : end do
3916 : :
3917 : : !Free temporary memory spaces
3918 [ - + ]: 42 : LIBPAW_DEALLOCATE(dijexxc_idij)
3919 [ - + ]: 42 : LIBPAW_DEALLOCATE(vxcij1)
3920 [ - + ]: 42 : LIBPAW_DEALLOCATE(ff)
3921 [ - + ]: 42 : LIBPAW_DEALLOCATE(gg)
3922 : :
3923 : 42 : end subroutine pawdijexxc
3924 : : !!***
3925 : :
3926 : : !----------------------------------------------------------------------
3927 : :
3928 : : !!****f* m_pawdij/pawdijfr
3929 : : !!
3930 : : !! NAME
3931 : : !! pawdijfr
3932 : : !!
3933 : : !! FUNCTION
3934 : : !! PAW, Response Function only:
3935 : : !! Compute frozen part of psp strength Dij due to 1st-order compensation density
3936 : : !! and first order local potential:
3937 : : !! Dijfr =Int_R^3{vtrial*Sum_LM[Q_ij_q^LM^(1)] + Vloc^(1)*Sum_LM[Q_ij_q^LM]}
3938 : : !! Depends on q wave vector but not on first-order wave-function.
3939 : : !!
3940 : : !! INPUTS
3941 : : !! gprimd(3,3)=dimensional primitive translations for reciprocal space
3942 : : !! idir=direction of atomic displacement (in case of phonons perturb.)
3943 : : !! ipert=index of perturbation
3944 : : !! mpi_atmtab(:)=--optional-- indexes of the atoms treated by current proc
3945 : : !! comm_atom=--optional-- MPI communicator over atoms
3946 : : !! mpi_comm_grid=--optional-- MPI communicator over real space grid components
3947 : : !! my_natom=number of atoms treated by current processor
3948 : : !! natom=total number of atoms in cell
3949 : : !! nfft=(effective) number of FFT grid points (for this processor)
3950 : : !! nspden=number of spin-density components
3951 : : !! nsppol=number of independent spin WF components
3952 : : !! ntypat=number of types of atoms
3953 : : !! option=0: computes full frozen part of Dij
3954 : : !! 1: computes frozen part of Dij without contribution from Vpsp1
3955 : : !! pawang <type(pawang_type)>=paw angular mesh and related data
3956 : : !! pawfgrtab(my_natom) <type(pawfgrtab_type)>=atomic data given on fine rectangular grid
3957 : : !! pawrad(ntypat*usepaw) <type(pawrad_type)>=paw radial mesh and related data
3958 : : !! pawtab(ntypat) <type(pawtab_type)>=paw tabulated starting data
3959 : : !! qphase=2 if dij contains a exp(-i.q.r) phase (as in the q<>0 RF case), 1 if not
3960 : : !! qphon(3)=wavevector of the phonon
3961 : : !! rprimd(3,3)=dimensional primitive translations for real space
3962 : : !! ucvol=unit cell volume (bohr^3)
3963 : : !! vpsp1(qphase*nfft)= first-order change of local potential
3964 : : !! vtrial(nfft,nspden)= total GS potential
3965 : : !! vxc(nfft,nspden)=XC potential
3966 : : !! xred(3,my_natom)= reduced atomic coordinates
3967 : : !!
3968 : : !! OUTPUT
3969 : : !! paw_ij1(iatom)%dijfr(cplex_dij*qphase*lmn2_size,nspden)=
3970 : : !! frozen contribution to psp strength Dij
3971 : : !! =Int_R^3{vtrial*Sum_LM[Q_ij_q^LM^(1)] + Vloc^(1)*Sum_LM[Q_ij_q^LM]}
3972 : : !! When Dij is complex (cplex_dij=2):
3973 : : !! dij(2*i-1,:) contains the real part, dij(2*i,:) contains the imaginary part
3974 : : !! When a exp(-i.q.r) phase is included (qphase=2):
3975 : : !! dij(1:cplex_dij*lmn2_size,:)
3976 : : !! contains the real part of the phase, i.e. D_ij*cos(q.r)
3977 : : !! dij(cplex_dij*lmn2_size+1:2*cplex_dij*lmn2_size,:)
3978 : : !! contains the imaginary part of the phase, i.e. D_ij*sin(q.r)
3979 : : !!
3980 : : !! SOURCE
3981 : :
3982 : 3981 : subroutine pawdijfr(gprimd,idir,ipert,my_natom,natom,nfft,ngfft,nspden,nsppol,ntypat,&
3983 : 3981 : & option,paw_ij1,pawang,pawfgrtab,pawrad,pawtab,qphase,qphon,rprimd,ucvol,&
3984 : 3981 : & vpsp1,vtrial,vxc,xred,&
3985 [ + - + + : 3981 : & mpi_atmtab,comm_atom,mpi_comm_grid) ! optional arguments (parallelism)
- + ]
3986 : :
3987 : : !Arguments ------------------------------------
3988 : : !scalars
3989 : : integer,intent(in) :: idir,ipert,my_natom,natom,nfft,nspden,nsppol,ntypat,option,qphase
3990 : : integer,optional,intent(in) :: comm_atom,mpi_comm_grid
3991 : : real(dp),intent(in) :: ucvol
3992 : : type(pawang_type),intent(in) :: pawang
3993 : : !arrays
3994 : : integer,intent(in) :: ngfft(18)
3995 : : integer,optional,target,intent(in) :: mpi_atmtab(:)
3996 : : real(dp),intent(in) :: gprimd(3,3),qphon(3),rprimd(3,3)
3997 : : real(dp),intent(in) :: vpsp1(qphase*nfft),vtrial(nfft,nspden),vxc(nfft,nspden)
3998 : : real(dp),intent(in) :: xred(3,natom)
3999 : : type(paw_ij_type),intent(inout) :: paw_ij1(my_natom)
4000 : : type(pawfgrtab_type),intent(inout) :: pawfgrtab(my_natom)
4001 : : type(pawrad_type),intent(in) :: pawrad(ntypat)
4002 : : type(pawtab_type),intent(in) :: pawtab(ntypat)
4003 : :
4004 : : !Local variables-------------------------------
4005 : : !scalars
4006 : : integer :: cplex_dij,cplex_nspden,cplex_p1,iatom,iatom_tot,ic,idij,idijend,ier,ils,ilslm,isel
4007 : : integer :: ispden,istr,itypat,jc,klm,klmn,klmn1,klmn2,kln,lm_size,lmn2_size,lm0,lmax,lmin,mesh_size
4008 : : integer :: mm,my_comm_atom,my_comm_grid,mu,mua,mub,ndij,nfftot,nfgd,nsploop
4009 : : integer :: optgr0,optgr1,optgr2,usexcnhat
4010 : : logical :: has_qphase,my_atmtab_allocated,need_dijfr_1,need_dijfr_2,need_dijfr_3,need_dijfr_4
4011 : : logical :: paral_atom,qne0,testdij1,testdij2,testdij3
4012 : : real(dp) :: c1,fact,intg,rg1
4013 : : character(len=500) :: msg
4014 : : !arrays
4015 : : integer,parameter :: m_index(3)=(/1,-1,0/)
4016 : 3981 : integer,pointer :: my_atmtab(:)
4017 : : integer,parameter :: alpha(9)=(/1,2,3,3,3,2,2,1,1/),beta(9)=(/1,2,3,2,1,1,3,3,2/)
4018 : : real(dp) :: contrib(2)
4019 : 3981 : real(dp),allocatable :: ff(:),intv(:,:),intv1(:,:),intv2(:,:),intvloc(:,:),intv_tmp(:,:)
4020 : 3981 : real(dp),allocatable :: rg(:),vloc(:,:)
4021 : :
4022 : : ! *************************************************************************
4023 : :
4024 : : !Nothing to be done for DDK
4025 [ + + ]: 3840 : if (ipert==natom+1.or.ipert==natom+10) return
4026 : :
4027 : : !Set up parallelism over atoms
4028 [ + - + + ]: 3820 : paral_atom=(present(comm_atom).and.(my_natom/=natom))
4029 [ + + ]: 3820 : nullify(my_atmtab);if (present(mpi_atmtab)) my_atmtab => mpi_atmtab
4030 [ + - ]: 3820 : my_comm_atom=xmpi_comm_self;if (present(comm_atom)) my_comm_atom=comm_atom
4031 [ - + ]: 3820 : my_comm_grid=xmpi_comm_self;if (present(mpi_comm_grid)) my_comm_grid=mpi_comm_grid
4032 : 3820 : call get_my_atmtab(my_comm_atom,my_atmtab,my_atmtab_allocated,paral_atom,natom,my_natom_ref=my_natom)
4033 : :
4034 : : !Compatibility tests
4035 : 3820 : qne0=(qphon(1)**2+qphon(2)**2+qphon(3)**2>=1.d-15)
4036 [ + + ]: 3820 : if (my_natom>0) then
4037 [ + + - + ]: 3778 : if (qne0.and.qphase==1) then
4038 : 0 : msg='qphase must be 2 when q<>0!'
4039 : 0 : LIBPAW_BUG(msg)
4040 : : end if
4041 [ - + ]: 3778 : if (paw_ij1(1)%qphase/=qphase) then
4042 : 0 : msg='paw_ij1()%qphase and qphase must be equal !'
4043 : 0 : LIBPAW_BUG(msg)
4044 : : end if
4045 [ - + ]: 3778 : if (paw_ij1(1)%has_dijfr==0) then
4046 : 0 : msg='pawdij1()%dijfr must be allocated !'
4047 : 0 : LIBPAW_BUG(msg)
4048 : : end if
4049 [ + + + + : 3778 : testdij1=(ipert<=natom.and.option==0.and.pawfgrtab(1)%gylm_allocated==0)
+ - ]
4050 [ + + - + ]: 3778 : testdij2=(ipert<=natom.and.pawfgrtab(1)%gylmgr_allocated==0)
4051 [ # # # # ]: 0 : testdij3=(testdij2.and.qne0.and.pawfgrtab(1)%expiqr_allocated==0)
4052 [ + - - + : 3778 : if ((testdij1.or.testdij2.or.testdij3).and.pawfgrtab(1)%rfgd_allocated==0) then
- - ]
4053 : 0 : msg='pawfgrtab()%rfgd array must be allocated !'
4054 : 0 : LIBPAW_BUG(msg)
4055 : : end if
4056 : : end if
4057 : :
4058 : : !Get correct index of strain perturbation
4059 [ + + ]: 3820 : if (ipert==natom+3) istr = idir
4060 [ + + ]: 3820 : if (ipert==natom+4) istr = idir + 3
4061 : :
4062 : : !Some inits
4063 [ + + ]: 11283 : usexcnhat=maxval(pawtab(1:ntypat)%usexcnhat)
4064 : 3820 : nfftot=ngfft(1)*ngfft(2)*ngfft(3)
4065 : 3820 : fact=ucvol/dble(nfftot)
4066 [ - + ]: 3820 : cplex_nspden=merge(1,2,nspden/=4)
4067 : :
4068 : : !Loops over atoms
4069 [ + + ]: 11807 : do iatom=1,my_natom
4070 [ + + ]: 7987 : iatom_tot=iatom;if (paral_atom) iatom_tot=my_atmtab(iatom)
4071 : :
4072 : : ! Select which part of Dijfr to compute
4073 [ + + - + ]: 7987 : need_dijfr_1=(ipert==iatom_tot.and.paw_ij1(iatom)%has_dijfr==1)
4074 [ + + + - : 7987 : need_dijfr_2=(ipert<=natom.and.paw_ij1(iatom)%has_dijfr==1.and.(option==0))
+ + ]
4075 [ + + + + : 7987 : need_dijfr_3=((ipert==natom+2.or.ipert==natom+11).and.paw_ij1(iatom)%has_dijfr==1)
- + ]
4076 [ + + + + : 7987 : need_dijfr_4=((ipert==natom+3.or.ipert==natom+4).and.paw_ij1(iatom)%has_dijfr==1)
- + ]
4077 : :
4078 [ + + + + ]: 7987 : if ((.not.need_dijfr_1).and.(.not.need_dijfr_2).and.(.not.need_dijfr_3).and.(.not.need_dijfr_4)) then
4079 [ + - ]: 73 : if (paw_ij1(iatom)%has_dijfr>0) then
4080 [ + + + + ]: 2774 : paw_ij1(iatom)%dijfr=zero ; paw_ij1(iatom)%has_dijfr=2
4081 : : end if
4082 : : cycle
4083 : : end if
4084 : :
4085 : : ! Some atom-dependent quantities
4086 : 7914 : itypat=pawfgrtab(iatom)%itypat
4087 : 7914 : lm_size=pawtab(itypat)%lcut_size**2
4088 : 7914 : lmn2_size=pawtab(itypat)%lmn2_size
4089 : 7914 : cplex_dij=paw_ij1(iatom)%cplex_dij
4090 : 7914 : ndij=paw_ij1(iatom)%ndij
4091 : :
4092 : : ! Eventually compute g_l(r).Y_lm(r) factors for the current atom (if not already done)
4093 : 7914 : nfgd=0
4094 [ + + + + ]: 7914 : if (need_dijfr_1.or.need_dijfr_2.or.need_dijfr_4) then
4095 : 6382 : nfgd=pawfgrtab(iatom)%nfgd
4096 [ + + + - : 6382 : if (((need_dijfr_2.or.need_dijfr_4).and.(pawfgrtab(iatom)%gylm_allocated==0)).or.&
+ + - + ]
4097 : : & ((need_dijfr_1).and.(pawfgrtab(iatom)%gylmgr_allocated==0))) then
4098 : 0 : optgr0=0;optgr1=0;optgr2=0
4099 [ # # # # ]: 0 : if ((need_dijfr_2.or. need_dijfr_4).and.(pawfgrtab(iatom)%gylm_allocated==0)) then
4100 [ # # ]: 0 : if (allocated(pawfgrtab(iatom)%gylm)) then
4101 : 0 : LIBPAW_DEALLOCATE(pawfgrtab(iatom)%gylm)
4102 : : end if
4103 [ # # # # : 0 : LIBPAW_ALLOCATE(pawfgrtab(iatom)%gylm,(nfgd,lm_size))
# # # # #
# # # # #
# # # # ]
4104 : 0 : pawfgrtab(iatom)%gylm_allocated=2;optgr0=1
4105 : : end if
4106 [ # # # # ]: 0 : if ((need_dijfr_1.or.need_dijfr_4).and.(pawfgrtab(iatom)%gylmgr_allocated==0)) then
4107 [ # # ]: 0 : if (allocated(pawfgrtab(iatom)%gylmgr)) then
4108 : 0 : LIBPAW_DEALLOCATE(pawfgrtab(iatom)%gylmgr)
4109 : : end if
4110 [ # # # # : 0 : LIBPAW_ALLOCATE(pawfgrtab(iatom)%gylmgr,(3,nfgd,lm_size))
# # # # #
# # # # #
# # # # ]
4111 : 0 : pawfgrtab(iatom)%gylmgr_allocated=2;optgr1=1
4112 : : end if
4113 [ # # ]: 0 : if (optgr0+optgr1+optgr2>0) then
4114 : : call pawgylm(pawfgrtab(iatom)%gylm,pawfgrtab(iatom)%gylmgr,pawfgrtab(iatom)%gylmgr2,&
4115 : 0 : & lm_size,nfgd,optgr0,optgr1,optgr2,pawtab(itypat),pawfgrtab(iatom)%rfgd)
4116 : : end if
4117 : : end if
4118 : : end if
4119 : :
4120 : : ! Eventually compute exp(-i.q.r) factors for the current atom (if not already done)
4121 [ + + - + ]: 7914 : has_qphase=(qne0.and.qphase==2)
4122 [ + + ]: 7914 : if (need_dijfr_2) then
4123 [ + + - + ]: 4915 : if (has_qphase.and.(pawfgrtab(iatom)%expiqr_allocated==0)) then
4124 [ # # ]: 0 : if (allocated(pawfgrtab(iatom)%expiqr)) then
4125 : 0 : LIBPAW_DEALLOCATE(pawfgrtab(iatom)%expiqr)
4126 : : end if
4127 [ # # # # : 0 : LIBPAW_ALLOCATE(pawfgrtab(iatom)%expiqr,(2,nfgd))
# # # # #
# # # #
# ]
4128 : : call pawexpiqr(pawfgrtab(iatom)%expiqr,gprimd,nfgd,qphon,&
4129 : 0 : & pawfgrtab(iatom)%rfgd,xred(:,iatom_tot))
4130 : 0 : pawfgrtab(iatom)%expiqr_allocated=2
4131 : : end if
4132 : 4915 : has_qphase=(pawfgrtab(iatom)%expiqr_allocated/=0)
4133 : : end if
4134 : :
4135 : : ! Loop over spin components
4136 [ - + ]: 7914 : nsploop=nsppol;if (ndij==4) nsploop=4
4137 [ + + ]: 16674 : do idij=1,nsploop
4138 [ - + - - : 16674 : if (idij<=nsppol.or.(nspden==4.and.idij<=3)) then
- - ]
4139 : :
4140 : 8760 : idijend=idij+idij/3
4141 [ + + ]: 17520 : do ispden=idij,idijend
4142 : :
4143 [ - + + - : 35040 : LIBPAW_ALLOCATE(intv,(qphase*cplex_nspden,lm_size))
- + + - +
- + - - +
- + - + ]
4144 [ + + + + ]: 173184 : intv(:,:) = zero
4145 : :
4146 : : ! ============ Phonons ====================================
4147 [ + + ]: 8760 : if (ipert<=natom) then
4148 : :
4149 [ + - ]: 5274 : if (need_dijfr_1.or.need_dijfr_2) then
4150 : :
4151 [ - + + - : 21096 : LIBPAW_ALLOCATE(intv1,(cplex_nspden,lm_size))
- + + - +
- + - - +
- + ]
4152 [ - + + - : 21096 : LIBPAW_ALLOCATE(intv2,(qphase,lm_size))
- + + - +
- + - - +
- + ]
4153 [ + + + + : 202554 : intv1(:,:)=zero ; intv2(:,:)=zero
+ + + + ]
4154 : :
4155 : : ! First part: Int_R^3{vtrial*Sum_LM[Q_ij_q^LM^(1)]}
4156 [ + + ]: 5274 : if (need_dijfr_1) then
4157 : :
4158 : : ! ----- Retrieve potential Vlocal (subtle if nspden=4 ;-)
4159 [ - + + - : 6336 : LIBPAW_ALLOCATE(vloc,(cplex_nspden,nfgd))
- + + - +
- + - - +
- + ]
4160 [ + - ]: 1584 : if (nspden/=4) then
4161 [ + + ]: 1584 : if (usexcnhat==0) then
4162 [ + + ]: 715057 : do ic=1,nfgd
4163 : 714380 : jc=pawfgrtab(iatom)%ifftsph(ic)
4164 : 715057 : vloc(1,ic)=vtrial(jc,ispden)-vxc(jc,ispden)
4165 : : end do
4166 : : else
4167 [ + + ]: 857673 : do ic=1,nfgd
4168 : 857673 : vloc(1,ic)=vtrial(pawfgrtab(iatom)%ifftsph(ic),ispden)
4169 : : end do
4170 : : end if
4171 : : else ! nspden==4
4172 [ # # ]: 0 : if (ispden<=2) then
4173 [ # # ]: 0 : if (usexcnhat==0) then
4174 [ # # ]: 0 : do ic=1,nfgd
4175 : 0 : jc=pawfgrtab(iatom)%ifftsph(ic)
4176 : 0 : vloc(1,ic)=vtrial(jc,ispden)-vxc(jc,ispden)
4177 : 0 : vloc(2,ic)=zero
4178 : : end do
4179 : : else
4180 [ # # ]: 0 : do ic=1,nfgd
4181 : 0 : jc=pawfgrtab(iatom)%ifftsph(ic)
4182 : 0 : vloc(1,ic)=vtrial(jc,ispden)
4183 : 0 : vloc(2,ic)=zero
4184 : : end do
4185 : : end if
4186 [ # # ]: 0 : else if (ispden==3) then
4187 [ # # ]: 0 : if (usexcnhat==0) then
4188 [ # # # # ]: 0 : vloc(:,:)=zero
4189 : : else
4190 [ # # ]: 0 : do ic=1,nfgd
4191 : 0 : jc=pawfgrtab(iatom)%ifftsph(ic)
4192 : 0 : vloc(1,ic)=vtrial(jc,3)
4193 : 0 : vloc(2,ic)=vtrial(jc,4)
4194 : : end do
4195 : : end if
4196 : : else ! ispden=4
4197 [ # # ]: 0 : vloc(2,1:nfgd)=-vloc(2,1:nfgd)
4198 : : end if
4199 : : end if
4200 : :
4201 : : ! ----- Compute Integral [ Vtrial(r).(g_l(r).Y_lm(r))^(1) dr ]
4202 [ - + + - : 3168 : LIBPAW_ALLOCATE(intv_tmp,(cplex_nspden,3))
- + - + ]
4203 [ + + ]: 16560 : do ilslm=1,lm_size
4204 [ + + + + ]: 104832 : intv_tmp=zero
4205 [ + + ]: 18243114 : do ic=1,nfgd
4206 [ + + ]: 72927528 : do mu=1,3
4207 : : ! Minus sign because dg(r-R)/dR = -dg(r-R)/dr
4208 [ + + ]: 109368828 : contrib(1:cplex_nspden)=-vloc(1:cplex_nspden,ic)*pawfgrtab(iatom)%gylmgr(mu,ic,ilslm)
4209 [ + + ]: 127596966 : intv_tmp(1:cplex_nspden,mu)=intv_tmp(1:cplex_nspden,mu)+contrib(1:cplex_nspden)
4210 : : end do
4211 : : end do
4212 : : ! Convert from cartesian to reduced coordinates
4213 : : intv1(1:cplex_nspden,ilslm)=intv1(1:cplex_nspden,ilslm) &
4214 : : & +(rprimd(1,idir)*intv_tmp(1:cplex_nspden,1) &
4215 : : & +rprimd(2,idir)*intv_tmp(1:cplex_nspden,2) &
4216 [ + + ]: 31536 : & +rprimd(3,idir)*intv_tmp(1:cplex_nspden,3))
4217 : : end do
4218 [ - + ]: 1584 : LIBPAW_DEALLOCATE(vloc)
4219 [ - + ]: 1584 : LIBPAW_DEALLOCATE(intv_tmp)
4220 : : end if ! need_dijfr_1
4221 : :
4222 : : ! 2nd part: Int_R^3{Vloc^(1)*Sum_LM[Q_ij_q^LM]}
4223 [ + + ]: 5274 : if (need_dijfr_2) then
4224 : :
4225 [ + + ]: 5247 : if (ispden==1) then
4226 : :
4227 : : ! ----- Retrieve potential Vloc^(1)
4228 [ - + + - : 19660 : LIBPAW_ALLOCATE(vloc,(qphase,nfgd))
- + + - +
- + - - +
- + ]
4229 [ + + ]: 4915 : if (qphase==1) then
4230 [ + + ]: 4001184 : do ic=1,nfgd
4231 : 3996569 : jc=qphase*pawfgrtab(iatom)%ifftsph(ic)
4232 : 4001184 : vloc(1,ic)=vpsp1(jc)
4233 : : end do
4234 : : else
4235 [ + + ]: 481812 : do ic=1,nfgd
4236 : 481512 : jc=2*pawfgrtab(iatom)%ifftsph(ic)-1
4237 : 481512 : vloc(1,ic)=vpsp1(jc )
4238 : 481812 : vloc(2,ic)=vpsp1(jc+1)
4239 : : end do
4240 : : end if
4241 : :
4242 : : ! ----- Compute Integral [ Vloc^(1)(r).g_l(r).Y_lm(r) ]
4243 [ - + + - : 14745 : LIBPAW_ALLOCATE(intvloc,(qphase,lm_size))
- + + - -
+ - + -
+ ]
4244 [ + + + + ]: 98005 : intvloc=zero
4245 [ + + ]: 4915 : if (has_qphase) then
4246 [ - + ]: 300 : if (qphase==1) then
4247 [ # # ]: 0 : do ilslm=1,lm_size
4248 [ # # ]: 0 : do ic=1,nfgd
4249 : 0 : contrib(1)=vloc(1,ic)*pawfgrtab(iatom)%gylm(ic,ilslm)
4250 : 0 : intvloc(1,ilslm)=intvloc(1,ilslm)+contrib(1)*pawfgrtab(iatom)%expiqr(1,ic)
4251 : : end do
4252 : : end do
4253 : : else
4254 [ + + ]: 3192 : do ilslm=1,lm_size
4255 [ + + ]: 4944672 : do ic=1,nfgd
4256 [ + + ]: 14824440 : contrib(1:2)=vloc(1:2,ic)*pawfgrtab(iatom)%gylm(ic,ilslm)
4257 : : intvloc(1,ilslm)=intvloc(1,ilslm)+contrib(1)*pawfgrtab(iatom)%expiqr(1,ic) &
4258 : 4941480 : & -contrib(2)*pawfgrtab(iatom)%expiqr(2,ic)
4259 : : intvloc(2,ilslm)=intvloc(2,ilslm)+contrib(1)*pawfgrtab(iatom)%expiqr(2,ic) &
4260 : 4944372 : & +contrib(2)*pawfgrtab(iatom)%expiqr(1,ic)
4261 : : end do
4262 : : end do
4263 : : end if
4264 : : else ! no phase
4265 [ + + ]: 46822 : do ilslm=1,lm_size
4266 [ + + ]: 41760103 : do ic=1,nfgd
4267 : : #if defined FC_NVHPC
4268 : : if (my_natom == -1) write(std_out, *)"NVHPC raises an internal compiler error that is fixed by this print statement."
4269 : : #endif
4270 [ + + ]: 83426562 : contrib(1:qphase)=vloc(1:qphase,ic)*pawfgrtab(iatom)%gylm(ic,ilslm)
4271 [ + + ]: 83468769 : intvloc(1:qphase,ilslm)=intvloc(1:qphase,ilslm)+contrib(1:qphase)
4272 : : end do
4273 : : end do
4274 : : end if
4275 [ - + ]: 4915 : LIBPAW_DEALLOCATE(vloc)
4276 : : end if ! ispden=1
4277 : :
4278 : : !Add to previous contribution
4279 [ - + ]: 5247 : if (ispden<=min(nspden,2)) then
4280 [ + + + + ]: 104997 : intv2(1:qphase,1:lm_size)=intv2(1:qphase,1:lm_size)+intvloc(1:qphase,1:lm_size)
4281 [ + + ]: 5247 : if (ispden==min(nspden,2)) then
4282 [ - + ]: 4915 : LIBPAW_DEALLOCATE(intvloc)
4283 : : end if
4284 : : end if
4285 : : end if ! need_dijfr_2
4286 : :
4287 : : ! Sum contributions and apply ucvol/nfft factor on integral
4288 [ + + + + ]: 102318 : intv(1:cplex_nspden,1:lm_size)=intv1(1:cplex_nspden,1:lm_size)
4289 [ + + ]: 53796 : intv(1,1:lm_size)=intv(1,1:lm_size)+intv2(1,1:lm_size)
4290 [ + + + + ]: 8466 : if (qphase==2) intv(cplex_nspden+1,1:lm_size)=intv(cplex_nspden+1,1:lm_size)+intv2(2,1:lm_size)
4291 [ + + + + ]: 105510 : intv(:,:)=fact*intv(:,:)
4292 [ - + ]: 5274 : LIBPAW_DEALLOCATE(intv1)
4293 [ - + ]: 5274 : LIBPAW_DEALLOCATE(intv2)
4294 : :
4295 : : ! --- Reduction in case of parallelization ---
4296 : 5274 : call xmpi_sum(intv,my_comm_grid,ier)
4297 : :
4298 [ + + ]: 219678 : paw_ij1(iatom)%dijfr(:,ispden)=zero
4299 : :
4300 : : ! ---- Loop over (i,j) components
4301 : 5274 : klmn1=1;klmn2=1+lmn2_size*cplex_dij ; cplex_p1=cplex_nspden+1
4302 [ + + ]: 205206 : do klmn=1,lmn2_size
4303 : 199932 : klm =pawtab(itypat)%indklmn(1,klmn)
4304 : 199932 : lmin=pawtab(itypat)%indklmn(3,klmn)
4305 : 199932 : lmax=pawtab(itypat)%indklmn(4,klmn)
4306 [ - + + + ]: 522510 : do ils=lmin,lmax,2
4307 : 322578 : lm0=ils**2+ils+1
4308 [ + + ]: 1499604 : do mm=-ils,ils
4309 : 977094 : ilslm=lm0+mm;isel=pawang%gntselect(ilslm,klm)
4310 [ + + ]: 1299672 : if (isel>0) then
4311 : : !The following works only because cplex_nspden<=cplex_dij
4312 : : paw_ij1(iatom)%dijfr(klmn1,ispden)=paw_ij1(iatom)%dijfr(klmn1,ispden) &
4313 : 290526 : & +pawtab(itypat)%qijl(ilslm,klmn)*intv(1,ilslm)
4314 [ - + ]: 290526 : if (cplex_nspden==2) then
4315 : : paw_ij1(iatom)%dijfr(klmn1+1,ispden)=paw_ij1(iatom)%dijfr(klmn1+1,ispden) &
4316 : 0 : & +pawtab(itypat)%qijl(ilslm,klmn)*intv(2,ilslm)
4317 : : end if
4318 [ + + ]: 290526 : if (qphase==2) then
4319 : : paw_ij1(iatom)%dijfr(klmn2,ispden)=paw_ij1(iatom)%dijfr(klmn2,ispden) &
4320 : 23184 : & +pawtab(itypat)%qijl(ilslm,klmn)*intv(cplex_p1,ilslm)
4321 [ - + ]: 23184 : if (cplex_nspden==2) then
4322 : : paw_ij1(iatom)%dijfr(klmn2+1,ispden)=paw_ij1(iatom)%dijfr(klmn2+1,ispden) &
4323 : 0 : & +pawtab(itypat)%qijl(ilslm,klmn)*intv(4,ilslm)
4324 : : end if
4325 : : end if
4326 : : !Previous version
4327 : : ! dplex_nsp=cplex_nspden-1
4328 : : ! paw_ij1(iatom)%dijfr(klmn1:klmn1+dplex_nsp,ispden)= &
4329 : : ! & paw_ij1(iatom)%dijfr(klmn1:klmn1+dplex_nsp,ispden) &
4330 : : ! & +pawtab(itypat)%qijl(ilslm,klmn)*intv(1:cplex_nspden,ilslm)
4331 : : ! if (qphase==2) then
4332 : : ! paw_ij1(iatom)%dijfr(klmn2:klmn2+dplex_nsp,ispden)= &
4333 : : ! & paw_ij1(iatom)%dijfr(klmn2:klmn2+dplex_nsp,ispden) &
4334 : : ! & +pawtab(itypat)%qijl(ilslm,klmn)*intv(1+cplex_nspden:2*cplex_nspden,ilslm)
4335 : : ! end if
4336 : : end if
4337 : : end do
4338 : : end do
4339 : 205206 : klmn1=klmn1+cplex_dij;klmn2=klmn2+cplex_dij
4340 : : end do
4341 : :
4342 : : ! Dijfr is marked as computed
4343 : 10548 : paw_ij1(iatom)%has_dijfr=2
4344 : :
4345 : : end if
4346 : :
4347 : : ! ============ Electric field perturbation =======================
4348 [ + + + + ]: 3486 : else if (ipert==natom+2.or.ipert==natom+11) then
4349 : :
4350 [ + - ]: 1974 : if (need_dijfr_3) then
4351 : :
4352 : : ! The following factor arises in expanding the angular dependence of the dipole
4353 : : ! vector in terms of real spherical harmonics. The real spherical harmonics are as
4354 : : ! in the routine initylmr.F90;
4355 : : ! see http://www.unioviedo.es/qcg/art/Theochem419-19-ov-BF97-rotation-matrices.pdf
4356 : 1974 : c1 = sqrt(four_pi/three)
4357 : 1974 : mesh_size=pawtab(itypat)%mesh_size
4358 : :
4359 [ + + ]: 1974 : if (ispden==1) then
4360 : :
4361 [ - + + - : 4596 : LIBPAW_ALLOCATE(ff,(mesh_size))
+ - + - -
+ - + -
+ ]
4362 [ - + ]: 1532 : LIBPAW_ALLOCATE(rg,(3))
4363 : :
4364 : : ! loop over basis state pairs for this atom
4365 : 1532 : klmn1=1
4366 [ + + ]: 62594 : do klmn = 1, paw_ij1(iatom)%lmn2_size
4367 : 61062 : klm =pawtab(itypat)%indklmn(1,klmn)
4368 : 61062 : kln =pawtab(itypat)%indklmn(2,klmn)
4369 : 61062 : lmin=pawtab(itypat)%indklmn(3,klmn)
4370 : 61062 : lmax=pawtab(itypat)%indklmn(4,klmn)
4371 : :
4372 : : ! Select only l=1, because the dipole is a vector operator
4373 [ + + ]: 61062 : if (lmin==1) then
4374 : 20769 : lm0=3 ! (l^2+l+1) for l=1
4375 : :
4376 : : ! Computation of <phi_i|r|phi_j>- <tphi_i|r|tphi_j>
4377 : : ! the dipole vector has radial dependence r
4378 : : ff(1:mesh_size)=(pawtab(itypat)%phiphj(1:mesh_size,kln)&
4379 : : & -pawtab(itypat)%tphitphj(1:mesh_size,kln))&
4380 [ + + ]: 18787425 : & *pawrad(itypat)%rad(1:mesh_size)
4381 : : ! call pawrad_deducer0(ff,mesh_size,pawrad(itypat))
4382 : 20769 : call simp_gen(intg,ff,pawrad(itypat))
4383 : :
4384 : : ! Compute <S_li_mi|r-R|S_lj_mj>: use a real Gaunt expression (with selection rule)
4385 [ + + ]: 83076 : rg(1:3)=zero
4386 [ + + ]: 83076 : do ic=1,3
4387 : 62307 : isel=pawang%gntselect(lm0+m_index(ic),klm)
4388 [ + + ]: 83076 : if (isel>0) rg(ic)=pawang%realgnt(isel)
4389 : : end do
4390 : :
4391 : : ! Translate from cartesian to reduced coordinates (in idir direction)
4392 : 20769 : rg1=gprimd(1,idir)*rg(1)+gprimd(2,idir)*rg(2)+gprimd(3,idir)*rg(3)
4393 : :
4394 : : ! Build sqrt(4pi/3).<S_li_mi|r-R|S_lj_mj>.(<phi_i|r-R|phi_j>- <tphi_i|r-R|tphi_j>
4395 : 20769 : paw_ij1(iatom)%dijfr(klmn1,ispden)=c1*rg1*intg
4396 [ - + ]: 20769 : if (cplex_dij==2) paw_ij1(iatom)%dijfr(klmn1+1,ispden)=zero
4397 : :
4398 : : else
4399 : 40293 : paw_ij1(iatom)%dijfr(klmn1,ispden)=zero
4400 : : end if ! end gaunt constraint
4401 : :
4402 : 62594 : klmn1=klmn1+cplex_dij
4403 : : end do ! end loop over lmn2_size pairs of basis states
4404 [ - + ]: 1532 : LIBPAW_DEALLOCATE(ff)
4405 [ - + ]: 1532 : LIBPAW_DEALLOCATE(rg)
4406 : :
4407 : : ! Dijfr is spin-independent for electric field case
4408 [ + - ]: 442 : else if (ispden==2) then
4409 [ + + ]: 16354 : paw_ij1(iatom)%dijfr(:,ispden)=paw_ij1(iatom)%dijfr(:,1)
4410 : : else
4411 [ # # ]: 0 : paw_ij1(iatom)%dijfr(:,ispden)=zero
4412 : : end if
4413 : :
4414 : : ! Dijfr is marked as computed
4415 : 1974 : paw_ij1(iatom)%has_dijfr=2
4416 : : end if
4417 : :
4418 : : ! ============ Elastic tensor ===============================
4419 [ + + - + ]: 1512 : else if (ipert==natom+3.or.ipert==natom+4) then
4420 : :
4421 : : ! ----- Retrieve potential Vlocal (subtle if nspden=4 ;-)
4422 [ - + + - : 6048 : LIBPAW_ALLOCATE(vloc,(cplex_nspden,nfgd))
- + + - +
- + - - +
- + ]
4423 [ + - ]: 1512 : if (nspden/=4) then
4424 [ + + ]: 1512 : if (usexcnhat==0) then
4425 [ + + ]: 501426 : do ic=1,nfgd
4426 : 501012 : jc=pawfgrtab(iatom)%ifftsph(ic)
4427 : 501426 : vloc(1,ic)=vtrial(jc,ispden)-vxc(jc,ispden)
4428 : : end do
4429 : : else
4430 [ + + ]: 886812 : do ic=1,nfgd
4431 : 886812 : vloc(1,ic)=vtrial(pawfgrtab(iatom)%ifftsph(ic),ispden)
4432 : : end do
4433 : : end if
4434 : : else ! nspden/=4
4435 [ # # ]: 0 : if (ispden<=2) then
4436 [ # # ]: 0 : if (usexcnhat==0) then
4437 [ # # ]: 0 : do ic=1,nfgd
4438 : 0 : jc=pawfgrtab(iatom)%ifftsph(ic)
4439 : 0 : vloc(1,ic)=vtrial(jc,ispden)-vxc(jc,ispden)
4440 : 0 : vloc(2,ic)=zero
4441 : : end do
4442 : : else
4443 [ # # ]: 0 : do ic=1,nfgd
4444 : 0 : jc=pawfgrtab(iatom)%ifftsph(ic)
4445 : 0 : vloc(1,ic)=vtrial(jc,ispden)
4446 : 0 : vloc(2,ic)=zero
4447 : : end do
4448 : : end if
4449 [ # # ]: 0 : else if (ispden==3) then
4450 [ # # ]: 0 : if (usexcnhat==0) then
4451 [ # # # # ]: 0 : vloc(:,:)=zero
4452 : : else
4453 [ # # ]: 0 : do ic=1,nfgd
4454 : 0 : jc=pawfgrtab(iatom)%ifftsph(ic)
4455 : 0 : vloc(1,ic)=vtrial(jc,3)
4456 : 0 : vloc(2,ic)=vtrial(jc,4)
4457 : : end do
4458 : : end if
4459 : : else ! ispden=4
4460 [ # # ]: 0 : vloc(2,1:nfgd)=-vloc(2,1:nfgd)
4461 : : end if
4462 : : end if
4463 : :
4464 : : ! option = 0 Insulator case
4465 [ + + ]: 1512 : if(option==0)then
4466 [ + + ]: 13656 : do ilslm=1,lm_size
4467 [ + + ]: 13044834 : do ic=1,nfgd
4468 : 13031178 : jc=pawfgrtab(iatom)%ifftsph(ic)
4469 [ + + ]: 26062356 : contrib(1:cplex_nspden) = zero
4470 : :
4471 : : ! Int_R^3{vtrial*Sum_LM[Q_ij_q^LM^(1)]}
4472 : 13031178 : mua=alpha(istr);mub=beta(istr)
4473 : : contrib(1:cplex_nspden)=contrib(1:cplex_nspden)+half*vloc(1:cplex_nspden,ic)&
4474 : : & *(pawfgrtab(iatom)%gylmgr(mua,ic,ilslm)*pawfgrtab(iatom)%rfgd(mub,ic)&
4475 [ + + ]: 26062356 : & + pawfgrtab(iatom)%gylmgr(mub,ic,ilslm)*pawfgrtab(iatom)%rfgd(mua,ic))
4476 : :
4477 : : ! Int_R^3{Vloc^(1)*Sum_LM[Q_ij_q^LM]}
4478 : 13031178 : contrib(1)=contrib(1)+vpsp1(jc)*pawfgrtab(iatom)%gylm(ic,ilslm)
4479 : :
4480 : : ! delta_{alphabeta}Int_R^3{Vloc*Sum_LM[Q_ij_q^LM]}
4481 [ + + ]: 13031178 : if(istr<=3)then
4482 : : contrib(1:cplex_nspden)=contrib(1:cplex_nspden) &
4483 [ + + ]: 13031178 : & +vloc(1:cplex_nspden,ic)*pawfgrtab(iatom)%gylm(ic,ilslm)
4484 : : end if
4485 : :
4486 [ + + ]: 26074656 : intv(1:cplex_nspden,ilslm)=intv(1:cplex_nspden,ilslm)+contrib(1:cplex_nspden)
4487 : : end do
4488 : : end do
4489 : :
4490 : : ! option = 1 Metal case (without Vpsp1)
4491 [ + - ]: 156 : else if (option==1)then
4492 [ + + ]: 1560 : do ilslm=1,lm_size
4493 [ + + ]: 1297668 : do ic=1,nfgd
4494 : 1296108 : jc=pawfgrtab(iatom)%ifftsph(ic)
4495 : 1296108 : contrib(1) = zero
4496 : :
4497 : : ! Int_R^3{vtrial*Sum_LM[Q_ij_q^LM^(1)]}
4498 : 1296108 : mua=alpha(istr);mub=beta(istr)
4499 : : contrib(1:cplex_nspden)=contrib(1:cplex_nspden)+half*vloc(1:cplex_nspden,ic)&
4500 : : & *(pawfgrtab(iatom)%gylmgr(mua,ic,ilslm)*pawfgrtab(iatom)%rfgd(mub,ic)&
4501 [ + + ]: 2592216 : & + pawfgrtab(iatom)%gylmgr(mub,ic,ilslm)*pawfgrtab(iatom)%rfgd(mua,ic))
4502 : :
4503 : : ! delta_{alphabeta}Int_R^3{Vtrial*Sum_LM[Q_ij_q^LM]}
4504 [ + + ]: 1296108 : if(istr<=3)then
4505 : : contrib(1:cplex_nspden)=contrib(1:cplex_nspden) &
4506 [ + + ]: 1296108 : & +vloc(1:cplex_nspden,ic)*pawfgrtab(iatom)%gylm(ic,ilslm)
4507 : : end if
4508 : :
4509 [ + + ]: 2593620 : intv(1:cplex_nspden,ilslm)=intv(1:cplex_nspden,ilslm)+contrib(1:cplex_nspden)
4510 : : end do
4511 : : end do
4512 : : end if
4513 [ - + ]: 1512 : LIBPAW_DEALLOCATE(vloc)
4514 : :
4515 : : ! Apply ucvol/nfft factor on integral
4516 [ + + + + ]: 28920 : intv(:,:)=fact*intv(:,:)
4517 : :
4518 : : ! --- Reduction in case of parallelization ---
4519 : 1512 : call xmpi_sum(intv,my_comm_grid,ier)
4520 : :
4521 [ + + ]: 57780 : paw_ij1(iatom)%dijfr(:,ispden)=zero
4522 : :
4523 : : ! ---- Loop over (i,j) components
4524 : : klmn1=1
4525 [ + + ]: 57780 : do klmn=1,lmn2_size
4526 : 56268 : klm =pawtab(itypat)%indklmn(1,klmn)
4527 : 56268 : lmin=pawtab(itypat)%indklmn(3,klmn)
4528 : 56268 : lmax=pawtab(itypat)%indklmn(4,klmn)
4529 [ - + + + ]: 146412 : do ils=lmin,lmax,2
4530 : 90144 : lm0=ils**2+ils+1
4531 [ + + ]: 414720 : do mm=-ils,ils
4532 : 268308 : ilslm=lm0+mm;isel=pawang%gntselect(ilslm,klm)
4533 [ + + ]: 358452 : if (isel>0) then
4534 : : !The following works only because cplex_nspden<=cplex_dij
4535 : : paw_ij1(iatom)%dijfr(klmn1,ispden)=paw_ij1(iatom)%dijfr(klmn1,ispden) &
4536 : 80928 : & +pawtab(itypat)%qijl(ilslm,klmn)*intv(1,ilslm)
4537 [ - + ]: 80928 : if (cplex_nspden==2) then
4538 : : paw_ij1(iatom)%dijfr(klmn1+1,ispden)=paw_ij1(iatom)%dijfr(klmn1+1,ispden) &
4539 : 0 : & +pawtab(itypat)%qijl(ilslm,klmn)*intv(2,ilslm)
4540 : : end if
4541 : : !Previous version
4542 : : ! dplex_nsp=cplex_nspden-1
4543 : : ! paw_ij1(iatom)%dijfr(klmn1:klmn1+dplex_nsp,ispden)= &
4544 : : !& paw_ij1(iatom)%dijfr(klmn1:klmn1+dplex_nsp,ispden) &
4545 : : !& +pawtab(itypat)%qijl(ilslm,klmn)*intv(1:cplex_nspden,ilslm)
4546 : : end if
4547 : : end do
4548 : : end do
4549 : 57780 : klmn1=klmn1+cplex_dij
4550 : : end do
4551 : :
4552 : : ! Dijfr is marked as computed
4553 : 3024 : paw_ij1(iatom)%has_dijfr=2
4554 : :
4555 : : end if ! ipert
4556 : :
4557 [ - + ]: 17520 : LIBPAW_DEALLOCATE(intv)
4558 : :
4559 : : !----------------------------------------------------------
4560 : : ! End loops over spin components
4561 : : end do ! ispden
4562 : :
4563 : : ! ----------------------------------------------------------
4564 : : ! Deduce some part of Dij according to symmetries
4565 : : ! ----------------------------------------------------------
4566 : :
4567 : : !Non-collinear: D_ij(:,4)=D^21_ij=D^12_ij^*
4568 [ # # # # ]: 0 : else if (nspden==4.and.idij==4) then
4569 [ # # ]: 0 : paw_ij1(iatom)%dijfr(:,idij)=paw_ij1(iatom)%dijfr(:,idij-1)
4570 [ # # ]: 0 : if (cplex_dij==2) then
4571 [ # # ]: 0 : do klmn=2,lmn2_size*cplex_dij,cplex_dij
4572 [ # # ]: 0 : paw_ij1(iatom)%dijfr(klmn,idij)=-paw_ij1(iatom)%dijfr(klmn,idij)
4573 : : end do
4574 [ # # ]: 0 : if (qphase==2) then
4575 [ # # ]: 0 : do klmn=2+lmn2_size*cplex_dij,2*lmn2_size*cplex_dij,cplex_dij
4576 [ # # ]: 0 : paw_ij1(iatom)%dijfr(klmn,idij)=-paw_ij1(iatom)%dijfr(klmn,idij)
4577 : : end do
4578 : : end if
4579 : : end if
4580 : :
4581 : : !Antiferro: D_ij(:,2)=D^down_ij=D^up_ij
4582 [ # # # # ]: 0 : else if (nsppol==1.and.idij==2) then
4583 [ # # ]: 0 : paw_ij1(iatom)%dijfr(:,idij)=paw_ij1(iatom)%dijfr(:,idij-1)
4584 : : end if
4585 : :
4586 : : ! End loop on Dij components
4587 : : end do ! idij
4588 : :
4589 : : !----------------------------------------------------------
4590 : :
4591 : : ! Eventually free temporary space for g_l(r).Y_lm(r) gradients and exp(-i.q.r)
4592 [ + + ]: 11734 : if (need_dijfr_1.or.need_dijfr_2) then
4593 [ - + ]: 4942 : if (pawfgrtab(iatom)%gylm_allocated==2) then
4594 [ # # ]: 0 : LIBPAW_DEALLOCATE(pawfgrtab(iatom)%gylm)
4595 [ # # ]: 0 : LIBPAW_ALLOCATE(pawfgrtab(iatom)%gylm,(0,0))
4596 : 0 : pawfgrtab(iatom)%gylm_allocated=0
4597 : : end if
4598 [ - + ]: 4942 : if (pawfgrtab(iatom)%gylmgr_allocated==2) then
4599 [ # # ]: 0 : LIBPAW_DEALLOCATE(pawfgrtab(iatom)%gylmgr)
4600 [ # # ]: 0 : LIBPAW_ALLOCATE(pawfgrtab(iatom)%gylmgr,(0,0,0))
4601 : 0 : pawfgrtab(iatom)%gylmgr_allocated=0
4602 : : end if
4603 [ + - ]: 4942 : if (pawfgrtab(iatom)%expiqr_allocated==2) then
4604 [ # # ]: 0 : LIBPAW_DEALLOCATE(pawfgrtab(iatom)%expiqr)
4605 [ # # ]: 0 : LIBPAW_ALLOCATE(pawfgrtab(iatom)%expiqr,(0,0))
4606 : 0 : pawfgrtab(iatom)%expiqr_allocated=0
4607 : : end if
4608 : : end if
4609 : :
4610 : : ! End loop on atoms
4611 : : end do
4612 : :
4613 : : !Destroy atom table used for parallelism
4614 : 3820 : call free_my_atmtab(my_atmtab,my_atmtab_allocated)
4615 : :
4616 [ + + - + : 7821 : end subroutine pawdijfr
- + - + ]
4617 : : !!***
4618 : :
4619 : : !----------------------------------------------------------------------
4620 : :
4621 : : !!****f* m_pawdij/pawpupot
4622 : : !! NAME
4623 : : !! pawpupot
4624 : : !!
4625 : : !! FUNCTION
4626 : : !! Compute the PAW DFT+U on-site potential
4627 : : !!
4628 : : !! INPUTS
4629 : : !! cplex_dij=2 if DFT+U pot. is COMPLEX (as in the spin-orbit case), 1 if dij is REAL
4630 : : !! ndij=number of spin components for Dij
4631 : : !! pawprtvol=control print volume and debugging output for PAW
4632 : : !! noccmmp(cplex_dij,2*lpawu+1,2*lpawu+1,ndij)=density matrix in the augm. region
4633 : : !! nocctot(ndij)=number of electrons in the correlated subspace
4634 : : !! pawtab(ntypat) <type(pawtab_type)>=paw tabulated starting data:
4635 : : !! %usepawu, %upawu, %jpau
4636 : : !! %vee(2*lpawu+1*4)=screened coulomb matrix
4637 : : !!
4638 : : !! OUTPUT
4639 : : !! vpawu(cplex_dij,lpawu*2+1,lpawu*2+1,ndij)=lda+u potential
4640 : : !! (see eg PRB 52, 5467 (1995) [[cite:Liechenstein1995]])
4641 : : !! When vpawu is complex (cplex_dij=2):
4642 : : !! vpawu(2*i-1,:) contains the real part
4643 : : !! vpawu(2*i,:) contains the imaginary part
4644 : : !!
4645 : : !! SOURCE
4646 : :
4647 [ - + ]: 2465 : subroutine pawpupot(cplex_dij,ndij,noccmmp,nocctot,&
4648 [ - + - + ]: 2465 : & pawprtvol,pawtab,vpawu)
4649 : :
4650 : : !Arguments ---------------------------------------------
4651 : : !scalars
4652 : : integer,intent(in) :: cplex_dij,ndij,pawprtvol
4653 : : type(pawtab_type),intent(in) :: pawtab
4654 : : !arrays
4655 : : real(dp),intent(in) :: noccmmp(:,:,:,:),nocctot(:)
4656 : : real(dp),intent(out) :: vpawu(:,:,:,:)
4657 : :
4658 : : !Local variables ---------------------------------------
4659 : : !scalars
4660 : : !Option for interaction energy in case of non-collinear magnetism:
4661 : : ! 1: E_int=-J/4.N.(N-2) (better)
4662 : : ! 2: E_int=-J/2.(Nup.(Nup-1)+Ndn.(Ndn-1)) (Nup and Ndn are ill-defined)
4663 : : ! integer,parameter :: option_interaction=3
4664 : :
4665 : : integer :: iplex,ispden,jspden,lpawu,m1,m11,m2,m21,m3,m31,m4,m41,nspden_eff
4666 : : real(dp) :: mnorm,mx,my,mz,n_sig,n_msig,n_tot,VUKStemp,n_sigs,n_msigs
4667 : : real(dp),save :: VUKS
4668 : : character(len=500) :: msg
4669 : : !arrays
4670 : : real(dp),parameter :: factcg(3:4)=(/one,-one/)
4671 : 4930 : real(dp) :: n34_msig(cplex_dij),n34_sig(cplex_dij)
4672 : : !real(dp) :: n43_sig(cplex_dij)
4673 : :
4674 : : ! *****************************************************
4675 : :
4676 : : !Useful data
4677 : 2465 : lpawu=pawtab%lpawu
4678 : :
4679 : : !Check data consistency
4680 [ - + ]: 2465 : if(pawtab%usepawu<0) then
4681 : 0 : msg = "usepawu<0 not allowed!"
4682 : 0 : LIBPAW_BUG(msg)
4683 : : end if
4684 [ + + + + : 2465 : if(ndij==4.and.pawtab%option_interaction_pawu==3.and.pawtab%usepawu>=10) then
- + ]
4685 : 0 : msg = "Option_interaction==3 is not compatible with usepawu>=10 in pawpupot"
4686 : 0 : LIBPAW_ERROR(msg)
4687 : : end if
4688 : : if (size(vpawu,1)/=cplex_dij.or.size(vpawu,2)/=2*lpawu+1.or.&
4689 [ + - + - : 2465 : & size(vpawu,3)/=2*lpawu+1.or.size(vpawu,4)/=ndij) then
+ - - + ]
4690 : 0 : write (msg,'(a,4I5, a,4I5)') ' invalid sizes for vpawu !',cplex_dij,2*lpawu+1,2*lpawu+1,ndij, &
4691 : 0 : & ' /= ', size(vpawu,1), size(vpawu,2), size(vpawu,3), size(vpawu,4)
4692 : 0 : LIBPAW_BUG(msg)
4693 : : end if
4694 : : if (size(noccmmp,1)/=cplex_dij.or.size(noccmmp,2)/=2*lpawu+1.or.&
4695 [ + - + - : 2465 : & size(noccmmp,3)/=2*lpawu+1.or.size(noccmmp,4)/=ndij) then
+ - - + ]
4696 : 0 : write (msg,'(a,4I5, a,4I5)') ' invalid sizes for noccmmp !',cplex_dij,2*lpawu+1,2*lpawu+1,ndij, &
4697 : 0 : & ' /= ', size(noccmmp,1), size(noccmmp,2), size(noccmmp,3), size(noccmmp,4)
4698 : 0 : LIBPAW_BUG(msg)
4699 : : end if
4700 [ - + ]: 2465 : if (size(nocctot,1)/=ndij) then
4701 : 0 : msg='invalid size for nocctot !'
4702 : 0 : LIBPAW_BUG(msg)
4703 : : end if
4704 : :
4705 : : !=====================================================
4706 : : !Compute DFT+U Potential on the basis of projectors
4707 : : !cf PRB 52 5467 (1995) [[cite:Liechenstein1995]]
4708 : : !-----------------------------------------------------
4709 : :
4710 [ + + + + : 409301 : vpawu=zero ; nspden_eff=ndij
+ + + + ]
4711 [ + + ]: 8420 : do ispden=1,nspden_eff
4712 : :
4713 [ + + ]: 5955 : if (ispden<=2) then ! cases ndij=4, ispden=1,2 or ndij<4
4714 : 4691 : jspden=min(nspden_eff,2)-ispden+1 ! (ispden,ndij)=(1,4)=>jspden=2
4715 : :
4716 [ + + ]: 4691 : if (nspden_eff<=2) then
4717 : 3427 : n_sig =nocctot(ispden)
4718 : 3427 : n_msig=nocctot(jspden)
4719 : 3427 : n_tot =n_sig+n_msig
4720 : : else
4721 : 1264 : n_tot=nocctot(1)
4722 : 1264 : mx=nocctot(2)
4723 : 1264 : my=nocctot(3)
4724 : 1264 : mz=nocctot(4)
4725 : 1264 : mnorm=sqrt(mx*mx+my*my+mz*mz)
4726 [ + + ]: 1264 : if (ispden==1) then
4727 : : ! n_sig =half*(n_tot+mnorm)
4728 : : ! n_msig=half*(n_tot-mnorm)
4729 : 632 : n_sig =half*(n_tot+sign(mnorm,mz))
4730 : 632 : n_msig=half*(n_tot-sign(mnorm,mz))
4731 : : else
4732 : : ! n_sig =half*(n_tot-mnorm)
4733 : : ! n_msig=half*(n_tot+mnorm)
4734 : 632 : n_sig =half*(n_tot-sign(mnorm,mz))
4735 : 632 : n_msig=half*(n_tot+sign(mnorm,mz))
4736 : : end if
4737 : : end if
4738 : :
4739 : 4691 : n_sigs =n_sig/(float(2*lpawu+1))
4740 : 4691 : n_msigs =n_msig/(float(2*lpawu+1))
4741 [ + + ]: 28042 : do m1=-lpawu,lpawu
4742 : 23351 : m11=m1+lpawu+1
4743 [ + + ]: 142962 : do m2=-lpawu,lpawu
4744 : 119611 : m21=m2+lpawu+1
4745 [ + + ]: 771761 : do m3=-lpawu,lpawu
4746 : 628799 : m31=m3+lpawu+1
4747 [ + + ]: 4139869 : do m4=-lpawu,lpawu
4748 : 3391459 : m41=m4+lpawu+1
4749 [ + + ]: 7674874 : n34_sig(:) =noccmmp(:,m31,m41,ispden) ! spin sigma
4750 [ + + ]: 7674874 : n34_msig(:)=noccmmp(:,m31,m41,jspden) ! opposite spin (-sigma)
4751 [ + + - + ]: 3391459 : if(m31==m41.and.pawtab%usepawu==3) then
4752 : 0 : n34_sig(1)= n34_sig(1) - n_sigs
4753 : 0 : n34_msig(1)= n34_msig(1) - n_msigs
4754 : : end if
4755 [ + + ]: 8303673 : do iplex=1,cplex_dij
4756 : : vpawu(iplex,m11,m21,ispden)=vpawu(iplex,m11,m21,ispden) &
4757 : : & +n34_msig(iplex)*pawtab%vee(m11,m31,m21,m41) &
4758 : 7674874 : & +n34_sig(iplex)*(pawtab%vee(m11,m31,m21,m41)-pawtab%vee(m11,m31,m41,m21))
4759 : : end do
4760 : : ! if(abs(pawprtvol)>=3.and.m11==1.and.m21==1) then
4761 : : ! write(msg,'(a,i4,i4,2e20.10)') "m31,m41,vu=",m31,m41,&
4762 : : ! & vpawu(:,m11,m21,ispden)
4763 : : ! call wrtout(std_out,msg,'COLL')
4764 : : ! write(msg,'(a,4e20.10)') "vee",pawtab%vee(m11,m31,m21,m41),&
4765 : : ! & pawtab%vee(m11,m31,m41,m21)
4766 : : ! call wrtout(std_out,msg,'COLL')
4767 : : ! write(msg,'(a,4e20.10)') "n34_msig,n34_sig",n34_msig(1),n34_sig(1)
4768 : : ! call wrtout(std_out,msg,'COLL')
4769 : : ! end if
4770 : : end do
4771 : : end do
4772 : : ! if(abs(pawprtvol)>=3) then
4773 : : ! if(m11/=m21) then
4774 : : ! write(msg,'(a,i4,i4,2e20.10)') "vu=",m11,m21,vpawu(:,m11,m21,ispden)
4775 : : ! call wrtout(std_out,msg,'COLL')
4776 : : ! write(msg,'(a,2e20.10)') "vupred=",-pawtab%upawu*noccmmp(:,m21,m11,ispden)
4777 : : ! call wrtout(std_out,msg,'COLL')
4778 : : ! end if
4779 : : ! end if
4780 : : end do ! m2
4781 [ + + ]: 23351 : if(abs(pawprtvol)>=3) then
4782 : : write(msg,'(a,i3,14f11.5)') &
4783 [ + - + + ]: 65642 : & "vpawu ",m11, (vpawu(:,m11,m21,ispden),m21=1,2*lpawu+1)
4784 : 10469 : call wrtout(std_out, msg,'COLL')
4785 : : write(msg,'(a,i3,14f11.5)') &
4786 [ + - + + ]: 65642 : & "noccmmp ",m11, (noccmmp(:,m11,m21,ispden),m21=1,2*lpawu+1)
4787 : 10469 : call wrtout(std_out, msg,'COLL')
4788 : : end if
4789 : :
4790 : : ! Full localized limit
4791 [ + + ]: 23351 : if(pawtab%usepawu==1.or.pawtab%usepawu==4) then ! not activated if usepawu=10 !!
4792 : : ! Here we compute vpawu=vpawu-v_dc
4793 : 22706 : vpawu(1,m11,m11,ispden)=vpawu(1,m11,m11,ispden)-pawtab%upawu*(n_tot-half)
4794 [ + + - + ]: 22706 : if (ndij/=4.or.pawtab%option_interaction_pawu==2) then
4795 [ + + ]: 16274 : if(pawtab%usepawu/=4) then
4796 : 14649 : vpawu(1,m11,m11,ispden)=vpawu(1,m11,m11,ispden)+pawtab%jpawu*(n_sig-half)
4797 : : else
4798 : 1625 : vpawu(1,m11,m11,ispden)=vpawu(1,m11,m11,ispden)+half*pawtab%jpawu*(n_tot-one)
4799 : : endif
4800 [ + + + + ]: 6432 : else if (ndij==4.and.(pawtab%usepawu==4.or.pawtab%option_interaction_pawu==1)) then
4801 : 2600 : vpawu(1,m11,m11,ispden)=vpawu(1,m11,m11,ispden)+half*pawtab%jpawu*(n_tot-one)
4802 [ + - ]: 3832 : else if (ndij==4.and.pawtab%option_interaction_pawu==3) then
4803 : : ! Here vdc^{alpha,beta}=\vect{m}.\vect{sigma}^{\beta,\alpha}
4804 : 3832 : vpawu(1,m11,m11,ispden)=vpawu(1,m11,m11,ispden)+half*pawtab%jpawu*(n_tot-one)
4805 [ + + ]: 3832 : if (ispden==1) then
4806 : 1916 : vpawu(1,m11,m11,ispden)=vpawu(1,m11,m11,ispden)+half*pawtab%jpawu*mz
4807 : : else
4808 : 1916 : vpawu(1,m11,m11,ispden)=vpawu(1,m11,m11,ispden)-half*pawtab%jpawu*mz
4809 : : end if
4810 : : end if
4811 : :
4812 : : ! Around mean field
4813 [ + + ]: 645 : else if(pawtab%usepawu==2) then
4814 : : vpawu(1,m11,m11,ispden)=vpawu(1,m11,m11,ispden)-n_msig*pawtab%upawu &
4815 : : & -n_sig*(pawtab%upawu-pawtab%jpawu) &
4816 : 625 : & *(dble(2*lpawu)/dble(2*lpawu+1))
4817 : : end if
4818 : :
4819 : : ! if (abs(pawprtvol)>=3) then
4820 : : ! write(msg,'(a,i4,i4,2x,e20.10)') "vudiag= ",m11,m11,vpawu(1,m11,m11,ispden)
4821 : : ! call wrtout(std_out, msg,'COLL')
4822 : : ! write(msg,'(a,2e20.10)') "vudiagpred= ",pawtab%upawu*(half-noccmmp(:,m11,m11,ispden))
4823 : : ! call wrtout(std_out, msg,'COLL')
4824 : : ! end if
4825 [ + + ]: 28042 : if(abs(pawprtvol)>=3) then
4826 : 10469 : write(msg,*) "nocctot",nocctot
4827 : 10469 : call wrtout(std_out, msg,'COLL')
4828 : : write(msg,'(a,i3,14f11.5)') &
4829 [ + - + + ]: 65642 : & "vpawu 2",m11, (vpawu(:,m11,m21,ispden),m21=1,2*lpawu+1)
4830 : 10469 : call wrtout(std_out, msg,'COLL')
4831 : : write(msg,'(a,i3,14f11.5)') &
4832 [ + - + + ]: 65642 : & "noccmmp2",m11, (noccmmp(:,m11,m21,ispden),m21=1,2*lpawu+1)
4833 : 10469 : call wrtout(std_out, msg,'COLL')
4834 : : end if
4835 : : end do ! m1
4836 : :
4837 : : end if ! ispden<=2
4838 : :
4839 : : ! Non-collinear magnetism: add non-diagonal term; see (Eq 6) in PRB 72, 024458 (2005) [[cite:Shurikov2005]]
4840 : : ! BA Here, we compute the transpose --- with respect to spin indices --- of
4841 : : ! BA equation (6) of this reference, because of differences in notations,
4842 : : ! BA namely Eband=\sum rhoij^{alpha,beta}*Dij(beta,alpha) contrary to PRB 72, 024458 (2005) [[cite:Shurikov2005]]
4843 [ + + ]: 5955 : if (ispden>=3) then
4844 : 1264 : mx=nocctot(2)
4845 : 1264 : my=nocctot(3)
4846 [ + + ]: 7696 : do m1=-lpawu,lpawu
4847 : 6432 : m11=m1+lpawu+1
4848 [ + + ]: 39376 : do m2=-lpawu,lpawu
4849 : 32944 : m21=m2+lpawu+1
4850 [ + + ]: 209584 : do m3=-lpawu,lpawu
4851 : 170208 : m31=m3+lpawu+1
4852 [ + + ]: 1092608 : do m4=-lpawu,lpawu
4853 : 889456 : m41=m4+lpawu+1
4854 : : ! n43_sig(:) =noccmmp(:,m41,m31,ispden)
4855 : : ! vpawu(1,m11,m21,ispden)=vpawu(1,m11,m21,ispden)-n43_sig(1)*pawtab%vee(m11,m31,m41,m21)
4856 : : ! vpawu(2,m11,m21,ispden)=vpawu(2,m11,m21,ispden)+n43_sig(2)*pawtab%vee(m11,m31,m41,m21)
4857 [ + + ]: 2668368 : n34_sig(:) =noccmmp(:,m31,m41,ispden)
4858 : 889456 : vpawu(1,m11,m21,ispden)=vpawu(1,m11,m21,ispden)-n34_sig(1)*pawtab%vee(m11,m31,m41,m21)
4859 : 1059664 : vpawu(2,m11,m21,ispden)=vpawu(2,m11,m21,ispden)-n34_sig(2)*pawtab%vee(m11,m31,m41,m21)
4860 : : end do
4861 : : end do
4862 : : end do
4863 [ + + + + ]: 7696 : if(pawtab%usepawu==1.and.pawtab%option_interaction_pawu==3) then ! not activated if usepawu=10 !!
4864 : 3832 : vpawu(1,m11,m11,ispden)=vpawu(1,m11,m11,ispden)+half*pawtab%jpawu*mx
4865 [ + + ]: 3832 : if(ispden==3) then
4866 : 1916 : vpawu(2,m11,m11,ispden)=vpawu(2,m11,m11,ispden)-half*pawtab%jpawu*my
4867 : : else
4868 : 1916 : vpawu(2,m11,m11,ispden)=vpawu(2,m11,m11,ispden)+half*pawtab%jpawu*my
4869 : : end if
4870 : : end if
4871 : : end do
4872 : : end if
4873 : :
4874 [ + + ]: 5955 : if(abs(pawprtvol)>=3) then
4875 : 3245 : write(std_out,*) "vpawu, ispden",ispden
4876 [ + + ]: 19986 : do m11=1,2*lpawu+1
4877 : : write(msg,'(12(1x,9(1x,"(",f10.7,",",f10.7,")")))') &
4878 [ + - + + ]: 104058 : & (vpawu(1:cplex_dij,m11,m21,ispden),m21=1,2*lpawu+1)
4879 : 19986 : call wrtout(std_out,msg,'COLL')
4880 : : end do
4881 : : end if
4882 : :
4883 : : ! Printing for test
4884 [ + + ]: 8420 : if (abs(pawprtvol)>=3) then
4885 [ + + ]: 3245 : if (ispden==1) VUKS=zero
4886 : 3245 : VUKStemp=zero
4887 [ + + ]: 19986 : do m1=-lpawu,lpawu
4888 : 16741 : m11=m1+lpawu+1
4889 [ + + ]: 107303 : do m2=-lpawu,lpawu
4890 : 87317 : m21=m2+lpawu+1
4891 : 87317 : VUKStemp=VUKStemp+vpawu(1,m11,m21,ispden)*noccmmp(1,m11,m21,ispden)
4892 [ + + ]: 87317 : if (cplex_dij == 2) then
4893 : 64288 : VUKStemp=VUKStemp-vpawu(2,m11,m21,ispden)*noccmmp(2,m11,m21,ispden)
4894 : : end if
4895 : 87317 : write(msg,'(a,2e20.10,2e20.10)') "m1,m2,vpawu,noccmmp= ", &
4896 : 174634 : & vpawu(:,m11,m21,ispden),noccmmp(:,m11,m21,ispden)
4897 : 104058 : call wrtout(std_out, msg,'COLL')
4898 : : end do
4899 : : end do
4900 : 3245 : VUKS=VUKS+VUKStemp
4901 : 3245 : write(msg,*) "pawpupot: VUKStemp= ",ispden,VUKStemp
4902 : 3245 : call wrtout(std_out, msg,'COLL')
4903 [ + + ]: 3245 : if (ispden==nspden_eff) then
4904 : 1126 : write(msg,*) "pawpupot: VUKS= ",ispden,VUKS
4905 : 1126 : call wrtout(std_out, msg,'COLL')
4906 : : end if
4907 : : end if
4908 : :
4909 : : end do ! Loop on ispden
4910 : :
4911 : 2465 : end subroutine pawpupot
4912 : : !!***
4913 : :
4914 : : !----------------------------------------------------------------------
4915 : :
4916 : : !!****f* m_pawdij/pawxpot
4917 : : !! NAME
4918 : : !! pawxpot
4919 : : !!
4920 : : !! FUNCTION
4921 : : !! Compute the PAW Local Exact-Exchange on-site potential
4922 : : !!
4923 : : !! INPUTS
4924 : : !! ndij=number of spin components for Dij
4925 : : !! pawprtvol=control print volume and debugging output for PAW
4926 : : !! paw_ij <type(paw_ij_type)>=paw arrays given on (i,j) channels
4927 : : !! pawtab <type(pawtab_type)>=paw tabulated starting data:
4928 : : !! pawrhoij <type(pawrhoij_type)>= paw rhoij occupancies and related data
4929 : : !!
4930 : : !! OUTPUT
4931 : : !! paw_ij%vpawx(pawtab%lexexch*2+1,pawtab%lexexch*2+1)=local exact-exchange potential
4932 : : !!
4933 : : !! SOURCE
4934 : :
4935 [ - + ]: 42 : subroutine pawxpot(ndij,pawprtvol,pawrhoij,pawtab,vpawx)
4936 : :
4937 : : !Arguments ---------------------------------------------
4938 : : !scalars
4939 : : integer,intent(in) :: ndij,pawprtvol
4940 : : type(pawrhoij_type),intent(in) :: pawrhoij
4941 : : type(pawtab_type),intent(in) :: pawtab
4942 : : real(dp),intent(out) :: vpawx(:,:,:)
4943 : :
4944 : : !Local variables ---------------------------------------
4945 : : !scalars
4946 : : integer :: cplex_rhoij,irhoij,irhoij1,ispden,jrhoij,jrhoij1,klmn,klmn1,lexexch,ll,lmn2_size
4947 : : integer :: m11,m21,m31,m41,n1,n2,n3,n4,nk,nn1,nn2,nspden_eff
4948 : : real(dp) :: tot
4949 : : character(len=500) :: msg
4950 : : !arrays
4951 : : integer :: indn(3,3)
4952 : : real(dp) :: factnk(6)
4953 : :
4954 : : ! *****************************************************
4955 : :
4956 : : !Useful data
4957 : 42 : lexexch=pawtab%lexexch
4958 : 42 : cplex_rhoij=pawrhoij%cplex_rhoij
4959 : 42 : lmn2_size=pawtab%lmn2_size
4960 : : if (pawtab%nproju==1) nk=1
4961 : 42 : if (pawtab%nproju==2) nk=6
4962 : 42 : factnk(1)=one;factnk(2)=one;factnk(3)=one
4963 : 42 : factnk(4)=two;factnk(5)=two;factnk(6)=two
4964 : 42 : indn(1,1)=1;indn(1,2)=4;indn(1,3)=5
4965 : 42 : indn(2,1)=4;indn(2,2)=2;indn(2,3)=6
4966 : 42 : indn(3,1)=5;indn(3,2)=6;indn(3,3)=3
4967 : :
4968 : : !Check data consistency
4969 [ + - + - : 42 : if (size(vpawx,1)/=1.or.size(vpawx,2)/=lmn2_size.or.&
- + ]
4970 : : & size(vpawx,3)/=ndij) then
4971 : 0 : msg='invalid sizes for vpawx !'
4972 : 0 : LIBPAW_BUG(msg)
4973 : : end if
4974 [ - + ]: 42 : if (pawrhoij%qphase==2) then
4975 : 0 : msg='pawxpot not compatible with qphase=2 (DFPT)!'
4976 : 0 : LIBPAW_BUG(msg)
4977 : : end if
4978 : :
4979 : : !=====================================================
4980 : : !Compute local exact exchange Potential
4981 : : !on the basis of projectors.
4982 : : !-----------------------------------------------------
4983 : :
4984 [ + + + + : 28854 : vpawx=zero ; nspden_eff=ndij
+ + ]
4985 [ + + ]: 126 : do ispden=1,nspden_eff
4986 : 84 : jrhoij=1
4987 [ + + ]: 6790 : do irhoij=1,pawrhoij%nrhoijsel
4988 : 6664 : klmn=pawrhoij%rhoijselect(irhoij)
4989 [ + + + + ]: 6664 : if(pawtab%indklmn(3,klmn)==0.and.pawtab%indklmn(4,klmn)==2*lexexch) then
4990 : 3780 : m11=pawtab%klmntomn(1,klmn);m21=pawtab%klmntomn(2,klmn)
4991 : 3780 : n1=pawtab%klmntomn(3,klmn);n2=pawtab%klmntomn(4,klmn)
4992 : 3780 : nn1=(n1*n2)/2+1
4993 : 3780 : jrhoij1=1
4994 [ + + ]: 315980 : do irhoij1=1,pawrhoij%nrhoijsel
4995 : 312200 : klmn1=pawrhoij%rhoijselect(irhoij1)
4996 [ + + + + ]: 312200 : if(pawtab%indklmn(3,klmn1)==0.and.pawtab%indklmn(4,klmn1)==2*lexexch) then
4997 : 176820 : m31=pawtab%klmntomn(1,klmn1);m41=pawtab%klmntomn(2,klmn1)
4998 : 176820 : n3=pawtab%klmntomn(3,klmn1);n4=pawtab%klmntomn(4,klmn1)
4999 : 176820 : nn2=(n3*n4)/2+1
5000 [ + + ]: 707280 : do ll=1,lexexch+1
5001 : : vpawx(1,klmn,ispden)=vpawx(1,klmn,ispden)&
5002 : : & -pawtab%vex(m11,m31,m41,m21,ll)*pawtab%dltij(klmn1) &
5003 : 707280 : & *pawtab%fk(indn(nn1,nn2),ll)*pawrhoij%rhoijp(jrhoij1,ispden)
5004 : : end do
5005 : :
5006 : : end if
5007 : 315980 : jrhoij1=jrhoij1+cplex_rhoij
5008 : : end do !irhoij1
5009 : : end if
5010 : 6748 : jrhoij=jrhoij+cplex_rhoij
5011 : : end do !irhoij
5012 : : end do !ispden
5013 : :
5014 : : !Test
5015 [ - + ]: 42 : if (abs(pawprtvol)>=2) then
5016 : 0 : tot=zero
5017 [ # # ]: 0 : do ispden=1,pawrhoij%nspden
5018 : 0 : jrhoij=1
5019 [ # # ]: 0 : do irhoij=1,pawrhoij%nrhoijsel
5020 : 0 : klmn=pawrhoij%rhoijselect(irhoij)
5021 : 0 : tot=tot+vpawx(1,klmn,ispden)*pawrhoij%rhoijp(jrhoij,ispden)*pawtab%dltij(klmn)
5022 : 0 : jrhoij=jrhoij+cplex_rhoij
5023 : : end do
5024 : : end do
5025 : 0 : write(msg, '(a,es22.15)' )" Vpawx: tot=",tot*half
5026 : 0 : call wrtout(std_out,msg,'COLL')
5027 : : end if
5028 : :
5029 : 42 : end subroutine pawxpot
5030 : : !!***
5031 : :
5032 : : !----------------------------------------------------------------------
5033 : :
5034 : : !!****f* m_pawdij/symdij
5035 : : !! NAME
5036 : : !! symdij
5037 : : !!
5038 : : !! FUNCTION
5039 : : !! Symmetrize PAW non-local strengths Dij
5040 : : !! Symmetrize total Dij or one part of it
5041 : : !!
5042 : : !! INPUTS
5043 : : !! gprimd(3,3)=dimensional primitive translations for reciprocal space(bohr^-1).
5044 : : !! indsym(4,nsym,natom)=indirect indexing array for atom labels
5045 : : !! ipert=index of perturbation if pawrhoij is a pertubed rhoij
5046 : : !! no meaning for ground-state calculations (should be 0)
5047 : : !! [mpi_atmtab(:)]=--optional-- indexes of the atoms treated by current proc
5048 : : !! [comm_atom]=--optional-- MPI communicator over atoms
5049 : : !! my_natom=number of atoms treated by current processor
5050 : : !! natom=number of atoms in cell
5051 : : !! nsym=number of symmetry elements in space group
5052 : : !! ntypat=number of types of atoms in unit cell.
5053 : : !! option_dij=choose which part of Dij has to be symmetrized (which paw_ij(:)%dijxxx):
5054 : : !! 0: total dij (dij)
5055 : : !! 1: dij due to compensation charge (dijhat)
5056 : : !! 2: dij due to +U (dijU)
5057 : : !! 3: dij XC (dijxc)
5058 : : !! 4: dij XC due to compensation charge (dijxc_hat)
5059 : : !! 5: dij XC valence only (dijxc_val)
5060 : : !! 6: dij spin-orbit (dijso)
5061 : : !! 7: dij exact exchange (dijexxc)
5062 : : !! 8: dij, RF frozen part (dijfr)
5063 : : !! 9: dij due to nuclear dipoles
5064 : : !! 10: dij Hartree
5065 : : !! 11: dij Fock
5066 : : !! paw_ij(natom)%cplex_dij=1 if dij are REAL, 2 if they are COMPLEX
5067 : : !! paw_ij(natom)%qphase=2 if exp^(-i.q.r) phase from RF at q<>0, 1 otherwise
5068 : : !! paw_ij(natom)%lmn_size=number of (l,m,n) elements for the paw basis
5069 : : !! paw_ij(natom)%nspden=number of spin-density components
5070 : : !! paw_ij(natom)%nsppol=number of independent spin-density components
5071 : : !! paw_ij(natom)%dij(lmn2_size,nspden)=non-symmetrized paw dij quantities
5072 : : !! pawang <type(pawang_type)>=angular mesh discretization and related data
5073 : : !! pawprtvol=control print volume and debugging output for PAW
5074 : : !! pawtab(ntypat) <type(pawtab_type)>=paw tabulated starting data
5075 : : !! [qphon(3)]=--optional-- (RF calculations only) - wavevector of the phonon
5076 : : !! rprimd(3,3)=real space primitive translations.
5077 : : !! symafm(nsym)=(anti)ferromagnetic part of symmetry operations
5078 : : !! symrec(3,3,nsym)=symmetries of group in terms of operations on
5079 : : !! reciprocal space primitive translations
5080 : : !!
5081 : : !! SIDE EFFECTS
5082 : : !! paw_ij(natom)%dij???(cplex_dij*lmn2_size,nspden)=symmetrized dij quantities as output
5083 : : !!
5084 : : !! SOURCE
5085 : :
5086 : 41500 : subroutine symdij(gprimd,indsym,ipert,my_natom,natom,nsym,ntypat,option_dij,&
5087 : 41500 : & paw_ij,pawang,pawprtvol,pawtab,rprimd,symafm,symrec, &
5088 [ + + + + : 20750 : & mpi_atmtab,comm_atom,qphon) ! optional arguments (parallelism)
- + ]
5089 : :
5090 : : !Arguments ---------------------------------------------
5091 : : !scalars
5092 : : integer,intent(in) :: ipert,my_natom,natom,nsym,ntypat,option_dij,pawprtvol
5093 : : integer,optional,intent(in) :: comm_atom
5094 : : type(pawang_type),intent(in) :: pawang
5095 : : !arrays
5096 : : integer,intent(in) :: indsym(4,nsym,natom),symafm(nsym),symrec(3,3,nsym)
5097 : : integer,optional,target,intent(in) :: mpi_atmtab(:)
5098 : : real(dp),intent(in) :: gprimd(3,3),rprimd(3,3)
5099 : : real(dp),intent(in),optional :: qphon(3)
5100 : : type(paw_ij_type),intent(inout) :: paw_ij(my_natom)
5101 : : type(pawtab_type),target,intent(in) :: pawtab(ntypat)
5102 : :
5103 : : !Local variables ---------------------------------------
5104 : : !scalars
5105 : : integer :: at_indx,cplex_dij,iafm,iatom,iatom_tot,ii
5106 : : integer :: il,il0,ilmn,iln,iln0,ilpm,indexi,indexii,indexj,indexjj,indexjj0,indexk,indexkc,indexkc_q
5107 : : integer :: iplex,iq,irot,ispden,itypat,j0lmn,jl,jl0,jlmn,jln,jln0,jlpm,jspden
5108 : : integer :: klmn,klmnc,kspden,lmn_size,lmn2_size,mi,mj,my_comm_atom,my_cplex_dij,my_ndij,my_qphase
5109 : : integer :: mu,natinc,ndij0,ndij1,nu,qphase,sz1,sz2
5110 : : logical,parameter :: afm_noncoll=.true. ! TRUE if antiferro symmetries are used with non-collinear magnetism
5111 : : logical :: antiferro,has_qphase,my_atmtab_allocated,noncoll,paral_atom,use_afm
5112 : : !DEBUG_ALTERNATE_ALGO
5113 : : !Set to TRUE to choose an alternate algorithm (with another representation)
5114 : : !to symmetrize Dij within non-collinear magnetism or spin-orbit
5115 : : logical,parameter :: lsymnew=.false.
5116 : : !DEBUG_ALTERNATE_ALGO
5117 : : real(dp) :: arg,factafm,zarot2
5118 : : real(dp) :: det
5119 : : character(len=6) :: pertstrg,wrt_mode
5120 : : character(len=500) :: msg
5121 : : !arrays
5122 : : integer :: nsym_used(2)
5123 : 20750 : integer, pointer :: indlmn(:,:)
5124 : 20750 : integer,pointer :: my_atmtab(:)
5125 : 20750 : integer,allocatable :: symrec_det(:)
5126 : : real(dp) :: dijc(2),fact(2),factsym(2),phase(2)
5127 : : real(dp) :: rotdij(2,2,2),rotmag(2,3,2),sumdij(2,2,2),summag(2,3,2)
5128 : 20750 : real(dp),allocatable :: dijnew(:,:,:),dijtmp(:,:),symrec_cart(:,:,:)
5129 : 20750 : type(coeff2_type),target, allocatable :: my_tmp_dij(:)
5130 : 20750 : type(coeff2_type),pointer :: tmp_dij(:)
5131 : :
5132 : : !DEBUG_ALTERNATE_ALGO
5133 : : !integer :: i1,i2,i3,i4,symrel_conv(3,3)
5134 : : !real(dp) :: spinrot(4)
5135 : : !real(dp),allocatable :: dijtemp(:,:),sumrhoso(:,:)
5136 : : !complex(dp) :: dijt(2,2),dijt2(2,2),Rspinrot(2,2)
5137 : : !DEBUG_ALTERNATE_ALGO
5138 : : ! *********************************************************************
5139 : :
5140 : : !Tests consistency of options
5141 : 20750 : if (my_natom>0) then
5142 : : if ((option_dij==1.and.paw_ij(1)%has_dijhat==0).or.&
5143 : : & (option_dij==2.and.paw_ij(1)%has_dijU==0).or.&
5144 : : & (option_dij==3.and.paw_ij(1)%has_dijxc==0).or.&
5145 : : & (option_dij==4.and.paw_ij(1)%has_dijxc_hat==0).or.&
5146 : : & (option_dij==5.and.paw_ij(1)%has_dijxc_val==0).or.&
5147 : : & (option_dij==6.and.paw_ij(1)%has_dijso==0).or.&
5148 : : & (option_dij==7.and.paw_ij(1)%has_dijexxc==0).or.&
5149 : : & (option_dij==8.and.paw_ij(1)%has_dijfr==0).or.&
5150 : : & (option_dij==9.and.paw_ij(1)%has_dijnd==0).or.&
5151 [ + + + - : 18986 : & (option_dij==10.and.paw_ij(1)%has_dijhartree==0).or.&
- + - - +
+ + - + +
+ - + + +
- - + - -
- + - - -
+ - - - +
- - + + +
- - + -
- ]
5152 : : & (option_dij==11.and.paw_ij(1)%has_dijfock==0)) then
5153 : 0 : msg='Incompatibilty between option_dij and allocation of Dij!'
5154 : 0 : LIBPAW_BUG(msg)
5155 : : end if
5156 : : end if
5157 : :
5158 : : !Set up parallelism over atoms
5159 [ + + + + ]: 20750 : paral_atom=(present(comm_atom).and.(my_natom/=natom))
5160 [ + + ]: 20750 : nullify(my_atmtab);if (present(mpi_atmtab)) my_atmtab => mpi_atmtab
5161 [ + + ]: 20750 : my_comm_atom=xmpi_comm_self;if (present(comm_atom)) my_comm_atom=comm_atom
5162 : 20750 : call get_my_atmtab(my_comm_atom,my_atmtab,my_atmtab_allocated,paral_atom,natom,my_natom_ref=my_natom)
5163 : :
5164 : : !Determine sizes of dij array according to options
5165 : 20750 : my_qphase=1;my_cplex_dij=1;my_ndij=1
5166 [ + + ]: 20750 : if (my_natom>0) then
5167 : 18986 : my_qphase=paw_ij(1)%qphase
5168 : 18986 : my_cplex_dij=paw_ij(1)%cplex_dij
5169 : 18986 : my_ndij=paw_ij(1)%ndij
5170 [ + + ]: 18986 : if (option_dij==4.or.option_dij==5.or.option_dij==9) my_qphase=1
5171 [ + + ]: 18986 : if (option_dij==10) my_cplex_dij=1
5172 [ + + ]: 18986 : if (option_dij==10) my_ndij=1
5173 : : end if
5174 : :
5175 : : !Antiferro case ?
5176 [ + + + + : 20750 : antiferro=.false.;if (my_natom>0) antiferro=(paw_ij(1)%nspden==2.and.paw_ij(1)%nsppol==1.and.my_ndij/=4)
- + ]
5177 : : ! Non-collinear case
5178 [ + + ]: 20750 : noncoll=.false.;if (my_natom>0) noncoll=(my_ndij==4)
5179 [ + + ]: 20750 : if (my_natom>0) then
5180 [ + + - + ]: 18986 : if (noncoll.and.paw_ij(1)%cplex_dij/=2) then
5181 : 0 : msg='cplex_dij must be 2 with ndij=4!'
5182 : 0 : LIBPAW_BUG(msg)
5183 : : end if
5184 : : end if
5185 : : !Do we use antiferro symmetries ?
5186 : 20750 : use_afm=((antiferro).or.(noncoll.and.afm_noncoll))
5187 : :
5188 : : !Do we have a phase due to q-vector?
5189 : 20750 : has_qphase=.false.
5190 [ + + ]: 20750 : if (my_natom>0) then
5191 : 18986 : has_qphase=(paw_ij(1)%qphase==2)
5192 [ + + ]: 18986 : if (present(qphon)) then
5193 [ + + + + : 14087 : if (any(abs(qphon(1:3))>tol8).and.(.not.has_qphase)) then
- + ]
5194 : 0 : msg='Should have qphase=2 for a non-zero q!'
5195 : 0 : LIBPAW_BUG(msg)
5196 : : end if
5197 : : end if
5198 : : !DEBUG_ALTERNATE_ALGO
5199 : : ! if(lsymnew.and.has_qphase) then
5200 : : ! msg='symdij: alternate algo not available for phonons at q<>0!'
5201 : : ! LIBPAW_BUG(msg)
5202 : : ! end if
5203 : : !DEBUG_ALTERNATE_ALGO
5204 : : end if
5205 : :
5206 : : !Printing of unsymetrized Dij
5207 [ + + + + : 20750 : if (abs(pawprtvol)>=1.and.option_dij==0.and.ipert/=natom+1.and.ipert/=natom+10) then
+ - + - ]
5208 [ + + ]: 1620 : wrt_mode='COLL';if (paral_atom) wrt_mode='PERS'
5209 [ - + ]: 1620 : pertstrg="DIJ";if (ipert>0) pertstrg="DIJ(1)"
5210 [ + + + + ]: 1620 : natinc=1;if(my_natom>1.and.pawprtvol>=0) natinc=my_natom-1
5211 : 1620 : write(msg, '(7a)') ch10," PAW TEST:",ch10,&
5212 : 3240 : & ' ========= Values of ',trim(pertstrg),' before symetrization =========',ch10
5213 : 1620 : call wrtout(std_out,msg,wrt_mode)
5214 [ - + + + ]: 3677 : do iatom=1,my_natom,natinc
5215 [ + + ]: 2057 : iatom_tot=iatom; if (paral_atom) iatom_tot=my_atmtab(iatom)
5216 : : call pawdij_print_dij(paw_ij(iatom)%dij,paw_ij(iatom)%cplex_dij,paw_ij(iatom)%qphase,&
5217 : 3677 : & iatom_tot,natom,paw_ij(iatom)%nspden,opt_prtvol=pawprtvol,mode_paral=wrt_mode)
5218 : : end do
5219 : 1620 : call wrtout(std_out,"",wrt_mode)
5220 : : end if
5221 : :
5222 : : !Symmetrization occurs only when nsym>1
5223 [ + + + - : 20750 : if (nsym>1.and.ipert/=natom+1.and.ipert/=natom+10) then
+ - ]
5224 : :
5225 [ - + ]: 11390 : if (pawang%nsym==0) then
5226 : 0 : msg='pawang%zarot must be allocated!'
5227 : 0 : LIBPAW_BUG(msg)
5228 : : end if
5229 : :
5230 : : ! Have to make a temporary copy of dij
5231 [ + + + - : 60528 : LIBPAW_DATATYPE_ALLOCATE(my_tmp_dij,(my_natom))
+ - + + -
+ - + +
+ ]
5232 [ + + ]: 11390 : if (my_natom>0) then
5233 [ + + ]: 37234 : do iatom=1,my_natom
5234 : 26358 : lmn2_size=paw_ij(iatom)%lmn2_size
5235 : 26358 : sz1=my_qphase*my_cplex_dij*lmn2_size;sz2=my_ndij
5236 [ - + + - : 105432 : LIBPAW_ALLOCATE(my_tmp_dij(iatom)%value,(sz1,sz2))
- + + - +
- + - - +
- + - + ]
5237 [ - + + - : 79074 : LIBPAW_ALLOCATE(dijtmp,(sz1,sz2))
- + + - -
+ - + ]
5238 [ + + - + : 26358 : if (option_dij==0) then
+ + - - -
- + - - ]
5239 [ + + + + ]: 4544201 : dijtmp(:,:)=paw_ij(iatom)%dij(:,:)
5240 : : else if (option_dij==1) then
5241 [ + + + + ]: 1673 : dijtmp(:,:)=paw_ij(iatom)%dijhat(:,:)
5242 : : else if (option_dij==2) then
5243 [ # # # # ]: 0 : dijtmp(:,:)=paw_ij(iatom)%dijU(:,:)
5244 : : else if (option_dij==3) then
5245 [ + + + + ]: 1673 : dijtmp(:,:)=paw_ij(iatom)%dijxc(:,:)
5246 : : else if (option_dij==4) then
5247 [ + + + + ]: 1673 : dijtmp(:,:)=paw_ij(iatom)%dijxc_hat(:,:)
5248 : : else if (option_dij==5) then
5249 [ + + + + ]: 1673 : dijtmp(:,:)=paw_ij(iatom)%dijxc_val(:,:)
5250 : : else if (option_dij==6) then
5251 [ # # # # ]: 0 : dijtmp(:,:)=paw_ij(iatom)%dijso(:,:)
5252 : : else if (option_dij==7) then
5253 [ # # # # ]: 0 : dijtmp(:,:)=paw_ij(iatom)%dijexxc(:,:)
5254 : : else if (option_dij==8) then
5255 [ # # # # ]: 0 : dijtmp(:,:)=paw_ij(iatom)%dijfr(:,:)
5256 : : else if (option_dij==9) then
5257 [ # # # # ]: 0 : dijtmp(:,:)=paw_ij(iatom)%dijnd(:,:)
5258 : : else if (option_dij==10) then
5259 [ + + ]: 3263 : dijtmp(:,1)=paw_ij(iatom)%dijhartree(:)
5260 : : else if (option_dij==11) then
5261 [ # # # # ]: 0 : dijtmp(:,:)=paw_ij(iatom)%dijfock(:,:)
5262 : : end if
5263 : : !Has to translate Dij^{alpha,beta} into (Dij, Dij magnetic field) format
5264 [ + + ]: 26358 : if (my_ndij==4) then
5265 [ + + ]: 564717 : my_tmp_dij(iatom)%value(:,1)=dijtmp(:,1)+dijtmp(:,2)
5266 [ + + ]: 564717 : my_tmp_dij(iatom)%value(:,2)=dijtmp(:,3)+dijtmp(:,4)
5267 [ + + ]: 564717 : my_tmp_dij(iatom)%value(:,4)=dijtmp(:,1)-dijtmp(:,2)
5268 [ + + ]: 283249 : do klmn=1,paw_ij(iatom)%lmn2_size
5269 : 281468 : my_tmp_dij(iatom)%value(2*klmn-1,3)=-dijtmp(2*klmn ,3)+dijtmp(2*klmn ,4)
5270 : 283249 : my_tmp_dij(iatom)%value(2*klmn ,3)= dijtmp(2*klmn-1,3)-dijtmp(2*klmn-1,4)
5271 : : end do
5272 : : !DEBUG_ALTERNATE_ALGO
5273 : : ! if(lsymnew) my_tmp_dij(iatom)%value(:,:)=dijtmp(:,:)
5274 : : !DEBUG_ALTERNATE_ALGO
5275 : : else
5276 [ + + + + ]: 2293569 : my_tmp_dij(iatom)%value(:,:)=dijtmp(:,:)
5277 : : end if
5278 [ - + ]: 37234 : LIBPAW_DEALLOCATE(dijtmp)
5279 : : end do
5280 : : end if
5281 : :
5282 : : ! Parallelism: gather all Dij
5283 [ + + ]: 11390 : if (paral_atom) then
5284 [ - + + - : 19800 : LIBPAW_DATATYPE_ALLOCATE(tmp_dij,(natom))
+ - + - -
+ - + +
+ ]
5285 : 3264 : call pawdij_gather(my_tmp_dij,tmp_dij,my_comm_atom,my_atmtab)
5286 [ + + ]: 6596 : do iatom=1,my_natom
5287 [ - + ]: 6596 : LIBPAW_DEALLOCATE(my_tmp_dij(iatom)%value)
5288 : : end do
5289 [ + - + + : 6596 : LIBPAW_DATATYPE_DEALLOCATE(my_tmp_dij)
- + - + ]
5290 : : else
5291 : 8126 : tmp_dij=>my_tmp_dij
5292 : : end if
5293 : :
5294 [ + + ]: 11390 : if (noncoll) then
5295 [ - + + - : 3843 : LIBPAW_ALLOCATE(symrec_cart,(3,3,nsym))
+ - - + -
+ ]
5296 [ - + + - : 3843 : LIBPAW_ALLOCATE(symrec_det,(nsym))
+ - - + -
+ ]
5297 [ + + ]: 10245 : do irot=1,nsym
5298 : 8964 : symrec_cart(:,:,irot)=symdij_symcart(gprimd,rprimd,symrec(:,:,irot))
5299 : : ! compute the sign of the determinant of the symmetries
5300 : : ! to be able to apply only the proper part of the symmetries to the magn. components
5301 : : ! (magnetization == pseudo-vector)
5302 : : det = symrec_cart(1,1,irot)*symrec_cart(2,2,irot)*symrec_cart(3,3,irot)+&
5303 : : & symrec_cart(2,1,irot)*symrec_cart(3,2,irot)*symrec_cart(1,3,irot)+&
5304 : : & symrec_cart(1,2,irot)*symrec_cart(2,3,irot)*symrec_cart(3,1,irot) - &
5305 : : & (symrec_cart(3,1,irot)*symrec_cart(2,2,irot)*symrec_cart(1,3,irot)+&
5306 : : & symrec_cart(2,1,irot)*symrec_cart(1,2,irot)*symrec_cart(3,3,irot)+&
5307 : 8964 : & symrec_cart(3,2,irot)*symrec_cart(2,3,irot)*symrec_cart(1,1,irot))
5308 : 10245 : symrec_det(irot) = nint(det) ! should return 1 or -1
5309 : : end do
5310 : : !DEBUG_ALTERNATE_ALGO
5311 : : ! if(lsymnew) then
5312 : : ! LIBPAW_ALLOCATE(sumrhoso,(my_cplex_dij,4))
5313 : : ! end if
5314 : : !DEBUG_ALTERNATE_ALGO
5315 : : end if
5316 : :
5317 : 11390 : ndij1=1
5318 [ + + ]: 11390 : if (antiferro) ndij1=2
5319 [ + + ]: 11390 : if (noncoll) ndij1=4
5320 : 11390 : ndij1=min(ndij1,my_ndij)
5321 : 11390 : ndij0=ndij1-1
5322 [ - + + - : 56950 : LIBPAW_ALLOCATE(dijnew,(my_cplex_dij,ndij1,my_qphase))
- + + - -
+ + - + -
+ - - + -
+ ]
5323 : :
5324 : : ! Loops over atoms and spin components
5325 [ + + ]: 37748 : do iatom=1,my_natom
5326 [ + + ]: 26358 : iatom_tot=iatom;if (paral_atom) iatom_tot=my_atmtab(iatom)
5327 : 26358 : itypat=paw_ij(iatom)%itypat
5328 : 26358 : lmn_size=paw_ij(iatom)%lmn_size
5329 : 26358 : lmn2_size=paw_ij(iatom)%lmn2_size
5330 : 26358 : cplex_dij=min(paw_ij(iatom)%cplex_dij,my_cplex_dij)
5331 : 26358 : qphase=min(paw_ij(iatom)%qphase,my_qphase)
5332 : 26358 : indlmn => pawtab(itypat)%indlmn
5333 : :
5334 : : !DEBUG_ALTERNATE_ALGO
5335 : : ! if (noncoll.and.lsymnew) then
5336 : : ! LIBPAW_ALLOCATE(dijtemp,(cplex_dij,my_ndij))
5337 : : ! end if
5338 : : !DEBUG_ALTERNATE_ALGO
5339 : :
5340 [ + + ]: 67862 : do ispden=1,paw_ij(iatom)%nsppol
5341 : 30114 : jspden=min(3-ispden,paw_ij(iatom)%nsppol)
5342 : :
5343 : : ! Loops over (il,im) and (jl,jm)
5344 : 30114 : jl0=-1;jln0=-1;indexj=1
5345 [ + + ]: 391332 : do jlmn=1,lmn_size
5346 : 334860 : jl=indlmn(1,jlmn)
5347 : 334860 : jlpm=1+jl+indlmn(2,jlmn)
5348 : 334860 : jln=indlmn(5,jlmn)
5349 [ + + ]: 334860 : if (jln/=jln0) indexj=indexj+2*jl0+1
5350 : 334860 : j0lmn=jlmn*(jlmn-1)/2
5351 : 334860 : il0=-1;iln0=-1;indexi=1
5352 [ + + ]: 2770049 : do ilmn=1,jlmn
5353 : 2435189 : il=indlmn(1,ilmn)
5354 : 2435189 : ilpm=1+il+indlmn(2,ilmn)
5355 : 2435189 : iln=indlmn(5,ilmn)
5356 [ + + ]: 2435189 : if (iln/=iln0) indexi=indexi+2*il0+1
5357 : 2435189 : klmn=j0lmn+ilmn;klmnc=cplex_dij*(klmn-1)
5358 : :
5359 : 2435189 : nsym_used(:)=0
5360 : :
5361 : 2435189 : rotdij(:,:,:)=zero
5362 [ + + ]: 2435189 : if (noncoll) rotmag(:,:,:)=zero
5363 : : !DEBUG_ALTERNATE_ALGO
5364 : : ! if (noncoll.and.lsymnew) sumrhoso(:,:)=zero
5365 : : !DEBUG_ALTERNATE_ALGO
5366 : :
5367 : : ! Loop over symmetries
5368 [ + + ]: 85596629 : do irot=1,nsym
5369 : : !DEBUG_ALTERNATE_ALGO
5370 : : ! if(lsymnew) then
5371 : : ! call mati3inv(symrec(:,:,irot),symrel_conv)
5372 : : ! call getspinrot(rprimd,spinrot,symrel_conv)
5373 : : ! Rspinrot(1,1)=cmplx(spinrot(1),-spinrot(4))
5374 : : ! Rspinrot(1,2)=cmplx(-spinrot(3),-spinrot(2))
5375 : : ! Rspinrot(2,1)=cmplx(spinrot(3),-spinrot(2))
5376 : : ! Rspinrot(2,2)=cmplx(spinrot(1),spinrot(4))
5377 : : ! end if
5378 : : !DEBUG_ALTERNATE_ALGO
5379 [ + + + + ]: 83161440 : if ((symafm(irot)/=1).and.(.not.use_afm)) cycle
5380 [ + + ]: 80948064 : kspden=ispden;if (symafm(irot)==-1) kspden=jspden
5381 [ + + + + ]: 80948064 : iafm=1;if ((antiferro).and.(symafm(irot)==-1)) iafm=2
5382 : 80948064 : factafm=dble(symafm(irot))
5383 : :
5384 : 80948064 : nsym_used(iafm)=nsym_used(iafm)+1
5385 : 80948064 : at_indx=indsym(4,irot,iatom_tot)
5386 : :
5387 [ + + ]: 80948064 : if (has_qphase) then
5388 : : arg=two_pi*(qphon(1)*indsym(1,irot,iatom)+qphon(2)*indsym(2,irot,iatom) &
5389 : 14904 : & +qphon(3)*indsym(3,irot,iatom))
5390 : 14904 : phase(1)=cos(arg);phase(2)=sin(arg)
5391 : : end if
5392 : :
5393 : 80948064 : sumdij(:,:,:)=zero
5394 [ + + ]: 80948064 : if (noncoll) summag(:,:,:)=zero
5395 : :
5396 : : ! Accumulate values over (mi,mj) and symmetries
5397 [ + + ]: 430615332 : do mj=1,2*jl+1
5398 : 349667268 : indexjj=indexj+mj;indexjj0=indexjj*(indexjj-1)/2
5399 [ + + ]: 1601976020 : do mi=1,2*il+1
5400 : 1171360688 : indexii=indexi+mi
5401 [ + + ]: 3514082064 : factsym(:)=one
5402 [ + + ]: 1171360688 : if (indexii<=indexjj) then
5403 : 1024838624 : indexk=indexjj0+indexii
5404 : 1024838624 : factsym(2)=one
5405 : : else
5406 : 146522064 : indexk=indexii*(indexii-1)/2+indexjj
5407 : 146522064 : factsym(2)=-one
5408 : : end if
5409 : 1171360688 : indexkc=cplex_dij*(indexk-1)
5410 : 1171360688 : indexkc_q=indexkc+cplex_dij*lmn2_size
5411 : :
5412 : : !DEBUG_ALTERNATE_ALGO
5413 : : ! if (noncoll.and.lsymnew) then
5414 : : ! do iplex=1,cplex_dij
5415 : : ! if(factafm>zero) then
5416 : : ! dijtemp(iplex,1)=factsym(iplex)*tmp_dij(at_indx)%value(indexkc+iplex,1)
5417 : : ! dijtemp(iplex,2)=factsym(iplex)*tmp_dij(at_indx)%value(indexkc+iplex,2)
5418 : : ! else
5419 : : ! dijtemp(iplex,1)=factsym(iplex)*tmp_dij(at_indx)%value(indexkc+iplex,2)
5420 : : ! dijtemp(iplex,2)=factsym(iplex)*tmp_dij(at_indx)%value(indexkc+iplex,1)
5421 : : ! end if
5422 : : ! if(factsym(2)<zero) then ! to be changed if symafm
5423 : : ! dijtemp(iplex,3)=factafm*factsym(iplex)*tmp_dij(at_indx)%value(indexkc+iplex,4)
5424 : : ! dijtemp(iplex,4)=factafm*factsym(iplex)*tmp_dij(at_indx)%value(indexkc+iplex,3)
5425 : : ! else
5426 : : ! dijtemp(iplex,3)=factafm*factsym(iplex)*tmp_dij(at_indx)%value(indexkc+iplex,3)
5427 : : ! dijtemp(iplex,4)=factafm*factsym(iplex)*tmp_dij(at_indx)%value(indexkc+iplex,4)
5428 : : ! end if
5429 : : ! end do
5430 : : ! end if
5431 : : !DEBUG_ALTERNATE_ALGO
5432 : :
5433 : : ! Be careful: use here R_rel^-1 in term of spherical harmonics
5434 : : ! which is tR_rec in term of spherical harmonics
5435 : : ! so, use transpose[zarot].... however, we use here zarot (??)
5436 : 1171360688 : zarot2=pawang%zarot(mi,ilpm,il+1,irot)*pawang%zarot(mj,jlpm,jl+1,irot)
5437 : : ! zarot2=pawang%zarot(ilpm,mi,il+1,irot)*pawang%zarot(jlpm,mj,jl+1,irot)
5438 : :
5439 : : if((.not.noncoll).or.(.not.lsymnew)) then
5440 : 1171360688 : fact(1)=factsym(1);fact(2)=factsym(2)*factafm !????? What? MT
5441 : : sumdij(1:cplex_dij,iafm,1)=sumdij(1:cplex_dij,iafm,1) &
5442 : : & +fact(1:cplex_dij)*zarot2 &
5443 [ + + ]: 2380258592 : & *tmp_dij(at_indx)%value(indexkc+1:indexkc+cplex_dij,kspden)
5444 [ + + ]: 1171360688 : if (qphase==2) &
5445 : : & sumdij(1:cplex_dij,iafm,2)=sumdij(1:cplex_dij,iafm,2) &
5446 : : & +fact(1:cplex_dij)*zarot2 &
5447 [ + + ]: 261744 : & *tmp_dij(at_indx)%value(indexkc_q+1:indexkc_q+cplex_dij,kspden)
5448 : : end if
5449 : :
5450 [ + + ]: 1521027956 : if (noncoll.and.(.not.lsymnew)) then
5451 : 37477024 : fact(1)=factsym(1)*factafm;fact(2)=factsym(2)
5452 [ + + ]: 149908096 : do mu=1,3
5453 : : summag(1:cplex_dij,mu,1)=summag(1:cplex_dij,mu,1) &
5454 : : & +fact(1:cplex_dij)*zarot2 &
5455 [ + + ]: 374770240 : & *tmp_dij(at_indx)%value(indexkc+1:indexkc+cplex_dij,1+mu)
5456 : : end do
5457 [ - + ]: 37477024 : if (qphase==2) then
5458 [ # # ]: 0 : do mu=1,3
5459 : : summag(1:cplex_dij,mu,2)=summag(1:cplex_dij,mu,2) &
5460 : : & +fact(1:cplex_dij)*zarot2 &
5461 [ # # ]: 0 : & *tmp_dij(at_indx)%value(indexkc_q+1:indexkc_q+cplex_dij,1+mu)
5462 : : end do
5463 : : end if
5464 : : end if
5465 : : !DEBUG_ALTERNATE_ALGO
5466 : : ! if (noncoll.and.(lsymnew)) then
5467 : : ! dijt(1,1)=cmplx(dijtemp(1,1),dijtemp(2,1))
5468 : : ! dijt(2,2)=cmplx(dijtemp(1,2),dijtemp(2,2))
5469 : : ! dijt(1,2)=cmplx(dijtemp(1,3),dijtemp(2,3))
5470 : : ! dijt(2,1)=cmplx(dijtemp(1,4),dijtemp(2,4))
5471 : : ! dijt2(:,:)=czero
5472 : : ! do i1=1,2
5473 : : ! do i4=1,2
5474 : : ! do i2=1,2
5475 : : ! do i3=1,2
5476 : : ! dijt2(i1,i4)=dijt2(i1,i4)+Rspinrot(i1,i2)*dijt(i2,i3)*conjg(Rspinrot(i4,i3))
5477 : : ! end do
5478 : : ! end do
5479 : : ! end do
5480 : : ! end do
5481 : : ! do mu=1,4
5482 : : ! if(mu==1) then
5483 : : ! i1=1;i4=1
5484 : : ! else if(mu==2) then
5485 : : ! i1=2;i4=2
5486 : : ! else if(mu==3) then
5487 : : ! i1=1;i4=2
5488 : : ! else if(mu==4) then
5489 : : ! i1=2;i4=1
5490 : : ! end if
5491 : : ! sumrhoso(1,mu)=sumrhoso(1,mu)+zarot2*real(dijt2(i1,i4))
5492 : : ! sumrhoso(2,mu)=sumrhoso(2,mu)+zarot2*imag(dijt2(i1,i4))
5493 : : ! end do
5494 : : ! end if
5495 : : end do ! mi
5496 : : end do ! mj
5497 : : !DEBUG_ALTERNATE_ALGO
5498 : :
5499 : : ! Apply phase for phonons
5500 [ + + ]: 80948064 : if (has_qphase) then
5501 : : !Remember, Dij is stored as follows:
5502 : : ! Dij= [Dij(2klmn-1)+i.Dij(2klmn)]
5503 : : ! +i.[Dij(lnm2_size+2klmn-1)+i.Dij(lmn2_size+2klmn)]
5504 : : if((.not.noncoll).or.(.not.lsymnew)) then
5505 [ + + ]: 29808 : do iplex=1,cplex_dij
5506 : 14904 : dijc(1)=sumdij(iplex,iafm,1)
5507 : 14904 : dijc(2)=sumdij(iplex,iafm,2)
5508 : 14904 : sumdij(iplex,iafm,1)=phase(1)*dijc(1)-phase(2)*dijc(2)
5509 : 29808 : sumdij(iplex,iafm,2)=phase(1)*dijc(2)+phase(2)*dijc(1)
5510 : : end do
5511 : : end if
5512 [ - + ]: 14904 : if (noncoll.and.(.not.lsymnew)) then
5513 [ # # ]: 0 : do iplex=1,cplex_dij
5514 [ # # ]: 0 : do mu=1,3
5515 : 0 : dijc(1)=summag(iplex,mu,1)
5516 : 0 : dijc(2)=summag(iplex,mu,2)
5517 : 0 : summag(iplex,mu,1)=phase(1)*dijc(1)-phase(2)*dijc(2)
5518 : 0 : summag(iplex,mu,2)=phase(1)*dijc(2)+phase(2)*dijc(1)
5519 : : end do
5520 : : end do
5521 : : end if
5522 : : !DEBUG_ALTERNATE_ALGO
5523 : : ! if (noncoll.and.(lsymnew) then
5524 : : ! do mu=1,4
5525 : : ! sumrhoso(1,mu)=phase(1)*sumrhoso(1,mu)-phase(2)*sumrhoso(2,mu)
5526 : : ! sumrhoso(2,mu)=phase(1)*sumrhoso(2,mu)+phase(2)*sumrhoso(1,mu)
5527 : : ! end do
5528 : : ! end do
5529 : : ! end if
5530 : : !DEBUG_ALTERNATE_ALGO
5531 : : end if
5532 : :
5533 : : ! Add contribution of this rotation
5534 [ + + ]: 161911032 : do iq=1,qphase
5535 : : rotdij(1:cplex_dij,iafm,iq)=rotdij(1:cplex_dij,iafm,iq) &
5536 [ + + ]: 244978352 : & +sumdij(1:cplex_dij,iafm,iq)
5537 : : end do
5538 [ + + ]: 83383253 : if (noncoll.and.(.not.lsymnew)) then
5539 : : ! If non-collinear case, rotate Dij magnetization
5540 : : ! Should use symrel^1 but use transpose[symrec] instead
5541 [ + + ]: 4189696 : do iq=1,qphase
5542 [ + + ]: 10474240 : do nu=1,3
5543 [ + + ]: 27233024 : do mu=1,3
5544 : : !We need the transpose ?
5545 : : rotmag(1:cplex_dij,mu,iq)=rotmag(1:cplex_dij,mu,iq) &
5546 [ + + ]: 62845440 : & +symrec_det(irot)*symrec_cart(mu,nu,irot)*summag(1:cplex_dij,nu,iq)
5547 : : end do
5548 : : end do
5549 : : end do
5550 : : end if
5551 : :
5552 : : end do ! End loop over symmetries
5553 : :
5554 : : if((.not.noncoll).or.(.not.lsymnew)) then
5555 : : ! Store new value of dij
5556 [ + + ]: 4877830 : do iq=1,qphase
5557 [ + + ]: 7604315 : do iplex=1,cplex_dij
5558 : 2726485 : dijnew(iplex,1,iq)=rotdij(iplex,1,iq)/nsym_used(1)
5559 [ + + ]: 5169126 : if (abs(dijnew(iplex,1,iq))<=tol10) dijnew(iplex,1,iq)=zero
5560 : : end do
5561 : : end do
5562 : :
5563 : : ! Antiferromagnetic case: has to fill up "down" component of dij
5564 [ + + + - ]: 2435189 : if (antiferro.and.nsym_used(2)>0) then
5565 [ + + ]: 152900 : do iq=1,qphase
5566 [ + + ]: 229350 : do iplex=1,cplex_dij
5567 : 76450 : dijnew(iplex,2,iq)=rotdij(iplex,2,iq)/nsym_used(2)
5568 [ + + ]: 152900 : if (abs(dijnew(iplex,2,iq))<=tol10) dijnew(iplex,2,iq)=zero
5569 : : end do
5570 : : end do
5571 : : end if
5572 : : !DEBUG_ALTERNATE_ALGO
5573 : : ! else if (noncoll.and.(lsymnew)) then
5574 : : ! do mu=1,4
5575 : : ! do iplex=1,cplex_dij
5576 : : ! dijnew(iplex,mu,1)=sumrhoso(iplex,mu)/nsym_used(1)
5577 : : ! if (abs(dijnew(iplex,mu,1))<=tol10) dijnew(iplex,mu,1)=zero
5578 : : ! end do
5579 : : ! end do
5580 : : !DEBUG_ALTERNATE_ALGO
5581 : : end if
5582 : :
5583 : : ! Non-collinear case: store new values of Dij magnetization
5584 [ + + ]: 2435189 : if (noncoll.and.(.not.lsymnew)) then
5585 : : ! Select on-zero elements
5586 [ + + ]: 562936 : do iq=1,qphase
5587 [ + + ]: 1407340 : do mu=1,3
5588 [ + + ]: 2814680 : do iplex=1,cplex_dij
5589 : 1688808 : rotmag(iplex,mu,iq)=rotmag(iplex,mu,iq)/nsym_used(1)
5590 [ + + ]: 2533212 : if (abs(rotmag(iplex,mu,iq))<=tol10) rotmag(iplex,mu,iq)=zero
5591 : : end do
5592 : : end do
5593 : : end do
5594 : : ! Transfer back to Dij^{alpha,beta}
5595 : : if(.not.lsymnew) then
5596 : : !Remember: cplex_dij is 2 in that case
5597 [ + + ]: 562936 : do iq=1,qphase
5598 : 281468 : dijnew(1,1,iq)=half*(dijnew(1,1,iq)+rotmag(1,3,iq))
5599 : 281468 : dijnew(2,1,iq)=half*(dijnew(2,1,iq)+rotmag(2,3,iq))
5600 : 281468 : dijnew(1,2,iq)= dijnew(1,1,iq)-rotmag(1,3,iq)
5601 : 281468 : dijnew(2,2,iq)= dijnew(2,1,iq)-rotmag(2,3,iq)
5602 : 281468 : dijnew(1,3,iq)=half*(rotmag(1,1,iq)+rotmag(2,2,iq))
5603 : 281468 : dijnew(2,3,iq)=half*(rotmag(2,1,iq)-rotmag(1,2,iq))
5604 : 281468 : dijnew(1,4,iq)=half*(rotmag(1,1,iq)-rotmag(2,2,iq))
5605 : 562936 : dijnew(2,4,iq)=half*(rotmag(2,1,iq)+rotmag(1,2,iq))
5606 : : end do
5607 : : end if
5608 : : end if
5609 : : ! Transfer new value of Dij in suitable pointer
5610 : : ii=klmnc
5611 [ + + ]: 4877830 : do iq=1,qphase
5612 [ + + - + : 2442641 : if (option_dij==0) then
+ + - - -
- + - - ]
5613 [ + + + + ]: 10268944 : paw_ij(iatom)%dij(ii+1:ii+cplex_dij,ispden:ispden+ndij0)=dijnew(1:cplex_dij,1:ndij1,iq)
5614 : : else if (option_dij==1) then
5615 [ + + + + ]: 4833 : paw_ij(iatom)%dijhat(ii+1:ii+cplex_dij,ispden:ispden+ndij0)=dijnew(1:cplex_dij,1:ndij1,iq)
5616 : : else if (option_dij==2) then
5617 [ # # # # ]: 0 : paw_ij(iatom)%dijU(ii+1:ii+cplex_dij,ispden:ispden+ndij0)=dijnew(1:cplex_dij,1:ndij1,iq)
5618 : : else if (option_dij==3) then
5619 [ + + + + ]: 4833 : paw_ij(iatom)%dijxc(ii+1:ii+cplex_dij,ispden:ispden+ndij0)=dijnew(1:cplex_dij,1:ndij1,iq)
5620 : : else if (option_dij==4) then
5621 [ + + + + ]: 4833 : paw_ij(iatom)%dijxc_hat(ii+1:ii+cplex_dij,ispden:ispden+ndij0)=dijnew(1:cplex_dij,1:ndij1,iq)
5622 : : else if (option_dij==5) then
5623 [ + + + + ]: 4833 : paw_ij(iatom)%dijxc_val(ii+1:ii+cplex_dij,ispden:ispden+ndij0)=dijnew(1:cplex_dij,1:ndij1,iq)
5624 : : else if (option_dij==6) then
5625 [ # # # # ]: 0 : paw_ij(iatom)%dijso(ii+1:ii+cplex_dij,ispden:ispden+ndij0)=dijnew(1:cplex_dij,1:ndij1,iq)
5626 : : else if (option_dij==7) then
5627 [ # # # # ]: 0 : paw_ij(iatom)%dijexxc(ii+1:ii+cplex_dij,ispden:ispden+ndij0)=dijnew(1:cplex_dij,1:ndij1,iq)
5628 : : else if (option_dij==8) then
5629 [ # # # # ]: 0 : paw_ij(iatom)%dijfr(ii+1:ii+cplex_dij,ispden:ispden+ndij0)=dijnew(1:cplex_dij,1:ndij1,iq)
5630 : : else if (option_dij==9) then
5631 [ # # # # ]: 0 : paw_ij(iatom)%dijnd(ii+1:ii+cplex_dij,ispden:ispden+ndij0)=dijnew(1:cplex_dij,1:ndij1,iq)
5632 : : else if (option_dij==10) then
5633 [ + + ]: 6402 : paw_ij(iatom)%dijhartree(ii+1:ii+cplex_dij)=dijnew(1:cplex_dij,1,iq)
5634 : : else if (option_dij==11) then
5635 [ # # # # ]: 0 : paw_ij(iatom)%dijfock(ii+1:ii+cplex_dij,ispden:ispden+ndij0)=dijnew(1:cplex_dij,1:ndij1,iq)
5636 : : end if
5637 : 4877830 : ii=ii+lmn2_size*cplex_dij
5638 : : end do
5639 : :
5640 : 2770049 : il0=il;iln0=iln ! End loops over (il,im) and (jl,jm)
5641 : : end do
5642 : 364974 : jl0=jl;jln0=jln
5643 : : end do
5644 : :
5645 : : end do ! ispden
5646 : :
5647 : : !DEBUG_ALTERNATE_ALGO
5648 : : ! if (noncoll.and.lsymnew) then
5649 : : ! LIBPAW_DEALLOCATE(dijtemp)
5650 : : ! end if
5651 : : !DEBUG_ALTERNATE_ALGO
5652 : :
5653 : : end do ! iatom
5654 : :
5655 [ - + ]: 11390 : LIBPAW_DEALLOCATE(dijnew)
5656 [ + + ]: 11390 : if (noncoll) then
5657 [ - + ]: 1281 : LIBPAW_DEALLOCATE(symrec_cart)
5658 [ - + ]: 1281 : LIBPAW_DEALLOCATE(symrec_det)
5659 : : !DEBUG_ALTERNATE_ALGO
5660 : : ! if (lsymnew) then
5661 : : ! LIBPAW_DEALLOCATE(sumrhoso)
5662 : : ! end if
5663 : : !DEBUG_ALTERNATE_ALGO
5664 : : end if
5665 : :
5666 [ + + ]: 11390 : if (paral_atom) then
5667 [ + + ]: 13272 : do iatom=1,natom
5668 [ - + ]: 13272 : LIBPAW_DEALLOCATE(tmp_dij(iatom)%value)
5669 : : end do
5670 [ - + ]: 3264 : LIBPAW_DATATYPE_DEALLOCATE(tmp_dij)
5671 : : else
5672 [ + + ]: 31152 : do iatom=1,my_natom
5673 [ - + ]: 31152 : LIBPAW_DEALLOCATE(my_tmp_dij(iatom)%value)
5674 : : end do
5675 [ + - + + : 31152 : LIBPAW_DATATYPE_DEALLOCATE(my_tmp_dij)
- + - + ]
5676 : : end if
5677 : :
5678 [ + + + + ]: 9360 : else if (ipert/=natom+1.and.ipert/=natom+10) then ! nsym>1
5679 : :
5680 : : ! *********************************************************************
5681 : : ! If nsym==1, only cut small components of dij
5682 : :
5683 [ - + ]: 8469 : if (antiferro) then
5684 : 0 : msg='In the antiferromagnetic case, nsym cannot be 1'
5685 : 0 : LIBPAW_BUG(msg)
5686 : : end if
5687 : :
5688 [ + + ]: 25906 : do iatom=1,my_natom
5689 [ + + ]: 48312 : do ispden=1,my_ndij
5690 : 22406 : qphase=paw_ij(iatom)%qphase
5691 : 22406 : cplex_dij=paw_ij(iatom)%cplex_dij
5692 : 22406 : lmn2_size=paw_ij(iatom)%lmn2_size
5693 [ + - - - : 39843 : if (option_dij==0) then
- - - - -
- - - ]
5694 [ + + ]: 951890 : do klmn=1,lmn2_size*cplex_dij*qphase
5695 [ + + ]: 951890 : if (abs(paw_ij(iatom)%dij(klmn,ispden))<=tol10) paw_ij(iatom)%dij(klmn,ispden)=zero
5696 : : end do
5697 : : else if (option_dij==1) then
5698 [ # # ]: 0 : do klmn=1,lmn2_size*cplex_dij*qphase
5699 [ # # ]: 0 : if (abs(paw_ij(iatom)%dijhat(klmn,ispden))<=tol10) paw_ij(iatom)%dijhat(klmn,ispden)=zero
5700 : : end do
5701 : : else if (option_dij==2) then
5702 [ # # ]: 0 : do klmn=1,lmn2_size*cplex_dij*qphase
5703 [ # # ]: 0 : if (abs(paw_ij(iatom)%dijU(klmn,ispden))<=tol10) paw_ij(iatom)%dijU(klmn,ispden)=zero
5704 : : end do
5705 : : else if (option_dij==3) then
5706 [ # # ]: 0 : do klmn=1,lmn2_size*cplex_dij*qphase
5707 [ # # ]: 0 : if (abs(paw_ij(iatom)%dijxc(klmn,ispden))<=tol10) paw_ij(iatom)%dijxc(klmn,ispden)=zero
5708 : : end do
5709 : : else if (option_dij==4) then
5710 [ # # ]: 0 : do klmn=1,lmn2_size*cplex_dij
5711 [ # # ]: 0 : if (abs(paw_ij(iatom)%dijxc_hat(klmn,ispden))<=tol10) paw_ij(iatom)%dijxc_hat(klmn,ispden)=zero
5712 : : end do
5713 : : else if (option_dij==5) then
5714 [ # # ]: 0 : do klmn=1,lmn2_size*cplex_dij
5715 [ # # ]: 0 : if (abs(paw_ij(iatom)%dijxc_val(klmn,ispden))<=tol10) paw_ij(iatom)%dijxc_val(klmn,ispden)=zero
5716 : : end do
5717 : : else if (option_dij==6) then
5718 [ # # ]: 0 : do klmn=1,lmn2_size*cplex_dij*qphase
5719 [ # # ]: 0 : if (abs(paw_ij(iatom)%dijso(klmn,ispden))<=tol10) paw_ij(iatom)%dijso(klmn,ispden)=zero
5720 : : end do
5721 : : else if (option_dij==7) then
5722 [ # # ]: 0 : do klmn=1,lmn2_size*cplex_dij*qphase
5723 [ # # ]: 0 : if (abs(paw_ij(iatom)%dijexxc(klmn,ispden))<=tol10) paw_ij(iatom)%dijexxc(klmn,ispden)=zero
5724 : : end do
5725 : : else if (option_dij==8) then
5726 [ # # ]: 0 : do klmn=1,lmn2_size*cplex_dij*qphase
5727 [ # # ]: 0 : if (abs(paw_ij(iatom)%dijfr(klmn,ispden))<=tol10) paw_ij(iatom)%dijfr(klmn,ispden)=zero
5728 : : end do
5729 : : else if (option_dij==9) then
5730 [ # # ]: 0 : do klmn=1,lmn2_size*cplex_dij
5731 [ # # ]: 0 : if (abs(paw_ij(iatom)%dijnd(klmn,ispden))<=tol10) paw_ij(iatom)%dijnd(klmn,ispden)=zero
5732 : : end do
5733 [ # # ]: 0 : else if (option_dij==10.and.ispden==1) then
5734 [ # # ]: 0 : do klmn=1,lmn2_size*qphase
5735 [ # # ]: 0 : if (abs(paw_ij(iatom)%dijhartree(klmn))<=tol10) paw_ij(iatom)%dijhartree(klmn)=zero
5736 : : end do
5737 [ # # ]: 0 : else if (option_dij==11) then
5738 [ # # ]: 0 : do klmn=1,lmn2_size*cplex_dij*qphase
5739 [ # # ]: 0 : if (abs(paw_ij(iatom)%dijfock(klmn,ispden))<=tol10) paw_ij(iatom)%dijfock(klmn,ispden)=zero
5740 : : end do
5741 : : end if
5742 : : end do
5743 : : end do
5744 : :
5745 : : end if ! nsym>1
5746 : :
5747 : : !*********************************************************************
5748 : : !Printing of Dij
5749 : :
5750 [ + + + + : 20750 : if (abs(pawprtvol)>=1.and.option_dij==0.and.ipert/=natom+1.and.ipert/=natom+10) then
+ - + - ]
5751 [ + + ]: 1620 : wrt_mode='COLL';if (paral_atom) wrt_mode='PERS'
5752 [ - + ]: 1620 : pertstrg="DIJ";if (ipert>0) pertstrg="DIJ(1)"
5753 [ + + + + ]: 1620 : natinc=1;if(my_natom>1.and.pawprtvol>=0) natinc=my_natom-1
5754 : 1620 : write(msg, '(7a)') ch10," PAW TEST:",ch10,&
5755 : 3240 : & ' ========= Values of ',trim(pertstrg),' after symetrization =========',ch10
5756 : 1620 : call wrtout(std_out,msg,wrt_mode)
5757 [ - + + + ]: 3677 : do iatom=1,my_natom,natinc
5758 [ + + ]: 2057 : iatom_tot=iatom; if (paral_atom) iatom_tot=my_atmtab(iatom)
5759 : : call pawdij_print_dij(paw_ij(iatom)%dij,paw_ij(iatom)%cplex_dij,paw_ij(iatom)%qphase,&
5760 : 3677 : & iatom_tot,natom,paw_ij(iatom)%nspden,opt_prtvol=pawprtvol,mode_paral=wrt_mode)
5761 : : end do
5762 : 1620 : call wrtout(std_out,"",wrt_mode)
5763 : : end if
5764 : :
5765 : : !Destroy atom table used for parallelism
5766 [ + + - + : 41500 : call free_my_atmtab(my_atmtab,my_atmtab_allocated)
- + - + -
- - - ]
5767 : :
5768 : : !*********************************************************************
5769 : : !Small function: convert a symmetry operation
5770 : : !from reduced coordinates (integers) to cartesian coordinates (reals)
5771 : : contains
5772 [ - + ]: 8964 : function symdij_symcart(aprim,bprim,symred)
5773 : :
5774 : : real(dp) :: symdij_symcart(3,3)
5775 : : integer,intent(in) :: symred(3,3)
5776 : : real(dp),intent(in) :: aprim(3,3),bprim(3,3)
5777 : : integer :: ii,jj,kk
5778 : : real(dp) :: tmp(3,3)
5779 [ + + + + ]: 116532 : symdij_symcart=zero;tmp=zero
5780 [ + + ]: 35856 : do kk=1,3
5781 [ + + ]: 116532 : do jj=1,3
5782 [ + + ]: 349596 : do ii=1,3
5783 : 322704 : tmp(ii,jj)=tmp(ii,jj)+bprim(ii,kk)*dble(symred(jj,kk))
5784 : : end do
5785 : : end do
5786 : : end do
5787 [ + + ]: 35856 : do kk=1,3
5788 [ + + ]: 116532 : do jj=1,3
5789 [ + + ]: 349596 : do ii=1,3
5790 : 322704 : symdij_symcart(ii,jj)=symdij_symcart(ii,jj)+aprim(ii,kk)*tmp(jj,kk)
5791 : : end do
5792 : : end do
5793 : : end do
5794 : : end function symdij_symcart
5795 : :
5796 : : end subroutine symdij
5797 : : !!***
5798 : :
5799 : : !----------------------------------------------------------------------
5800 : :
5801 : : !!****f* m_pawdij/symdij_all
5802 : : !! NAME
5803 : : !! symdij_all
5804 : : !!
5805 : : !! FUNCTION
5806 : : !! Symmetrize all contributions to PAW non-local strengths Dij
5807 : : !!
5808 : : !! INPUTS
5809 : : !! gprimd(3,3)=dimensional primitive translations for reciprocal space(bohr^-1).
5810 : : !! indsym(4,nsym,natom)=indirect indexing array for atom labels
5811 : : !! ipert=index of perturbation if pawrhoij is a pertubed rhoij
5812 : : !! no meaning for ground-state calculations (should be 0)
5813 : : !! mpi_atmtab(:)=--optional-- indexes of the atoms treated by current proc
5814 : : !! comm_atom=--optional-- MPI communicator over atoms
5815 : : !! my_natom=number of atoms treated by current processor
5816 : : !! natom=number of atoms in cell
5817 : : !! nsym=number of symmetry elements in space group
5818 : : !! ntypat=number of types of atoms in unit cell.
5819 : : !! paw_ij(natom)%cplex_dij=1 if dij are REAL, 2 if they are COMPLEX
5820 : : !! paw_ij(natom)%qphase=2 if exp^(-i.q.r) phase from RF at q<>0, 1 otherwise
5821 : : !! paw_ij(natom)%lmn_size=number of (l,m,n) elements for the paw basis
5822 : : !! paw_ij(natom)%nspden=number of spin-density components
5823 : : !! paw_ij(natom)%nsppol=number of independent spin-density components
5824 : : !! paw_ij(natom)%dij(lmn2_size,nspden)=non-symmetrized paw dij quantities
5825 : : !! pawang <type(pawang_type)>=angular mesh discretization and related data
5826 : : !! pawprtvol=control print volume and debugging output for PAW
5827 : : !! pawtab(ntypat) <type(pawtab_type)>=paw tabulated starting data
5828 : : !! rprimd(3,3)=real space primitive translations.
5829 : : !! symafm(nsym)=(anti)ferromagnetic part of symmetry operations
5830 : : !! symrec(3,3,nsym)=symmetries of group in terms of operations on
5831 : : !! reciprocal space primitive translations
5832 : : !!
5833 : : !! SIDE EFFECTS
5834 : : !! paw_ij(natom)%dij???(cplex_dij*qphase*lmn2_size,nspden)=symmetrized dij quantities as output
5835 : : !!
5836 : : !! SOURCE
5837 : :
5838 : 20 : subroutine symdij_all(gprimd,indsym,ipert,my_natom,natom,nsym,ntypat,&
5839 : 20 : & paw_ij,pawang,pawprtvol,pawtab,rprimd,symafm,symrec,&
5840 [ - + - - : 10 : & mpi_atmtab,comm_atom) ! optional arguments (parallelism)
- - ]
5841 : :
5842 : : !Arguments ---------------------------------------------
5843 : : !scalars
5844 : : integer,intent(in) :: ipert,my_natom,natom,nsym,ntypat,pawprtvol
5845 : : integer,optional,intent(in) :: comm_atom
5846 : : type(pawang_type),intent(in) :: pawang
5847 : : !arrays
5848 : : integer,intent(in) :: indsym(4,nsym,natom),symafm(nsym),symrec(3,3,nsym)
5849 : : integer,optional,target,intent(in) :: mpi_atmtab(:)
5850 : : real(dp),intent(in) :: gprimd(3,3),rprimd(3,3)
5851 : : type(paw_ij_type),intent(inout) :: paw_ij(my_natom)
5852 : : type(pawtab_type),intent(in) :: pawtab(ntypat)
5853 : :
5854 : : !Local variables ---------------------------------------
5855 : : !scalars
5856 : : integer,parameter :: MAX_NOPTS=12
5857 : : integer :: ii,option_dij,my_comm_atom,nopt
5858 : : logical :: my_atmtab_allocated,paral_atom
5859 : : character(len=500) :: msg
5860 : : !arrays
5861 : : integer :: options(MAX_NOPTS)
5862 : 10 : integer,pointer :: my_atmtab(:)
5863 : :
5864 : : ! *********************************************************************
5865 : :
5866 : 10 : nopt = 0
5867 [ + - - + : 10 : if (ANY(paw_ij(:)%has_dij==2)) then
+ - ]
5868 : 10 : nopt = nopt + 1
5869 : 10 : options(nopt) = 0
5870 : : end if
5871 : :
5872 [ + + + + : 41 : if (ANY(paw_ij(:)%has_dijhat==2)) then
+ + ]
5873 : 5 : nopt = nopt + 1
5874 : 5 : options(nopt) = 1
5875 : : end if
5876 : :
5877 [ + + + - : 72 : if (ANY(paw_ij(:)%has_dijU==2)) then
- + ]
5878 : 0 : nopt = nopt + 1
5879 : 0 : options(nopt) = 2
5880 : : end if
5881 : :
5882 [ + + + + : 41 : if (ANY(paw_ij(:)%has_dijxc==2)) then
+ + ]
5883 : 5 : nopt = nopt + 1
5884 : 5 : options(nopt) = 3
5885 : : end if
5886 : :
5887 [ + + + + : 41 : if (ANY(paw_ij(:)%has_dijxc_hat==2)) then
+ + ]
5888 : 5 : nopt = nopt + 1
5889 : 5 : options(nopt) = 4
5890 : : end if
5891 : :
5892 [ + + + + : 41 : if (ANY(paw_ij(:)%has_dijxc_val==2)) then
+ + ]
5893 : 5 : nopt = nopt + 1
5894 : 5 : options(nopt) = 5
5895 : : end if
5896 : :
5897 [ + + + - : 72 : if (ANY(paw_ij(:)%has_dijso==2)) then
- + ]
5898 : 0 : nopt = nopt + 1
5899 : 0 : options(nopt) = 6
5900 : : end if
5901 : :
5902 [ + + + - : 72 : if (ANY(paw_ij(:)%has_dijexxc==2)) then
- + ]
5903 : 0 : nopt = nopt + 1
5904 : 0 : options(nopt) = 7
5905 : : end if
5906 : :
5907 [ + + + - : 72 : if (ANY(paw_ij(:)%has_dijfr==2)) then
- + ]
5908 : 0 : nopt = nopt + 1
5909 : 0 : options(nopt) = 8
5910 : : end if
5911 : :
5912 [ + + + - : 72 : if (ANY(paw_ij(:)%has_dijnd==2)) then
- + ]
5913 : 0 : nopt = nopt + 1
5914 : 0 : options(nopt) = 9
5915 : : end if
5916 : :
5917 [ + - - + : 10 : if (ANY(paw_ij(:)%has_dijhartree==2)) then
+ - ]
5918 : 10 : nopt = nopt + 1
5919 : 10 : options(nopt) = 10
5920 : : end if
5921 : :
5922 [ + + + - : 72 : if (ANY(paw_ij(:)%has_dijfock==2)) then
- + ]
5923 : 0 : nopt = nopt + 1
5924 : 0 : options(nopt) = 11
5925 : : end if
5926 : :
5927 [ + + + - : 72 : if (ANY(paw_ij(:)%has_exexch_pot==2)) then
- + ]
5928 : 0 : nopt = nopt + 1
5929 : 0 : options(nopt) = 10
5930 : 0 : msg='symetrization of dij_exexch not coded!'
5931 : 0 : LIBPAW_ERROR(msg)
5932 : : end if
5933 : :
5934 : : !Set up parallelism over atoms
5935 : 10 : paral_atom=(present(comm_atom))
5936 [ - + ]: 10 : nullify(my_atmtab);if (present(mpi_atmtab)) my_atmtab => mpi_atmtab
5937 [ - + ]: 10 : my_comm_atom=xmpi_comm_self;if (present(comm_atom)) my_comm_atom=comm_atom
5938 : 10 : call get_my_atmtab(my_comm_atom,my_atmtab,my_atmtab_allocated,paral_atom,natom,my_natom_ref=my_natom)
5939 : :
5940 [ + + ]: 50 : do ii=1,nopt
5941 : 40 : option_dij = options(ii)
5942 [ - + ]: 50 : if (paral_atom) then
5943 : : call symdij(gprimd,indsym,ipert,my_natom,natom,nsym,ntypat,option_dij,&
5944 : : & paw_ij,pawang,pawprtvol,pawtab,rprimd,symafm,symrec,&
5945 : 0 : & comm_atom=my_comm_atom,mpi_atmtab=my_atmtab)
5946 : : else
5947 : : call symdij(gprimd,indsym,ipert,my_natom,natom,nsym,ntypat,option_dij,&
5948 : 40 : & paw_ij,pawang,pawprtvol,pawtab,rprimd,symafm,symrec)
5949 : : end if
5950 : : end do
5951 : :
5952 : : !Destroy atom table used for parallelism
5953 : 10 : call free_my_atmtab(my_atmtab,my_atmtab_allocated)
5954 : :
5955 : 10 : end subroutine symdij_all
5956 : : !!***
5957 : :
5958 : : !----------------------------------------------------------------------
5959 : :
5960 : : !!****f* m_pawdij/pawdij_gather
5961 : : !! NAME
5962 : : !! pawdij_gather
5963 : : !!
5964 : : !! FUNCTION
5965 : : !! Performs a ALLGATHER operation (over atomic sites) on Dij data
5966 : : !! stored as a 1D array of Dij arrays.
5967 : : !!
5968 : : !! INPUTS
5969 : : !! dij_in = coeff2d_type array containing the input Dij
5970 : : !! comm_atom= MPI communicator over atoms
5971 : : !! mpi_atmtab(:)=indexes of the atoms treated by current proc
5972 : : !!
5973 : : !! OUTPUT
5974 : : !! dij_out = coeff2d_type array containing the gathered Dij
5975 : : !!
5976 : : !! SOURCE
5977 : :
5978 [ - + - + : 26544 : subroutine pawdij_gather(dij_in,dij_out,comm_atom,mpi_atmtab)
- + + + -
+ + + +
- ]
5979 : :
5980 : : !Arguments ------------------------------------
5981 : : !scalars
5982 : : integer,intent(in) :: comm_atom
5983 : : !arrays
5984 : : integer,intent(in) :: mpi_atmtab(:)
5985 : : type(coeff2_type),intent(in) :: dij_in(:)
5986 : : type(coeff2_type),intent(out) :: dij_out(:)
5987 : :
5988 : : !Local variables-------------------------------
5989 : : !scalars
5990 : : integer :: buf_dp_size,buf_dp_size_all,buf_int_size,buf_int_size_all
5991 : : integer :: dij_size,dij_size_out,ierr,ii,i2,indx_dp,indx_int,ival,n1,n2,nproc
5992 : : !arrays
5993 : : integer :: bufsz(2)
5994 : 3264 : integer, allocatable :: buf_int(:),buf_int_all(:)
5995 : 3264 : integer, allocatable :: count_dp(:),count_int(:),count_tot(:),displ_dp(:),displ_int(:)
5996 : 3264 : integer, allocatable :: dimdij(:,:)
5997 : 3264 : real(dp),allocatable :: buf_dp(:),buf_dp_all(:)
5998 : :
5999 : : ! *************************************************************************
6000 : :
6001 : 3264 : nproc=xmpi_comm_size(comm_atom)
6002 : 3264 : dij_size=size(dij_in,dim=1)
6003 : :
6004 : 3264 : buf_dp_size=0
6005 [ + + + - : 9792 : LIBPAW_ALLOCATE(dimdij,(dij_size,2))
+ - + + -
+ - + ]
6006 [ + + ]: 6596 : do ii=1,dij_size
6007 : 3332 : dimdij(ii,1)=size(dij_in(ii)%value,dim=1)
6008 : 3332 : dimdij(ii,2)=size(dij_in(ii)%value,dim=2)
6009 : 6596 : buf_dp_size=buf_dp_size+dimdij(ii,1)*dimdij(ii,2)
6010 : : end do
6011 : :
6012 : : !If only one proc, perform a single copy
6013 [ - + ]: 3264 : if (nproc==1) then
6014 [ # # ]: 0 : do ii=1,dij_size
6015 : 0 : ival=mpi_atmtab(ii)
6016 [ # # ]: 0 : if (allocated(dij_out(ival)%value)) then
6017 : 0 : LIBPAW_DEALLOCATE(dij_out(ival)%value)
6018 : : end if
6019 [ # # # # : 0 : LIBPAW_ALLOCATE(dij_out(ival)%value,(n1,n2))
# # # # #
# # # # #
# # # # ]
6020 [ # # # # : 0 : dij_out(ii)%value=dij_in(ival)%value
# # # # #
# # # # #
# # ]
6021 : : end do
6022 [ # # ]: 0 : LIBPAW_DEALLOCATE(dimdij)
6023 : 0 : return
6024 : : end if
6025 : :
6026 : : !Fill in integer buffer
6027 : 3264 : buf_int_size=3*dij_size
6028 [ + + + - : 9792 : LIBPAW_ALLOCATE(buf_int,(buf_int_size))
+ - + + -
+ - + ]
6029 : 3264 : indx_int=1
6030 [ + + ]: 6596 : do ii=1,dij_size
6031 : 3332 : buf_int(indx_int )=dimdij(ii,1)
6032 : 3332 : buf_int(indx_int+1)=dimdij(ii,2)
6033 : 3332 : buf_int(indx_int+2)=mpi_atmtab(ii)
6034 : 6596 : indx_int=indx_int+3
6035 : : end do
6036 : :
6037 : : !Fill in real buffer
6038 [ + + + - : 9792 : LIBPAW_ALLOCATE(buf_dp,(buf_dp_size))
+ - + + -
+ - + ]
6039 : 3264 : indx_dp=1
6040 [ + + ]: 6596 : do ii=1,dij_size
6041 : 3332 : n1=dimdij(ii,1); n2=dimdij(ii,2)
6042 [ + + ]: 10534 : do i2=1,n2
6043 [ + + ]: 378126 : buf_dp(indx_dp:indx_dp+n1-1)=dij_in(ii)%value(1:n1,i2)
6044 : 7270 : indx_dp=indx_dp+n1
6045 : : end do
6046 : : end do
6047 : :
6048 : : !Communicate (1 gather for integers, 1 gather for reals)
6049 [ - + + - : 9792 : LIBPAW_ALLOCATE(count_int,(nproc))
+ - + - -
+ - + ]
6050 [ - + + - : 6528 : LIBPAW_ALLOCATE(displ_int,(nproc))
- + - + ]
6051 [ - + + - : 6528 : LIBPAW_ALLOCATE(count_dp ,(nproc))
- + - + ]
6052 [ - + + - : 6528 : LIBPAW_ALLOCATE(displ_dp ,(nproc))
- + - + ]
6053 [ + - - + : 9792 : LIBPAW_ALLOCATE(count_tot,(2*nproc))
+ - + - +
- - + -
+ ]
6054 : 3264 : bufsz(1)=buf_int_size; bufsz(2)=buf_dp_size
6055 : 3264 : call xmpi_allgather(bufsz,2,count_tot,comm_atom,ierr)
6056 [ + + ]: 13680 : do ii=1,nproc
6057 : 10416 : count_int(ii)=count_tot(2*ii-1)
6058 : 13680 : count_dp (ii)=count_tot(2*ii)
6059 : : end do
6060 : 3264 : displ_int(1)=0;displ_dp(1)=0
6061 [ + + ]: 10416 : do ii=2,nproc
6062 : 7152 : displ_int(ii)=displ_int(ii-1)+count_int(ii-1)
6063 : 10416 : displ_dp (ii)=displ_dp (ii-1)+count_dp (ii-1)
6064 : : end do
6065 [ + + ]: 13680 : buf_int_size_all=sum(count_int)
6066 [ + + ]: 13680 : buf_dp_size_all =sum(count_dp)
6067 [ - + ]: 3264 : LIBPAW_DEALLOCATE(count_tot)
6068 [ - + + - : 9792 : LIBPAW_ALLOCATE(buf_int_all,(buf_int_size_all))
+ - + - -
+ - + ]
6069 [ - + + - : 9792 : LIBPAW_ALLOCATE(buf_dp_all ,(buf_dp_size_all))
+ - + - -
+ - + ]
6070 : 3264 : call xmpi_allgatherv(buf_int,buf_int_size,buf_int_all,count_int,displ_int,comm_atom,ierr)
6071 : 3264 : call xmpi_allgatherv(buf_dp ,buf_dp_size ,buf_dp_all ,count_dp ,displ_dp ,comm_atom,ierr)
6072 [ - + ]: 3264 : LIBPAW_DEALLOCATE(count_int)
6073 : 3264 : LIBPAW_DEALLOCATE(displ_int)
6074 [ - + ]: 3264 : LIBPAW_DEALLOCATE(count_dp)
6075 : 3264 : LIBPAW_DEALLOCATE(displ_dp)
6076 : :
6077 : : !Retrieve gathered data
6078 : 3264 : dij_size_out=buf_int_size_all/3
6079 : 3264 : indx_int=1;indx_dp=1
6080 [ + + ]: 13272 : do ii=1,dij_size_out
6081 : 10008 : n1=buf_int_all(indx_int)
6082 : 10008 : n2=buf_int_all(indx_int+1)
6083 : 10008 : ival=buf_int_all(indx_int+2)
6084 : 10008 : indx_int=indx_int+3
6085 [ - + ]: 10008 : if (allocated(dij_out(ival)%value)) then
6086 : 0 : LIBPAW_DEALLOCATE(dij_out(ival)%value)
6087 : : end if
6088 [ - + + - : 40032 : LIBPAW_ALLOCATE(dij_out(ival)%value,(n1,n2))
- + + - +
- + - - +
- + - + ]
6089 [ + + ]: 25136 : do i2=1,n2
6090 [ + + ]: 1179288 : dij_out(ival)%value(1:n1,i2)=buf_dp_all(indx_dp:indx_dp+n1-1)
6091 : 21872 : indx_dp=indx_dp+n1
6092 : : end do
6093 : : end do
6094 : :
6095 [ - + ]: 3264 : LIBPAW_DEALLOCATE(buf_dp_all)
6096 [ - + ]: 3264 : LIBPAW_DEALLOCATE(buf_int_all)
6097 [ - + ]: 3264 : LIBPAW_DEALLOCATE(buf_int)
6098 [ - + ]: 3264 : LIBPAW_DEALLOCATE(buf_dp)
6099 [ - + ]: 3264 : LIBPAW_DEALLOCATE(dimdij)
6100 : :
6101 [ - + - + : 6528 : end subroutine pawdij_gather
- + - + -
+ - + - +
- + - + ]
6102 : : !!***
6103 : :
6104 : : !----------------------------------------------------------------------
6105 : :
6106 : : !!****f* m_pawdij/pawdij_print_ij
6107 : : !! NAME
6108 : : !! pawdij_print_dij
6109 : : !!
6110 : : !! FUNCTION
6111 : : !! Print out the content of a Dij matrix (total Dij) in a suitable format
6112 : : !!
6113 : : !! INPUTS
6114 : : !! dij(cplex_dij*qphase*lmn2_size,ndij)= input matrix to be printed
6115 : : !! cplex_dij=1 if Dij is real, 2 if Dij is complex
6116 : : !! qphase=1 if Dij contains no RF phase, 2 if it contains a exp(-iqr) RF phase
6117 : : !! iatom=current atom
6118 : : !! natom=total number of atoms in the system
6119 : : !! nspden=number of spin density components
6120 : : !! [Ha_or_eV]= 1: output in hartrees, 2: output in eV
6121 : : !! [opt_prtvol]= >=0 if up to 12 components of _ij matrix have to be printed
6122 : : !! <0 if all components of ij_ matrix have to be printed (optional)
6123 : : !! [mode_paral]= parallel printing mode (optional, default='COLL')
6124 : : !! [test_value]=(real number) if positive, print a warning when the magnitude of Dij is greater (optional)
6125 : : !! [title_msg]=message to print as title (optional)
6126 : : !! [unit]=the unit number for output (optional)
6127 : : !!
6128 : : !! OUTPUT
6129 : : !! (Only writing)
6130 : : !!
6131 : : !! SOURCE
6132 : :
6133 [ - + ]: 8530 : subroutine pawdij_print_dij(dij,cplex_dij,qphase,iatom,natom,nspden,&
6134 : : & test_value,title_msg,unit,Ha_or_eV,opt_prtvol,mode_paral) ! Optional arguments
6135 : :
6136 : : !Arguments ------------------------------------
6137 : : !scalars
6138 : : integer,intent(in) :: cplex_dij,iatom,natom,nspden,qphase
6139 : : integer,optional,intent(in) :: Ha_or_eV,opt_prtvol,unit
6140 : : real(dp),intent(in),optional :: test_value
6141 : : character(len=4),optional,intent(in) :: mode_paral
6142 : : character(len=100),optional,intent(in) :: title_msg
6143 : : !arrays
6144 : : real(dp),intent(in),target :: dij(:,:)
6145 : :
6146 : : !Local variables-------------------------------
6147 : : character(len=7),parameter :: dspin(6)=(/"up ","down ","up-up ","dwn-dwn","up-dwn ","dwn-up "/)
6148 : : integer :: idij,idij_sym,kk,lmn_size,lmn2_size,my_idij,my_idij_sym
6149 : : integer :: my_prtvol,my_unt,my_Ha_or_eV,ndij,tmp_cplex_dij
6150 : : real(dp) :: my_test_value,test_value_eff
6151 : : character(len=4) :: my_mode
6152 : : character(len=2000) :: msg
6153 : : !arrays
6154 : : integer :: idum(0)
6155 : 8530 : real(dp),allocatable,target :: dij1(:),dij2(:)
6156 : 8530 : real(dp),pointer :: dij2p(:),dij2p_(:)
6157 : :
6158 : : ! *************************************************************************
6159 : :
6160 : : !Optional arguments
6161 : 4416 : my_unt =std_out ; if (PRESENT(unit )) my_unt =unit
6162 [ + + ]: 8530 : my_mode ='COLL' ; if (PRESENT(mode_paral)) my_mode =mode_paral
6163 [ + - ]: 8530 : my_prtvol=1 ; if (PRESENT(opt_prtvol)) my_prtvol=opt_prtvol
6164 [ + + ]: 8530 : my_test_value=-one; if (PRESENT(test_value)) my_test_value=test_value
6165 [ + + ]: 8530 : my_Ha_or_eV=1 ; if (PRESENT(Ha_or_eV)) my_Ha_or_eV=Ha_or_eV
6166 : :
6167 : : !Title
6168 [ - + ]: 8530 : if (present(title_msg)) then
6169 [ # # ]: 0 : if (trim(title_msg)/='') then
6170 : 0 : write(msg, '(2a)') ch10,trim(title_msg)
6171 : 0 : call wrtout(my_unt,msg,my_mode)
6172 : : end if
6173 : : end if
6174 : :
6175 : : !Inits
6176 : 8530 : ndij=size(dij,2)
6177 : 8530 : lmn2_size=size(dij,1)/(cplex_dij*qphase)
6178 : 8530 : lmn_size=int(dsqrt(two*dble(lmn2_size)))
6179 [ - + ]: 8530 : if (qphase==2) then
6180 [ # # # # : 0 : LIBPAW_ALLOCATE(dij1,(2*lmn2_size))
# # # # #
# # # #
# ]
6181 [ # # # # : 0 : LIBPAW_ALLOCATE(dij2,(2*lmn2_size))
# # # # ]
6182 : : end if
6183 : :
6184 : : ! === Loop over Dij components ===
6185 [ + + ]: 24718 : do idij=1,ndij
6186 : :
6187 [ + + ]: 16188 : idij_sym=idij;if (ndij==4.and.idij>2) idij_sym=7-idij
6188 : :
6189 : : !Subtitle
6190 [ + + + + : 16188 : if (natom>1.or.nspden>1.or.ndij==4) then
+ + ]
6191 [ + + + + ]: 15404 : if (nspden==1.and.ndij/=4) write(msg,'(a,i3)') ' Atom #',iatom
6192 [ + + ]: 15404 : if (nspden==2) write(msg,'(a,i3,a,i1)')' Atom #',iatom,' - Spin component ',idij
6193 [ + + + - ]: 15404 : if (ndij==4) write(msg,'(a,i3,2a)') ' Atom #',iatom,' - Component ',trim(dspin(idij+2*(ndij/4)))
6194 : 15404 : call wrtout(my_unt,msg,my_mode)
6195 : : end if
6196 : :
6197 : : !Select upper and lower triangular parts
6198 : 16188 : my_idij=min(size(dij,2),idij)
6199 : 16188 : my_idij_sym=min(size(dij,2),idij_sym)
6200 [ + - ]: 16188 : if (qphase==1) then
6201 : 16188 : tmp_cplex_dij=cplex_dij
6202 : 16188 : dij2p => dij(1:cplex_dij*lmn2_size:1,my_idij)
6203 : 16188 : dij2p_ => dij(1:cplex_dij*lmn2_size:1,my_idij_sym)
6204 : : else
6205 : 0 : tmp_cplex_dij=2
6206 [ # # ]: 0 : if (cplex_dij==1) then
6207 [ # # ]: 0 : do kk=1,lmn2_size
6208 : 0 : dij1(2*kk-1)= dij(kk,my_idij)
6209 : 0 : dij1(2*kk )= dij(kk+lmn2_size,my_idij)
6210 : 0 : dij2(2*kk-1)= dij(kk,my_idij_sym)
6211 : 0 : dij2(2*kk )=-dij(kk+lmn2_size,my_idij_sym)
6212 : : end do
6213 : : else
6214 [ # # ]: 0 : do kk=1,lmn2_size
6215 : 0 : dij1(2*kk-1)= dij(2*kk-1,my_idij)-dij(2*kk +2*lmn2_size,my_idij)
6216 : 0 : dij1(2*kk )= dij(2*kk ,my_idij)+dij(2*kk-1+2*lmn2_size,my_idij)
6217 : 0 : dij2(2*kk-1)= dij(2*kk-1,my_idij_sym)+dij(2*kk +2*lmn2_size,my_idij_sym)
6218 : 0 : dij2(2*kk )= dij(2*kk ,my_idij_sym)-dij(2*kk-1+2*lmn2_size,my_idij_sym)
6219 : : end do
6220 : : end if
6221 : 0 : dij2p => dij1 ; dij2p_ => dij2
6222 : : end if
6223 : :
6224 : : !Printing
6225 [ + + + + ]: 16188 : test_value_eff=-one;if(my_test_value>zero.and.idij==1) test_value_eff=my_test_value
6226 : : call pawio_print_ij(my_unt,dij2p,lmn2_size,tmp_cplex_dij,lmn_size,-1,idum,0,&
6227 : : & my_prtvol,idum,test_value_eff,my_Ha_or_eV,&
6228 [ - + - + ]: 24718 : & opt_sym=2,asym_ij=dij2p_,mode_paral=my_mode,force_print=.true.)
6229 : :
6230 : : end do !idij
6231 : :
6232 [ - + ]: 8530 : if (qphase==2) then
6233 [ # # ]: 0 : LIBPAW_DEALLOCATE(dij1)
6234 [ # # ]: 0 : LIBPAW_DEALLOCATE(dij2)
6235 : : end if
6236 : :
6237 [ + + - + : 17060 : end subroutine pawdij_print_dij
- + ]
6238 : : !!***
6239 : :
6240 : : !----------------------------------------------------------------------
6241 : :
6242 : : !!****f* m_pawdij/pawv1
6243 : : !! NAME
6244 : : !! pawv1
6245 : : !!
6246 : : !! FUNCTION
6247 : : !! On-site all-electron potential V1
6248 : : !!
6249 : : !! INPUTS
6250 : : !! mesh_size=radial mesh size
6251 : : !! nspden=number of spin density components
6252 : : !! pawang <type(pawang_type)>=paw angular mesh and related data
6253 : : !! pawrad <type(pawrad_type)>=paw radial mesh and related data, for current atom
6254 : : !! pawxcdev=Choice of XC development (0=no dev. (use of angular mesh) ; 1 or 2=dev. on moments)
6255 : : !! vh1(qphase*mesh_size,v_size,nspden)=all-electron on-site Hartree potential for current atom
6256 : : !! only spherical moment is used
6257 : : !! vxc1(qphase*mesh_size,v_size,nspden)=all-electron on-site XC potential for current atom
6258 : : !! given on a (r,theta,phi) grid (v_size=angl_size)
6259 : : !! or on (l,m) spherical moments (v_size=lm_size)
6260 : : !!
6261 : : !! OUTPUT
6262 : : !! v1(mesh_size)=V1 on-site potential
6263 : : !!
6264 : : !! SOURCE
6265 : :
6266 [ - + - + ]: 2338 : subroutine pawv1(mesh_size,nspden,pawang,pawxcdev,v1,vh1,vxc1)
6267 : :
6268 : : !Arguments ---------------------------------------------
6269 : : !scalars
6270 : : integer,intent(in) :: mesh_size,nspden,pawxcdev
6271 : : type(pawang_type),intent(in) :: pawang
6272 : : !arrays
6273 : : real(dp),intent(in) :: vh1(:,:,:),vxc1(:,:,:)
6274 : : real(dp),intent(out) :: v1(mesh_size)
6275 : : !Local variables ---------------------------------------
6276 : : !scalars
6277 : : integer :: angl_size,ipts
6278 : : real(dp) :: fact
6279 : : !arrays
6280 : :
6281 : : ! *************************************************************************
6282 : :
6283 : 2338 : angl_size=pawang%angl_size
6284 : :
6285 : 2338 : fact=one/sqrt(four_pi) ! Y_00
6286 [ + + ]: 2338 : if (pawxcdev/=0) then
6287 [ + + ]: 2213 : if (nspden==1) then
6288 [ + + ]: 1857804 : v1(1:mesh_size)=vxc1(1:mesh_size,1,1)
6289 : : else
6290 [ + + ]: 730241 : v1(1:mesh_size)=half*(vxc1(1:mesh_size,1,1)+vxc1(1:mesh_size,1,2))
6291 : : end if
6292 : : else
6293 [ + + ]: 141477 : v1(1:mesh_size)=zero
6294 [ + + ]: 125 : if (nspden==1) then
6295 [ + + ]: 4082 : do ipts=1,angl_size
6296 : : v1(1:mesh_size)=v1(1:mesh_size) &
6297 [ + + ]: 5639894 : & +vxc1(1:mesh_size,ipts,1)*pawang%angwgth(ipts)
6298 : : end do
6299 : : else
6300 [ + + ]: 15543 : do ipts=1,angl_size
6301 : : v1(1:mesh_size)=v1(1:mesh_size) &
6302 : : & +half*(vxc1(1:mesh_size,ipts,1)+vxc1(1:mesh_size,ipts,2)) &
6303 [ + + ]: 16430643 : & *pawang%angwgth(ipts)
6304 : : end do
6305 : : end if
6306 [ + + ]: 141477 : v1(1:mesh_size)=sqrt(four_pi)*v1(1:mesh_size)
6307 : : end if
6308 [ + + ]: 2729522 : v1(1:mesh_size)=fact*(v1(1:mesh_size)+vh1(1:mesh_size,1,1))
6309 : :
6310 : 2338 : end subroutine pawv1
6311 : :
6312 : : !!***
6313 : :
6314 : :
6315 : : END MODULE m_pawdij
6316 : : !!***
|
