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 20544 : subroutine pawdij(cplex,enunit,gprimd,ipert,my_natom,natom,nfft,nfftot,nspden,ntypat,&
168 61632 : & paw_an,paw_ij,pawang,pawfgrtab,pawprtvol,pawrad,pawrhoij,pawspnorb,pawtab,&
169 20544 : & pawxcdev,qphon,spnorbscl,ucvol,charge,vtrial,vxc,xred,znuc,&
170 20544 : & electronpositron_calctype,electronpositron_pawrhoij,electronpositron_lmselect,&
171 20544 : & atvshift,fatvshift,natvshift,nucdipmom,eijkl_is_sym,&
172 20544 : & 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 20544 : integer,pointer :: my_atmtab(:)
228 20544 : logical,allocatable :: lmselect(:)
229 : real(dp) :: spinaxis_in(3)
230 20544 : real(dp),allocatable :: dij0(:),dijhartree(:)
231 20544 : real(dp),allocatable :: dijhat(:,:),dijexxc(:,:),dijfock_cv(:,:),dijfock_vv(:,:),dijpawu(:,:)
232 20544 : real(dp),allocatable :: dijnd(:,:),dijso(:,:)
233 20544 : real(dp),allocatable :: dijxc(:,:),dij_ep(:),dijxchat(:,:),dijxcval(:,:)
234 20544 : real(dp),pointer :: v_dijhat(:,:),vpawu(:,:,:,:),vpawx(:,:,:)
235 :
236 : ! *************************************************************************
237 :
238 : !------------------------------------------------------------------------
239 : !----- Check consistency of arguments
240 : !------------------------------------------------------------------------
241 :
242 : ! === Check optional arguments ===
243 :
244 15129 : hyb_mixing_ =zero ; if(present(hyb_mixing)) hyb_mixing_ =hyb_mixing
245 20544 : hyb_mixing_sr_=zero ; if(present(hyb_mixing_sr)) hyb_mixing_sr_=hyb_mixing_sr
246 :
247 20544 : natvshift_=0;if (present(natvshift)) natvshift_=natvshift
248 20544 : 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 20544 : ipositron=0;if (present(electronpositron_calctype)) ipositron=electronpositron_calctype
256 15129 : 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 20544 : has_nucdipmom=present(nucdipmom)
265 :
266 : ! === Check complex character of arguments ===
267 :
268 20544 : 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 20544 : if (my_natom>0) then
273 18780 : 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 18780 : 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 18780 : 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 18780 : 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 18780 : 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 20544 : if (ipert==natom+1.or.ipert==natom+10) then
301 2373 : do iatom=1,my_natom
302 255181 : if (paw_ij(iatom)%has_dij==1) paw_ij(iatom)%dij=zero
303 1554 : if (paw_ij(iatom)%has_dij0==1) paw_ij(iatom)%dij0=zero
304 1554 : if (paw_ij(iatom)%has_dijfock==1) paw_ij(iatom)%dijfock=zero
305 86045 : if (paw_ij(iatom)%has_dijhartree==1) paw_ij(iatom)%dijhartree=zero
306 1554 : if (paw_ij(iatom)%has_dijxc==1) paw_ij(iatom)%dijxc=zero
307 1554 : if (paw_ij(iatom)%has_dijhat==1) paw_ij(iatom)%dijhat=zero
308 1554 : if (paw_ij(iatom)%has_dijso==1) paw_ij(iatom)%dijso=zero
309 1554 : if (paw_ij(iatom)%has_dijU==1) paw_ij(iatom)%dijU=zero
310 1554 : if (paw_ij(iatom)%has_dijexxc==1) paw_ij(iatom)%dijexxc=zero
311 1554 : if (paw_ij(iatom)%has_dijxc_hat==1) paw_ij(iatom)%dijxc_hat=zero
312 2373 : 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 19725 : paral_atom=(present(comm_atom).and.(my_natom/=natom))
319 19725 : nullify(my_atmtab);if (present(mpi_atmtab)) my_atmtab => mpi_atmtab
320 19725 : my_comm_atom=xmpi_comm_self;if (present(comm_atom)) my_comm_atom=comm_atom
321 19725 : 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 19725 : nsppol=1;nsploop=1
325 19725 : if (my_natom>0) then
326 17961 : nsppol=paw_ij(1)%nsppol
327 17961 : nsploop=nsppol;if (paw_ij(1)%ndij==4) nsploop=4
328 : end if
329 49821 : usexcnhat=maxval(pawtab(1:ntypat)%usexcnhat)
330 19725 : 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 19725 : v_dijhat_allocated=.false.
334 19725 : if (my_natom>0) then
335 17961 : 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 17961 : if (usexcnhat==0) then
338 10474 : 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 41896 : LIBPAW_POINTER_ALLOCATE(v_dijhat,(cplex*nfft,nspden))
343 10474 : v_dijhat_allocated=.true.
344 : !v_dijhat=vtrial-vxc
345 23600 : do idij=1,nspden
346 403478751 : do klmn=1,cplex*nfft
347 403468277 : 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 63230 : do iatom=1,my_natom
361 43505 : iatom_tot=iatom;if (paral_atom) iatom_tot=my_atmtab(iatom)
362 :
363 : ! === Atom-dependent data ===
364 :
365 43505 : itypat=paw_ij(iatom)%itypat
366 43505 : cplex_dij=paw_ij(iatom)%cplex_dij
367 43505 : qphase=paw_ij(iatom)%qphase
368 43505 : lm_size=paw_an(iatom)%lm_size
369 43505 : lmn2_size=paw_ij(iatom)%lmn2_size
370 43505 : ndij=paw_ij(iatom)%ndij
371 43505 : usepawu=pawtab(itypat)%usepawu
372 43505 : pawu_algo=merge(PAWU_ALGO_1,PAWU_ALGO_2,ipert<=0.and.usepawu>=0)
373 43505 : pawu_dblec=merge(PAWU_FLL,PAWU_AMF,abs(usepawu)==1.or.abs(usepawu)==4)
374 43505 : usekden=merge(0,1,paw_an(iatom)%has_vxctau/=2)
375 : need_to_print=((abs(pawprtvol)>=1).and. &
376 43505 : & (iatom_tot==1.or.iatom_tot==natom.or.pawprtvol<0))
377 :
378 : ! === Determine which conditions and prerequisites are fulfilled for Dij ===
379 :
380 43505 : if (my_natom>0) then
381 : ! Total Dij: no condition ; no prerequisites
382 43505 : dij_available=.true.;dij_prereq=.true.
383 : ! Dij0: not available for RF ; need kij for the positron
384 43505 : 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 43505 : dijfock_available=(paw_ij(iatom)%has_dijfock>0.and.ipert<=0.and.ipositron/=1)
387 43505 : dijfock_prereq=(paw_ij(iatom)%has_dijfock==2)
388 : ! DijHartree: no condition ; no prerequisites
389 43505 : dijhartree_available=.true.;dijhartree_prereq=.true.
390 : ! DijXC: no condition ; Vxc needed
391 43505 : dijxc_available=.true.
392 43505 : dijxc_prereq=(paw_ij(iatom)%has_dijxc==2.or.paw_an(iatom)%has_vxc>0)
393 : ! Dij^hat: no condition ; no prerequisites
394 43505 : dijhat_available=.true.;dijhat_prereq=.true.
395 : ! Dij^hat_FR: only for RF and when it was previously computed
396 43505 : dijhatfr_available=(ipert>0.and.paw_ij(iatom)%has_dijfr==2) ; dijhatfr_prereq=.true.
397 : ! DijND: requires non-zero nucdipmom
398 43505 : dijnd_available=.false. ; dijnd_prereq=(cplex_dij==2)
399 155008 : 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 43505 : dijso_available=(pawspnorb>0.and.ipert<=0.and.ipositron/=1)
402 : dijso_prereq=(paw_ij(iatom)%has_dijso==2.or.&
403 43505 : & (paw_an(iatom)%has_vhartree>0.and.paw_an(iatom)%has_vxc>0))
404 : ! DijU: not available for positron; only for DFT+U
405 43505 : 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 43505 : & (paw_ij(iatom)%has_dijU>0))
408 : ! DijExxc: not available for RF, positron; only for local exact exch. ; Vxc_ex needed
409 43505 : dijexxc_available=(pawtab(itypat)%useexexch/=0.and.ipert<=0.and.ipositron/=1)
410 43505 : 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 43505 : dijxchat_available=(ipert<=0)
413 43505 : 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 43505 : dijxcval_available=(ipert<=0)
416 43505 : 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 43505 : dij_need=.false.;dij0_need=.false.;dijexxc_need=.false.;dijfock_need=.false.
422 43505 : dijhartree_need=.false.;dijhat_need=.false.;dijhatfr_need=.false.;
423 43505 : dijso_need=.false.;dijU_need=.false.;dijxc_need=.false.
424 43505 : dijxchat_need=.false.;dijxcval_need=.false.; dijnd_need=.false.
425 :
426 : if (dij_available) then
427 43505 : if (paw_ij(iatom)%has_dij==1) then
428 5505832 : 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 43505 : if (dij0_available) then
439 37562 : if (paw_ij(iatom)%has_dij0==1) then
440 0 : dij0_need=.true.;paw_ij(iatom)%dij0(:)=zero
441 37562 : 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 43505 : 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 43007 : 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 43505 : if (paw_ij(iatom)%has_dijhartree==1) then
464 0 : dijhartree_need=.true.;paw_ij(iatom)%dijhartree(:)=zero
465 43505 : 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 43505 : if (paw_ij(iatom)%has_dijxc==1) then
476 1673 : dijxc_need=.true.;paw_ij(iatom)%dijxc(:,:)=zero
477 43474 : 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 43505 : if (paw_ij(iatom)%has_dijhat==1) then
488 1878 : dijhat_need=.true.;paw_ij(iatom)%dijhat(:,:)=zero
489 43470 : 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 43505 : if (dijnd_available) then
499 535 : if (paw_ij(iatom)%has_dijnd==1) then
500 0 : dijnd_need=.true.;paw_ij(iatom)%dijnd(:,:)=zero
501 535 : 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 43505 : 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 41285 : else if (paw_ij(iatom)%has_dijso==1) then
519 0 : paw_ij(iatom)%dijso=zero
520 : end if
521 :
522 43505 : 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 40671 : else if (paw_ij(iatom)%has_dijU==1) then
531 3034254 : paw_ij(iatom)%dijU=zero
532 : end if
533 :
534 43505 : 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 43463 : else if (paw_ij(iatom)%has_dijexxc==1) then
543 0 : paw_ij(iatom)%dijexxc=zero
544 : end if
545 :
546 43505 : if (dijxchat_available) then
547 37562 : 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 43505 : if (dijxcval_available) then
559 37562 : 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 43505 : if (dij0_need.and.(.not.dij0_prereq)) then
577 0 : msg='Dij0 prerequisites missing!'
578 0 : LIBPAW_BUG(msg)
579 : end if
580 43505 : 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 43505 : 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 43505 : if (dijnd_need.and.(.not.dijnd_prereq)) then
602 0 : msg='DijND prerequisites missing!'
603 0 : LIBPAW_BUG(msg)
604 : end if
605 43505 : if (dijso_need.and.(.not.dijso_prereq)) then
606 0 : msg='DijSO prerequisites missing!'
607 0 : LIBPAW_BUG(msg)
608 : end if
609 43505 : if (dijU_need.and.(.not.dijU_prereq)) then
610 0 : msg='DijU prerequisites missing!'
611 0 : LIBPAW_BUG(msg)
612 : end if
613 43505 : if (dijexxc_need.and.(.not.dijexxc_prereq)) then
614 0 : msg='DijExcc prerequisites missing!'
615 0 : LIBPAW_BUG(msg)
616 : end if
617 43505 : if (dijxchat_need.and.(.not.dijxchat_prereq)) then
618 0 : msg='DijXC^hat prerequisites missing!'
619 0 : LIBPAW_BUG(msg)
620 : end if
621 43505 : 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 43505 : if ((dij0_need.or.dij_need).and.dij0_available) then
631 :
632 112686 : LIBPAW_ALLOCATE(dij0,(lmn2_size))
633 : ! ===== Dij0 already computed
634 37562 : if (paw_ij(iatom)%has_dij0==2) then
635 0 : dij0(:)=paw_ij(iatom)%dij0(:)
636 : else
637 : ! ===== Need to compute Dij0
638 2146965 : dij0(:)=pawtab(itypat)%dij0(:)
639 124982 : if (ipositron==1) dij0(:)=two*pawtab(itypat)%kij(:)-dij0(:)
640 69114 : if (pawu_algo==PAWU_ALGO_2.and.pawu_dblec==PAWU_FLL) dij0(:)=dij0(:)+pawtab(itypat)%euij_fll(:)
641 430549 : if (dij0_need) paw_ij(iatom)%dij0(:)=dij0(:)
642 : end if
643 :
644 37562 : if (dij_need) then
645 82128 : do idij=1,min(nsploop,2)
646 : klmn1=1
647 3058886 : do klmn=1,lmn2_size
648 2976758 : paw_ij(iatom)%dij(klmn1,idij)=paw_ij(iatom)%dij(klmn1,idij)+dij0(klmn)
649 3021324 : klmn1=klmn1+cplex_dij
650 : end do
651 : end do
652 : end if
653 37562 : LIBPAW_DEALLOCATE(dij0)
654 : end if
655 :
656 : ! ------------------------------------------------------------------------
657 : ! ------------------------------------------------------------------------
658 : ! ----------- Add Dij_{Fock exact-exchange} to Dij
659 : ! ------------------------------------------------------------------------
660 :
661 43505 : 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 43505 : if ((dijhartree_need.or.dij_need).and.dijhartree_available) then
693 :
694 130515 : LIBPAW_ALLOCATE(dijhartree,(qphase*lmn2_size))
695 : ! ===== DijHartree already computed
696 43505 : if (paw_ij(iatom)%has_dijhartree==2) then
697 2397008 : 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 43505 : if (dij_need) then
717 95314 : do idij=1,min(nsploop,2)
718 : klmn1=1
719 3366644 : do klmn=1,qphase*lmn2_size
720 3271330 : paw_ij(iatom)%dij(klmn1,idij)=paw_ij(iatom)%dij(klmn1,idij)+dijhartree(klmn)
721 3323139 : klmn1=klmn1+cplex_dij
722 : end do
723 : end do
724 : end if
725 :
726 43505 : LIBPAW_DEALLOCATE(dijhartree)
727 : end if
728 :
729 : ! ------------------------------------------------------------------------
730 : ! ----------- Add Dij_xc to Dij
731 : ! ------------------------------------------------------------------------
732 :
733 43505 : if ((dijxc_need.or.dij_need).and.dijxc_available) then
734 :
735 : ! ===== Dijxc already computed
736 43505 : 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 174020 : LIBPAW_ALLOCATE(dijxc,(cplex_dij*qphase*lmn2_size,ndij))
742 43505 : if (pawxcdev/=0) then
743 122403 : LIBPAW_ALLOCATE(lmselect,(lm_size))
744 458299 : lmselect(:)=paw_an(iatom)%lmselect(:)
745 93685 : 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 40801 : & paw_an(iatom)%vxct1,usexcnhat)
749 40801 : 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 1505419 : if (dijxc_need) paw_ij(iatom)%dijxc(:,:)=dijxc(:,:)
757 5505832 : if (dij_need) paw_ij(iatom)%dij(:,:)=paw_ij(iatom)%dij(:,:)+dijxc(:,:)
758 43505 : LIBPAW_DEALLOCATE(dijxc)
759 : end if
760 :
761 : end if
762 :
763 : ! ------------------------------------------------------------------------
764 : ! ----------- Add Dij_hat to Dij
765 : ! ------------------------------------------------------------------------
766 :
767 43505 : if ((dijhat_need.or.dij_need).and.dijhat_available) then
768 :
769 : ! ===== Dijhat already computed
770 43505 : 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 174020 : 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 43505 : & pawtab(itypat),v_dijhat,qphon,ucvol,xred,mpi_comm_grid=my_comm_grid)
779 1505620 : if (dijhat_need) paw_ij(iatom)%dijhat(:,:)=dijhat(:,:)
780 5505832 : if (dij_need) paw_ij(iatom)%dij(:,:)=paw_ij(iatom)%dij(:,:)+dijhat(:,:)
781 43505 : LIBPAW_DEALLOCATE(dijhat)
782 : end if
783 :
784 : ! ===== RF: add frozen part of 1st-order Dij
785 43505 : 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 43505 : if ((dijnd_need.or.dij_need).and.dijnd_available) then
801 :
802 : ! ===== Dijnd already computed
803 535 : if (paw_ij(iatom)%has_dijnd==2) then
804 535 : 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 106093 : & 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 43505 : 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 43505 : 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 43505 : 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 43505 : 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 43505 : 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 43505 : 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 43505 : if (dij_need.and.paw_ij(iatom)%has_dij>=1) paw_ij(iatom)%has_dij=2
998 43505 : if (dij0_need.and.paw_ij(iatom)%has_dij0>=1) paw_ij(iatom)%has_dij0=2
999 43505 : if (dijfock_need.and.paw_ij(iatom)%has_dijfock>=1) paw_ij(iatom)%has_dijfock=2
1000 :
1001 43505 : if (dijhartree_need.and.paw_ij(iatom)%has_dijhartree>=1) paw_ij(iatom)%has_dijhartree=2
1002 43505 : if (dijxc_need.and.paw_ij(iatom)%has_dijxc>=1) paw_ij(iatom)%has_dijxc=2
1003 43505 : if (dijhat_need.and.paw_ij(iatom)%has_dijhat>=1) paw_ij(iatom)%has_dijhat=2
1004 43505 : if (dijnd_need.and.paw_ij(iatom)%has_dijnd>=1) paw_ij(iatom)%has_dijnd=2
1005 43505 : if (dijso_need.and.paw_ij(iatom)%has_dijso>=1) paw_ij(iatom)%has_dijso=2
1006 43505 : if (dijU_need.and.paw_ij(iatom)%has_dijU>=1) paw_ij(iatom)%has_dijU=2
1007 43505 : if (dijexxc_need.and.paw_ij(iatom)%has_dijexxc>=1) paw_ij(iatom)%has_dijexxc=2
1008 43505 : if (dijxchat_need.and.paw_ij(iatom)%has_dijxc_hat>=1) paw_ij(iatom)%has_dijxc_hat=2
1009 63230 : 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 19725 : 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 13393 : & mode_paral='COLL',enunit=enunit,ipert=ipert)
1024 : end if
1025 :
1026 : !Free temporary storage
1027 19725 : if (v_dijhat_allocated) then
1028 10474 : LIBPAW_POINTER_DEALLOCATE(v_dijhat)
1029 : end if
1030 63230 : do iatom=1,my_natom
1031 43505 : 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 43505 : 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 43505 : 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 43505 : 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 43505 : 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 43505 : 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 43505 : 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 43505 : 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 43505 : 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 43505 : 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 63230 : 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 19725 : call free_my_atmtab(my_atmtab,my_atmtab_allocated)
1080 :
1081 41088 : 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 54109 : 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 54109 : 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 54109 : 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 2922478 : dijhartree=zero
1144 54109 : lmn2_size=pawrhoij%lmn2_size
1145 54109 : cplex_rhoij=pawrhoij%cplex_rhoij
1146 54109 : eijkl_is_sym=.true.
1147 54109 : if(present(is_sym)) eijkl_is_sym=is_sym
1148 :
1149 : !Loop over (diagonal) spin-components
1150 54109 : nspdiag=1;if (nspden==2) nspdiag=2
1151 115590 : do ispden=1,nspdiag
1152 :
1153 : !Loop over phase exp(iqr) phase real/imaginary part
1154 178279 : 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 62689 : iq0_dij=merge(0,lmn2_size,iq==1)
1158 62689 : iq0_rhoij=cplex_rhoij*iq0_dij
1159 :
1160 : !Loop over rhoij elements
1161 62689 : jrhoij=iq0_rhoij+1
1162 2141227 : do irhoij=1,pawrhoij%nrhoijsel
1163 2017057 : klmn=pawrhoij%rhoijselect(irhoij)
1164 :
1165 2017057 : 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 2017057 : dijhartree(iq0_dij+klmn)=dijhartree(iq0_dij+klmn)+ro*pawtab%eijkl(klmn,klmn)
1170 :
1171 : !k<=l
1172 113379502 : do klmn1=1,klmn-1
1173 113379502 : dijhartree(iq0_dij+klmn1)=dijhartree(iq0_dij+klmn1)+ro*pawtab%eijkl(klmn1,klmn)
1174 : end do
1175 :
1176 : !k>l
1177 122946739 : do klmn1=klmn+1,lmn2_size
1178 122946739 : if(eijkl_is_sym) then
1179 115446570 : 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 2079746 : 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 54109 : 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 40832 : subroutine pawdijxcm(dijxc,cplex_dij,qphase,lmselect,ndij,nspden,nsppol,&
1874 40832 : & 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 40832 : real(dp),allocatable :: dijxc_idij(:),ff(:),gg(:),vxcij1(:)
1895 :
1896 : ! *************************************************************************
1897 :
1898 : !Useful data
1899 40832 : lm_size=pawtab%lcut_size**2
1900 40832 : lmn2_size=pawtab%lmn2_size
1901 40832 : ij_size=pawtab%ij_size
1902 40832 : mesh_size=pawtab%mesh_size
1903 :
1904 : !Check data consistency
1905 40832 : 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 40832 : 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 40832 : & 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 4959658 : dijxc=zero
1922 122496 : LIBPAW_ALLOCATE(dijxc_idij,(qphase*lmn2_size))
1923 122496 : LIBPAW_ALLOCATE(vxcij1,(qphase*ij_size))
1924 122496 : LIBPAW_ALLOCATE(ff,(mesh_size))
1925 81664 : LIBPAW_ALLOCATE(gg,(mesh_size))
1926 :
1927 : !----------------------------------------------------------
1928 : !Loop over spin components
1929 : !----------------------------------------------------------
1930 40832 : nsploop=nsppol;if (ndij==4) nsploop=4
1931 93509 : do idij=1,nsploop
1932 93509 : if (idij<=nsppol.or.(nspden==4.and.idij<=3)) then
1933 :
1934 47320 : idijend=idij+idij/3
1935 95965 : do ispden=idij,idijend
1936 :
1937 3360848 : dijxc_idij=zero
1938 :
1939 : ! ----------------------------------------------------------
1940 : ! Summing over (l,m) moments
1941 : ! ----------------------------------------------------------
1942 647372 : do klm=1,lm_size
1943 647372 : if (lmselect(klm)) then
1944 :
1945 : ! ===== Vxc_ij_1 (tmp) =====
1946 7429407 : vxcij1=zero
1947 438342 : if (qphase==1) then
1948 7373043 : do kln=1,ij_size
1949 : ff(1:mesh_size)= &
1950 : & vxc1(1:mesh_size,klm,ispden)*pawtab%phiphj(1:mesh_size,kln) &
1951 6351884906 : & -vxct1(1:mesh_size,klm,ispden)*pawtab%tphitphj(1:mesh_size,kln)
1952 7373043 : 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 438342 : vxcij2=zero;vxcij2_i=zero
1972 438342 : 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 438342 : if (qphase==1) then
1994 49757685 : do klmn=1,lmn2_size
1995 49322027 : klm1=pawtab%indklmn(1,klmn)
1996 49322027 : kln=pawtab%indklmn(2,klmn)
1997 49322027 : isel=pawang%gntselect(klm,klm1)
1998 49322027 : if (isel>0) &
1999 4588438 : & dijxc_idij(klmn)=dijxc_idij(klmn)+vxcij1(kln)*pawang%realgnt(isel)
2000 49322027 : if (usexcnhat/=0) &
2001 30339041 : 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 48645 : klmn1=max(1,ispden-2);klmn2=1
2037 3348896 : do klmn=1,lmn2_size
2038 3300251 : dijxc(klmn1,idij)=dijxc_idij(klmn2)
2039 3300251 : klmn1=klmn1+cplex_dij
2040 3348896 : klmn2=klmn2+qphase
2041 : end do
2042 95965 : 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 40832 : LIBPAW_DEALLOCATE(dijxc_idij)
2079 40832 : LIBPAW_DEALLOCATE(vxcij1)
2080 40832 : LIBPAW_DEALLOCATE(ff)
2081 40832 : LIBPAW_DEALLOCATE(gg)
2082 :
2083 40832 : 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 43536 : subroutine pawdijhat(dijhat,cplex_dij,qphase,gprimd,iatom,&
2130 : & natom,ndij,ngrid,ngridtot,nspden,nsppol,pawang,pawfgrtab,&
2131 43536 : & 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 43536 : real(dp),allocatable :: dijhat_idij(:),prod(:)
2157 :
2158 : ! *************************************************************************
2159 :
2160 : !Useful data
2161 43536 : lm_size=pawtab%lcut_size**2
2162 43536 : lmn2_size=pawtab%lmn2_size
2163 43536 : nfgd=pawfgrtab%nfgd
2164 43536 : qne0=(qphon(1)**2+qphon(2)**2+qphon(3)**2>=1.d-15)
2165 43536 : has_qphase=(qne0.and.qphase==2)
2166 43536 : my_comm_grid=xmpi_comm_self;if (present(mpi_comm_grid)) my_comm_grid=mpi_comm_grid
2167 :
2168 : !Check data consistency
2169 43536 : 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 43536 : 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 43536 : 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 5507505 : dijhat=zero
2200 130608 : LIBPAW_ALLOCATE(prod,(qphase*lm_size))
2201 130608 : LIBPAW_ALLOCATE(dijhat_idij,(qphase*lmn2_size))
2202 :
2203 : !----------------------------------------------------------
2204 : !Loop over spin components
2205 : !----------------------------------------------------------
2206 43536 : nsploop=nsppol;if (ndij==4) nsploop=4
2207 101140 : do idij=1,nsploop
2208 101140 : if (idij<=nsppol.or.(nspden==4.and.idij<=3)) then
2209 :
2210 51806 : idijend=idij+idij/3
2211 105036 : 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 716070 : prod=zero
2221 :
2222 : ! ===== Standard case ============================
2223 53230 : if (.not.has_qphase) then
2224 52654 : if (qphase==1) then
2225 704358 : do ilslm=1,lm_size
2226 2102767013 : do ic=1,nfgd
2227 2102062655 : vr=Pot(pawfgrtab%ifftsph(ic),ispden)
2228 2102714359 : 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 716070 : prod=prod*ucvol/dble(ngridtot)
2272 :
2273 : ! Reduction in case of parallelism
2274 53230 : if (xmpi_comm_size(my_comm_grid)>1) then
2275 1488 : 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 3724353 : dijhat_idij=zero
2285 :
2286 53230 : if (qphase==1) then
2287 3675825 : do klmn=1,lmn2_size
2288 3623171 : klm =pawtab%indklmn(1,klmn)
2289 3623171 : lmin=pawtab%indklmn(3,klmn)
2290 3623171 : lmax=pawtab%indklmn(4,klmn)
2291 10868947 : do ils=lmin,lmax,2
2292 7193122 : lm0=ils**2+ils+1
2293 42603041 : do mm=-ils,ils
2294 31786748 : ilslm=lm0+mm;isel=pawang%gntselect(ilslm,klm)
2295 31786748 : if (isel>0) dijhat_idij(klmn)=dijhat_idij(klmn) &
2296 14154655 : & +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 53230 : klmn1=max(1,ispden-2);klmn2=1
2328 3700377 : do klmn=1,lmn2_size
2329 3647147 : dijhat(klmn1,idij)=dijhat_idij(klmn2)
2330 3647147 : klmn1=klmn1+cplex_dij
2331 3700377 : klmn2=klmn2+qphase
2332 : end do
2333 105036 : 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 43536 : LIBPAW_DEALLOCATE(prod)
2370 43536 : LIBPAW_DEALLOCATE(dijhat_idij)
2371 43536 : 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 43536 : 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 43536 : 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 535 : subroutine pawdijnd(dijnd,cplex_dij,gprimd,iatom,natom,ndij,nspden,nucdipmom,&
2421 535 : & 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 535 : integer,pointer :: indlmn(:,:),indklmn(:,:)
2446 535 : real(dp),allocatable :: ff(:),intgr3(:),v1(:),zk1(:)
2447 : character(len=500) :: msg
2448 : ! *************************************************************************
2449 :
2450 : !Useful data
2451 535 : angl_size=pawang%angl_size
2452 535 : indklmn => pawtab%indklmn
2453 535 : indlmn => pawtab%indlmn
2454 535 : mesh_size=pawtab%mesh_size
2455 535 : ij_size=pawtab%ij_size
2456 535 : lm_size=pawtab%lcut_size**2
2457 535 : lmn2_size=pawtab%lmn2_size
2458 535 : 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 535 : 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 535 : 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 1605 : LIBPAW_ALLOCATE(zk1,(mesh_size))
2474 535 : 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 106093 : dijnd = zero
2509 :
2510 : !-------------------------------------------------------------------
2511 : ! Computation of (<phi_i|phi_j>-<tphi_i|tphi_j>)/r^3 radial integral
2512 : !-------------------------------------------------------------------
2513 :
2514 1605 : LIBPAW_ALLOCATE(intgr3,(ij_size))
2515 :
2516 1070 : LIBPAW_ALLOCATE(ff,(mesh_size))
2517 5885 : do kln=1,ij_size
2518 6903680 : do imesh = 2, mesh_size
2519 6898330 : rr = pawrad%rad(imesh)
2520 6903680 : ff(imesh)=(pawtab%phiphj(imesh,kln)- pawtab%tphitphj(imesh,kln))/(rr**3)
2521 : end do !imesh
2522 1646850 : if (usezora) ff(2:mesh_size)=ff(2:mesh_size)*zk1(2:mesh_size)
2523 5350 : call pawrad_deducer0(ff,mesh_size,pawrad)
2524 5885 : call simp_gen(intgr3(kln),ff,pawrad)
2525 : end do
2526 535 : LIBPAW_DEALLOCATE(ff)
2527 :
2528 : !---------------------------
2529 : ! accumulate matrix elements
2530 : !---------------------------
2531 19795 : do klmn=1,lmn2_size
2532 :
2533 19260 : ilmn=indklmn(7,klmn)
2534 19260 : jlmn=indklmn(8,klmn)
2535 :
2536 19260 : il=indlmn(1,ilmn)
2537 19260 : jl=indlmn(1,jlmn)
2538 :
2539 19260 : im=indlmn(2,ilmn)
2540 19260 : jm=indlmn(2,jlmn)
2541 19260 : 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 19260 : if ( il /= jl ) cycle
2546 12840 : if ( il == 0 ) cycle
2547 :
2548 45475 : do idir = 1, 3
2549 :
2550 : ! this loop accumulates a dot product so if no dipole moment in direction idir, nothing to do
2551 33705 : if( ABS(nucdipmom(idir,iatom)) .LT. tol8 ) cycle
2552 :
2553 11235 : call slxyzs(il,im,idir,jl,jm,lms)
2554 :
2555 11235 : cmatrixelement = FineStructureConstant2*lms*nucdipmom(idir,iatom)*intgr3(kln)
2556 11235 : dijnd(2*klmn-1,1) = dijnd(2*klmn-1,1) + real(cmatrixelement)
2557 52965 : 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 535 : 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 1508 : do jatom=1,natom
2569 973 : 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 1508 : & 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 22927 : if(ndij > 1) dijnd(:,2)=dijnd(:,1)
2580 :
2581 535 : if(allocated(zk1)) then
2582 535 : LIBPAW_DEALLOCATE(zk1)
2583 : end if
2584 :
2585 535 : 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 3969 : subroutine pawdijfr(gprimd,idir,ipert,my_natom,natom,nfft,ngfft,nspden,nsppol,ntypat,&
3983 3969 : & option,paw_ij1,pawang,pawfgrtab,pawrad,pawtab,qphase,qphon,rprimd,ucvol,&
3984 3969 : & vpsp1,vtrial,vxc,xred,&
3985 3969 : & 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 3969 : 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 3969 : real(dp),allocatable :: ff(:),intv(:,:),intv1(:,:),intv2(:,:),intvloc(:,:),intv_tmp(:,:)
4020 3969 : 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 7809 : 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 41148 : subroutine symdij(gprimd,indsym,ipert,my_natom,natom,nsym,ntypat,option_dij,&
5087 41148 : & paw_ij,pawang,pawprtvol,pawtab,rprimd,symafm,symrec, &
5088 20574 : & 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 20574 : integer, pointer :: indlmn(:,:)
5124 20574 : integer,pointer :: my_atmtab(:)
5125 20574 : 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 20574 : real(dp),allocatable :: dijnew(:,:,:),dijtmp(:,:),symrec_cart(:,:,:)
5129 20574 : type(coeff2_type),target, allocatable :: my_tmp_dij(:)
5130 20574 : 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 20574 : 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 18810 : & (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 20574 : paral_atom=(present(comm_atom).and.(my_natom/=natom))
5160 20574 : nullify(my_atmtab);if (present(mpi_atmtab)) my_atmtab => mpi_atmtab
5161 20574 : my_comm_atom=xmpi_comm_self;if (present(comm_atom)) my_comm_atom=comm_atom
5162 20574 : 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 20574 : my_qphase=1;my_cplex_dij=1;my_ndij=1
5166 20574 : if (my_natom>0) then
5167 18810 : my_qphase=paw_ij(1)%qphase
5168 18810 : my_cplex_dij=paw_ij(1)%cplex_dij
5169 18810 : my_ndij=paw_ij(1)%ndij
5170 18810 : if (option_dij==4.or.option_dij==5.or.option_dij==9) my_qphase=1
5171 18810 : if (option_dij==10) my_cplex_dij=1
5172 18810 : if (option_dij==10) my_ndij=1
5173 : end if
5174 :
5175 : !Antiferro case ?
5176 20574 : 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 20574 : noncoll=.false.;if (my_natom>0) noncoll=(my_ndij==4)
5179 20574 : if (my_natom>0) then
5180 18810 : 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 20574 : use_afm=((antiferro).or.(noncoll.and.afm_noncoll))
5187 :
5188 : !Do we have a phase due to q-vector?
5189 20574 : has_qphase=.false.
5190 20574 : if (my_natom>0) then
5191 18810 : has_qphase=(paw_ij(1)%qphase==2)
5192 18810 : if (present(qphon)) then
5193 13799 : 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 20574 : 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 20574 : 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 9184 : 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 8365 : if (antiferro) then
5684 0 : msg='In the antiferromagnetic case, nsym cannot be 1'
5685 0 : LIBPAW_BUG(msg)
5686 : end if
5687 :
5688 25698 : do iatom=1,my_natom
5689 48000 : do ispden=1,my_ndij
5690 22302 : qphase=paw_ij(iatom)%qphase
5691 22302 : cplex_dij=paw_ij(iatom)%cplex_dij
5692 22302 : lmn2_size=paw_ij(iatom)%lmn2_size
5693 39635 : if (option_dij==0) then
5694 944298 : do klmn=1,lmn2_size*cplex_dij*qphase
5695 944298 : 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 20574 : 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 41148 : 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 8522 : 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 8522 : real(dp),allocatable,target :: dij1(:),dij2(:)
6156 8522 : real(dp),pointer :: dij2p(:),dij2p_(:)
6157 :
6158 : ! *************************************************************************
6159 :
6160 : !Optional arguments
6161 4408 : my_unt =std_out ; if (PRESENT(unit )) my_unt =unit
6162 8522 : my_mode ='COLL' ; if (PRESENT(mode_paral)) my_mode =mode_paral
6163 8522 : my_prtvol=1 ; if (PRESENT(opt_prtvol)) my_prtvol=opt_prtvol
6164 8522 : my_test_value=-one; if (PRESENT(test_value)) my_test_value=test_value
6165 8522 : my_Ha_or_eV=1 ; if (PRESENT(Ha_or_eV)) my_Ha_or_eV=Ha_or_eV
6166 :
6167 : !Title
6168 8522 : 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 8522 : ndij=size(dij,2)
6177 8522 : lmn2_size=size(dij,1)/(cplex_dij*qphase)
6178 8522 : lmn_size=int(dsqrt(two*dble(lmn2_size)))
6179 8522 : 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 24702 : do idij=1,ndij
6186 :
6187 16180 : idij_sym=idij;if (ndij==4.and.idij>2) idij_sym=7-idij
6188 :
6189 : !Subtitle
6190 16180 : 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 16180 : my_idij=min(size(dij,2),idij)
6199 16180 : my_idij_sym=min(size(dij,2),idij_sym)
6200 16180 : if (qphase==1) then
6201 16180 : tmp_cplex_dij=cplex_dij
6202 16180 : dij2p => dij(1:cplex_dij*lmn2_size:1,my_idij)
6203 16180 : 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 16180 : 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 24702 : & opt_sym=2,asym_ij=dij2p_,mode_paral=my_mode,force_print=.true.)
6229 :
6230 : end do !idij
6231 :
6232 8522 : if (qphase==2) then
6233 0 : LIBPAW_DEALLOCATE(dij1)
6234 0 : LIBPAW_DEALLOCATE(dij2)
6235 : end if
6236 :
6237 17044 : 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 : !!***
|
