Branch data Line data Source code
1 : : !!****m* ABINIT/m_dfpt_scfcv
2 : : !! NAME
3 : : !! m_dfpt_scfcv
4 : : !!
5 : : !! FUNCTION
6 : : !!
7 : : !! COPYRIGHT
8 : : !! Copyright (C) 1999-2026 ABINIT group (XG, DRH, MB, XW, MT, SPr, XW, MV, MM, AR)
9 : : !! This file is distributed under the terms of the
10 : : !! GNU General Public License, see ~abinit/COPYING
11 : : !! or http://www.gnu.org/copyleft/gpl.txt .
12 : : !!
13 : : !! SOURCE
14 : :
15 : : #if defined HAVE_CONFIG_H
16 : : #include "config.h"
17 : : #endif
18 : :
19 : : #include "abi_common.h"
20 : :
21 : : ! nvtx related macro definition
22 : : #include "nvtx_macros.h"
23 : :
24 : : module m_dfpt_scfcv
25 : :
26 : : use defs_basis
27 : : use m_abi_mixing
28 : : use m_efield
29 : : use m_errors
30 : : use m_dtset
31 : : use m_abicore
32 : : use m_wfk
33 : : use m_wffile
34 : : use m_xmpi
35 : : use m_nctk
36 : : use m_hdr
37 : : use m_dtfil
38 : : use m_hamiltonian
39 : : use netcdf
40 : :
41 : : use defs_datatypes, only : pseudopotential_type
42 : : use defs_abitypes, only : MPI_type
43 : : use m_cgtools, only : mean_fftr, overlap_g, dotprod_vn, dotprod_vn, dotprod_g
44 : : use m_fstrings, only : int2char4, sjoin
45 : : use m_geometry, only : metric, stresssym
46 : : use m_time, only : abi_wtime, sec2str, timab
47 : : use m_io_tools, only : open_file, file_exists, get_unit, iomode_from_fname
48 : : use m_exit, only : get_start_time, have_timelimit_in, get_timelimit, enable_timelimit_in
49 : : use m_mpinfo
50 : : use m_kg, only : getcut, mkkin, kpgstr, mkkpg
51 : : use m_fft, only : fftpac, fourdp
52 : : use m_matrix, only : mati3inv
53 : : use m_dynmat, only : dfpt_sygra
54 : : use m_occ, only : occeig
55 : : use m_paw_mkrho, only : pawmkrho
56 : : use m_mkffnl, only : mkffnl
57 : : use m_getgh1c, only : getgh1c
58 : : use m_dfpt_mkrho, only : dfpt_accrho
59 : : use m_nonlop, only : nonlop
60 : : use m_ioarr, only : ioarr, fftdatar_write_from_hdr, fort_denpot_skip
61 : : use m_pawang, only : pawang_type
62 : : use m_pawrad, only : pawrad_type
63 : : use m_pawtab, only : pawtab_type
64 : : use m_paw_an, only : paw_an_type, paw_an_init, paw_an_free, paw_an_nullify, paw_an_reset_flags
65 : : use m_paw_energies, only : paw_energies_type
66 : : use m_paw_ij, only : paw_ij_type, paw_ij_init, paw_ij_free, paw_ij_nullify, paw_ij_reset_flags
67 : : use m_pawfgrtab,only : pawfgrtab_type
68 : : use m_pawrhoij, only : pawrhoij_type, pawrhoij_init_unpacked, pawrhoij_gather, pawrhoij_filter, &
69 : : pawrhoij_alloc, pawrhoij_free, pawrhoij_nullify, &
70 : : pawrhoij_free_unpacked, pawrhoij_mpisum_unpacked, pawrhoij_inquire_dim
71 : : use m_pawcprj, only : pawcprj_type, pawcprj_alloc, pawcprj_get, pawcprj_copy, pawcprj_axpby, pawcprj_free, pawcprj_getdim
72 : : use m_pawdij, only : pawdij, pawdijfr, symdij
73 : : use m_pawfgr, only : pawfgr_type
74 : : use m_paw_denpot, only : pawdenpot
75 : : use m_paw_dfpt, only : pawdfptenergy
76 : : use m_paw_nhat, only : pawmknhat,pawnhatfr
77 : : use m_rf2, only : rf2_getidirs
78 : : use m_dens, only : calcdenmagsph, prtdenmagsph, magmom_to_d2, calmaxdifmag
79 : : use m_dfpt_fef, only : dfptff_initberry, qmatrix, dfptff_edie, dfptff_ebp, dfptff_die, dfptff_bec
80 : : use m_dfpt_vtorho, only : dfpt_vtorho
81 : : use m_paral_atom, only : get_my_atmtab, free_my_atmtab
82 : : use m_common, only : scprqt
83 : : use m_prcref, only : moddiel
84 : : use m_dfpt_rhotov, only : dfpt_rhotov
85 : : use m_dfpt_mkvxc, only : dfpt_mkvxc, dfpt_mkvxc_noncoll
86 : : use m_dfpt_mkvxcstr, only : dfpt_mkvxcstr
87 : : use m_mklocl, only : dfpt_vlocal, vlocalstr
88 : : use m_dfpt_nstwf, only : dfpt_nstpaw, dfpt_nstwf
89 : : use m_mkcore, only : dfpt_mkcore
90 : : use m_spacepar, only : hartrestr, make_vectornd, symrhg
91 : :
92 : : #if defined(HAVE_GPU_MARKERS)
93 : : use m_nvtx_data
94 : : #endif
95 : :
96 : : implicit none
97 : :
98 : : private
99 : : !!***
100 : :
101 : : public :: dfpt_scfcv
102 : : !!***
103 : :
104 : : contains
105 : : !!***
106 : :
107 : : !!****f* ABINIT/dfpt_scfcv
108 : : !! NAME
109 : : !! dfpt_scfcv
110 : : !!
111 : : !! FUNCTION
112 : : !! Conducts set of passes or overall iterations of preconditioned
113 : : !! conjugate gradient algorithm to converge wavefunctions to
114 : : !! optimum and optionally to compute mixed derivatives of energy.
115 : : !!
116 : : !! INPUTS
117 : : !! atindx(natom)=index table for atoms (see gstate.f)
118 : : !! cg(2,mpw*nspinor*mband*mkmem*nsppol)=pw coefficients of GS wavefunctions at k.
119 : : !! cgq(2,mpw1*nspinor*mband*mkqmem*nsppol)=pw coefficients of GS wavefunctions at k+q.
120 : : !! cplex: if 1, real space 1-order functions on FFT grid are REAL, if 2, COMPLEX
121 : : !! cprj(natom,nspinor*mband*mkmem*nsppol*usecprj)= wave functions at k
122 : : !! projected with non-local projectors: cprj=<p_i|Cnk>
123 : : !! cprjq(natom,nspinor*mband*mkqmem*nsppol*usecprj)= wave functions at k+q
124 : : !! projected with non-local projectors: cprjq=<p_i|Cnk+q>
125 : : !! cpus= cpu time limit in seconds
126 : : !! doccde_rbz(mband*nkpt_rbz*nsppol)=derivative of occ_rbz wrt the energy
127 : : !! docckqde(mband*nkpt_rbz*nsppol)=derivative of occkq wrt the energy
128 : : !! dtfil <type(datafiles_type)>=variables related to files
129 : : !! dtset <type(dataset_type)>=all input variables for this dataset
130 : : !! eew=2nd derivative of Ewald energy (hartree)
131 : : !! efrhar=Contribution from frozen-wavefunction, hartree energy,
132 : : !! to the second-derivative of total energy.
133 : : !! efrkin=Contribution from frozen-wavefunction, kinetic energy,
134 : : !! to the second-derivative of total energy.
135 : : !! efrloc=Contribution from frozen-wavefunction, local potential,
136 : : !! to the second-derivative of total energy.
137 : : !! efrnl=Contribution from frozen-wavefunction, non-local potential,
138 : : !! to the second-derivative of total energy.
139 : : !! efrx1=Contribution from frozen-wavefunction, xc core correction(1),
140 : : !! to the second-derivative of total energy.
141 : : !! efrx2=Contribution from frozen-wavefunction, xc core correction(2),
142 : : !! to the second-derivative of total energy.
143 : : !! eigenq(mband*nkpt_rbz*nsppol)=GS eigenvalues at k+q (hartree)
144 : : !! eigen0(mband*nkpt_rbz*nsppol)=GS eigenvalues at k (hartree)
145 : : !! eii=2nd derivative of pseudopotential core energy (hartree)
146 : : !! evdw=DFT-D semi-empirical part of 2nd-order total energy
147 : : !! fermie=fermi energy (Hartree)
148 : : !! hdr <type(hdr_type)>=the header of wf, den and pot files
149 : : !! idir=direction of the current perturbation
150 : : !! indkpt1(nkpt_rbz)=non-symmetrized indices of the k-points
151 : : !! indsy1(4,nsym1,natom)=indirect indexing array for atom labels
152 : : !! ipert=type of the perturbation
153 : : !! irrzon1(nfft**(1-1/nsym1),2,(nspden/nsppol)-3*(nspden/4))=irreducible zone data for RF symmetries
154 : : !! istwfk_rbz(nkpt_rbz)=input option parameter that describes the storage of wfs
155 : : !! kg(3,mpw*mkmem)=reduced planewave coordinates at k
156 : : !! kg1(3,mpw1*mk1mem)=reduced planewave coordinates at k+q, with RF k points
157 : : !! kpt_rbz(3,nkpt_rbz)=reduced coordinates of k points.
158 : : !! kxc(nfftf,nkxc)=exchange and correlation kernel (see rhotoxc.f)
159 : : !! mband_mem_rbz=maximum number of bands per processor in memory for cg
160 : : !! mgfftf=maximum size of 1D FFTs for the "fine" grid (see NOTES in respfn.F90)
161 : : !! mkmem =number of k points treated by this node (GS data)
162 : : !! mkqmem =number of k+q points which can fit in memory (GS data); 0 if use disk
163 : : !! mk1mem =number of k points which can fit in memory (RF data); 0 if use disk
164 : : !! mpert=maximum number of ipert
165 : : !! mpw=maximum dimensioned size of npw for wfs at k.
166 : : !! mpw1=maximum dimensioned size of npw for wfs at k+q (also for 1-order wfs).
167 : : !! nattyp(ntypat)= # atoms of each type.
168 : : !! nband_rbz(nkpt_rbz*nsppol)=number of bands at each RF k point, for each polarization
169 : : !! ncpgr=number of gradients stored in cprj array (cprj=<p_i|Cnk>)
170 : : !! nfftf=(effective) number of FFT grid points (for this proc) for the "fine" grid (see NOTES in respfn.F90)
171 : : !! ngfftf(1:18)=integer array with FFT box dimensions and other for the "fine" grid (see NOTES in respfn.F90)
172 : : !! nkpt=number of k points in the full BZ
173 : : !! nkpt_rbz=number of k points in the reduced BZ for this perturbation
174 : : !! nkxc=second dimension of the kxc array.
175 : : !! mpi_enreg=information about MPI parallelization
176 : : !! my_natom=number of atoms treated by current processor
177 : : !! npwarr(nkpt_rbz)=number of planewaves in basis at this GS k point
178 : : !! npwar1(nkpt_rbz)=number of planewaves in basis at this RF k+q point
179 : : !! nspden=number of spin-density components
180 : : !! nspinor=number of spinorial components of the wavefunctions
181 : : !! nsym1=number of symmetry elements in space group consistent with perturbation
182 : : !! n3xccc=dimension of xccc3d1 ; 0 if no XC core correction is used otherwise, nfftf
183 : : !! occkq(mband*nkpt_rbz*nsppol)=occupation number for each band (often 2)
184 : : !! at each k+q point of the reduced Brillouin zone.
185 : : !! occ_rbz(mband*nkpt_rbz*nsppol)=occupation number for each band (often 2)
186 : : !! at each k point of the reduced Brillouin zone.
187 : : !! paw_an(natom) <type(paw_an_type)>=paw arrays given on angular mesh for the GS
188 : : !! paw_ij(natom*usepaw) <type(paw_ij_type)>=paw arrays given on (i,j) channels for the GS
189 : : !! pawang <type(pawang_type)>=paw angular mesh and related data
190 : : !! pawang1 <type(pawang_type)>=pawang datastr. containing only symmetries preserving the perturbation
191 : : !! pawfgr <type(pawfgr_type)>=fine grid parameters and related data
192 : : !! pawfgrtab(natom*usepaw) <type(pawfgrtab_type)>=atomic data given on fine rectangular grid for the GS
193 : : !! pawrad(ntypat*usepaw) <type(pawrad_type)>=paw radial mesh and related data
194 : : !! pawrhoij(natom) <type(pawrhoij_type)>= paw rhoij occupancies and related data for the GS
195 : : !! pawtab(ntypat*usepaw) <type(pawtab_type)>=paw tabulated starting data
196 : : !! pertcase=fuill index of the perturbation
197 : : !! phnons1(2,nfft**(1-1/nsym1),(nspden/nsppol)-3*(nspden/4))=nonsymmorphic transl. phases, for RF symmetries
198 : : !! ph1d(2,3*(2*mgfft+1)*natom)=one-dimensional structure factor information
199 : : !! ph1df(2,3*(2*mgfftf+1)*natom)=one-dimensional structure factor information for the "fine" grid
200 : : !! prtbbb=if 1, band-by-band decomposition (also dim of d2bbb)
201 : : !! psps <type(pseudopotential_type)>=variables related to pseudopotentials
202 : : !! qphon(3)=reduced coordinates for the phonon wavelength
203 : : !! rhog(2,nfftf)=array for Fourier transform of GS electron density
204 : : !! rhor(nfftf,nspden)=array for GS electron density in electrons/bohr**3.
205 : : !! rprimd(3,3)=dimensional primitive translations in real space (bohr)
206 : : !! symaf1(nsym1)=anti(ferromagnetic) part of symmetry operations
207 : : !! symrc1(3,3,nsym1)=symmetry operations in reciprocal space
208 : : !! symrl1(3,3,nsym1)=symmetry operations in real space in terms
209 : : !! of primitive translations
210 : : !! tnons1(3,nsym1)=non-symmorphic translations
211 : : !! usecprj= 1 if cprj, cprjq arrays are stored in memory
212 : : !! useylmgr = 1 if ylmgr array is allocated
213 : : !! useylmgr1= 1 if ylmgr1 array is allocated
214 : : !! usevxctau=1 if if XC functional depends on kinetic energy density
215 : : !! ddk<wfk_t>=ddk file
216 : : !! vpsp1(cplex*nfftf)=first-order derivative of the ionic potential
217 : : !! vtrial(nfftf,nspden)=GS potential (Hartree).
218 : : !! vxc(nfftf,nspden)=Exchange-Correlation GS potential (Hartree)
219 : : !! vxctau(nfftf,nspden,4*usevxctau)=derivative of e_xc with respect to kinetic energy density, for mGGA
220 : : !! wtk_rbz(nkpt_rbz)=weight for each k point in the reduced Brillouin zone
221 : : !! xccc3d1(cplex*n3xccc)=3D change in core charge density, see n3xccc
222 : : !! xred(3,natom)=reduced dimensionless atomic coordinates
223 : : !! ylm(mpw*mkmem,mpsang*mpsang*useylm)= real spherical harmonics for each G and k point
224 : : !! ylm1(mpw1*mk1mem,mpsang*mpsang*useylm)= real spherical harmonics for each G and k+q point
225 : : !! ylmgr(mpw*mkmem,3,mpsang*mpsang*useylm*useylmgr)= gradients of real spherical harmonics at k
226 : : !! ylmgr1(mpw1*mk1mem,3,mpsang*mpsang*useylm*useylmgr1)= gradients of real spherical harmonics at k+q
227 : : !!
228 : : !! OUTPUT
229 : : !! blkflg(3,mpert,3,mpert)=flags for each element of the 2DTE (=1 if computed)
230 : : !! cg1_active(2,mpw1*nspinor*mband*mk1mem*nsppol)=pw coefficients of RF
231 : : !! wavefunctions at k,q. They are orthogonalized to the active.
232 : : !! d2bbb(2,3,3,mpert,mband,mband*prtbbb)=band by band decomposition of some
233 : : !! second order derivatives
234 : : !! d2lo(2,mpert,3,mpert)=local contributions to the 2DTEs
235 : : !! d2nl(2,mpert,3,mpert)=non-local contributions to the 2DTEs
236 : : !! d2ovl(2,mpert,3,mpert*usepaw)=1st-order change of WF overlap contributions to the 2DTEs
237 : : !! eberry=energy associated with Berry phase
238 : : !! edocc=correction to 2nd-order total energy coming from changes of occupation
239 : : !! eeig0=0th-order eigenenergies part of 2nd-order total energy
240 : : !! ehart01=inhomogeneous 1st-order Hartree part of 2nd-order total energy
241 : : !! for strain perturbation only (zero otherwise, and not used)
242 : : !! ehart1=1st-order Hartree part of 2nd-order total energy
243 : : !! eigen1(2*mband*mband*nkpt_rbz*nsppol)=array for holding eigenvalues (hartree)
244 : : !! ek0=0th-order kinetic energy part of 2nd-order total energy.
245 : : !! ek1=1st-order kinetic energy part of 2nd-order total energy.
246 : : !! eloc0=0th-order local (psp+vxc+Hart) part of 2nd-order total energy
247 : : !! elmag1=1st-order Zeeman part of 2nd-order total energy.
248 : : !! elpsp1=1st-order local pseudopot. part of 2nd-order total energy.
249 : : !! emagpen1=1st-order magnetic penalty part of 2nd-order total energy.
250 : : !! end0=0th-order nuclear dipole part of 2nd-order total energy
251 : : !! end1=1st-order nuclear dipole part of 2nd-order total energy
252 : : !! enl0=0th-order nonlocal pseudopot. part of 2nd-order total energy.
253 : : !! enl1=1st-order nonlocal pseudopot. part of 2nd-order total energy.
254 : : !! eovl1=1st-order change of wave-functions overlap, part of 2nd-order energy
255 : : !! PAW only - Eq(79) and Eq(80) of PRB 78, 035105 (2008) [[cite:Audouze2008]]
256 : : !! epaw1=1st-order PAW on-site part of 2nd-order total energy.
257 : : !! etotal=total energy (sum of 7 contributions) (hartree)
258 : : !! evxctau0=0th-order energy from vxctau
259 : : !! evxctau1=1st-order energy from vxctau
260 : : !! exc1=1st-order exchange-correlation part of 2nd-order total energy.
261 : : !! gh1c_set(2,mpw1*nspinor*mband*mk1mem*nsppol*dim_eig2rf)= set of <G|H^{(1)}|nK>
262 : : !! gh0c1_set(2,mpw1*nspinor*mband*mk1mem*nsppol*dim_eig2rf)= set of <G|H^{(0)}|\Psi^{(1)}>
263 : : !! The wavefunction is orthogonal to the active space (for metals). It is not
264 : : !! coherent with cg1.
265 : : !! resid(mband*nkpt_rbz*nsppol)=residuals for each band over all k points
266 : : !! of the reduced Brillouin zone, and spins
267 : : !! residm=maximum value from resid array (except for nbdbuf highest bands)
268 : : !! conv_retcode=return code, 0 if convergence was achieved.
269 : : !!
270 : : !! SIDE EFFECTS
271 : : !! cg1(2,mpw1*nspinor*mband*mk1mem*nsppol)=updated wavefunctions (ortho. to occ. states);
272 : : !! initialized= if 0 the initialization of the RF run is not yet finished
273 : : !! mpi_enreg=information about MPI parallelization
274 : : !! rhog1(2,nfftf)=array for Fourier transform of RF electron density
275 : : !! rhor1(cplex*nfftf,nspden)=array for RF electron density in electrons/bohr**3.
276 : : !! === if psps%usepaw==1
277 : : !! pawrhoij1(natom) <type(pawrhoij_type)>= 1st-order paw rhoij occupancies and related data
278 : : !!
279 : : !! SOURCE
280 : :
281 : 4708 : subroutine dfpt_scfcv(atindx,blkflg,cg,cgq,cg1,cg1_active,cplex,cprj,cprjq,cpus,&
282 : 2354 : & dielt,dim_eig2rf,doccde_rbz,docckqde,dtfil,dtset,&
283 : 2354 : & d2bbb,d2lo,d2nl,d2ovl,eberry,edocc,eeig0,eew,efrhar,efrkin,efrloc,efrnl,efrx1,efrx2,&
284 : 2354 : & ehart01,ehart1,eigenq,eigen0,eigen1,eii,ek0,ek1,elmag1,eloc0,elpsp1,emagpen1,&
285 : : & end0,end1,enl0,enl1,eovl1,epaw1,etotal,evxctau0,evxctau1,evdw,exc1,&
286 : 4708 : & fermie,gh0c1_set,gh1c_set,hdr,idir,indkpt1,&
287 : 2354 : & indsy1,initialized,ipert,irrzon1,istwfk_rbz,&
288 : 2354 : & kg,kg1,kpt_rbz,kxc,mband_mem_rbz,mgfftf,mkmem,mkqmem,mk1mem,&
289 : 2354 : & mpert,mpi_enreg,mpw,mpw1,mpw1_mq,my_natom,nattyp,nband_rbz,ncpgr,&
290 : 2354 : & nfftf,ngfftf,nhat,nkpt,nkpt_rbz,nkxc,npwarr,npwar1,nspden,&
291 : 2354 : & nsym1,n3xccc,occkq,occ_rbz,&
292 : 2354 : & paw_an,paw_ij,pawang,pawang1,pawfgr,pawfgrtab,pawrad,pawrhoij,pawrhoij1,pawtab,&
293 : 4708 : & pertcase,phnons1,ph1d,ph1df,&
294 : 2354 : & prtbbb,psps,qphon,resid,residm,rhog,rhog1,&
295 : 2354 : & rhor,rhor1,rprimd,symaf1,symrc1,symrl1,tnons1,&
296 : 2354 : & usecprj,useylmgr,useylmgr1,usevxctau,ddk_f,vpsp1,vtrial,vxc,vxctau,&
297 : 4708 : & wtk_rbz,xccc3d1,xred,ylm,ylm1,ylmgr,ylmgr1,zeff,conv_retcode,&
298 : : & kramers_deg,&
299 : 4708 : & cg_mq,cg1_mq,cg1_active_mq,docckde_mq,eigen_mq,eigen1_mq,gh0c1_set_mq,gh1c_set_mq,&
300 : 22 : & kg1_mq,npwar1_mq,occk_mq,resid_mq,residm_mq,rhog1_pq,rhog1_mq,rhor1_pq,rhor1_mq,&
301 : 2354 : & ylm1_mq,ylmgr1_mq)
302 : :
303 : : !Arguments ------------------------------------
304 : : type(dataset_type),intent(in) :: dtset
305 : : type(pseudopotential_type),intent(in) :: psps
306 : : integer,intent(in) :: cplex,dim_eig2rf,idir,ipert,mgfftf,mk1mem,mkmem,mkqmem
307 : : integer,intent(in) :: mpert,mpw,mpw1,my_natom,n3xccc,ncpgr,nfftf
308 : : integer,intent(in) :: mband_mem_rbz
309 : : integer,intent(in) :: mpw1_mq !-q duplicate
310 : : integer,intent(in) :: nkpt,nkpt_rbz,nkxc,nspden
311 : : integer,intent(in) :: nsym1,pertcase,prtbbb,usecprj,useylmgr,useylmgr1,usevxctau
312 : : logical,intent(in) :: kramers_deg
313 : : integer,intent(inout) :: initialized
314 : : ! nfft**(1-1/nsym1) is 1 if nsym1==1, and nfft otherwise
315 : : integer,intent(in) :: atindx(dtset%natom)
316 : : integer,intent(out) :: blkflg(3,mpert,3,mpert)
317 : : integer,intent(in) :: indkpt1(nkpt_rbz),indsy1(4,nsym1,dtset%natom)
318 : : integer,intent(in) :: irrzon1(dtset%nfft**(1-1/nsym1),2,(dtset%nspden/dtset%nsppol)-3*(dtset%nspden/4))
319 : : integer,intent(in) :: istwfk_rbz(nkpt_rbz)
320 : : integer,intent(in) :: kg(3,mpw*mkmem),kg1(3,mpw1*mk1mem),nattyp(psps%ntypat)
321 : : integer,intent(in) :: nband_rbz(nkpt_rbz*dtset%nsppol)
322 : : integer,intent(in) :: npwar1(nkpt_rbz),npwarr(nkpt_rbz)
323 : : integer,optional,intent(in) :: npwar1_mq(nkpt_rbz) !-q duplicate
324 : : integer,optional,intent(in) :: kg1_mq(3,mpw1_mq*mk1mem)!
325 : : integer,intent(in) :: symaf1(nsym1),symrc1(3,3,nsym1),symrl1(3,3,nsym1)
326 : : integer,intent(out) :: conv_retcode
327 : : real(dp),intent(in) :: cpus,eew,efrhar,efrkin,efrloc,efrnl,efrx1,efrx2,eii
328 : : real(dp),intent(out) :: eberry,edocc,eeig0,ehart01,ehart1,ek0,ek1,eloc0,elpsp1,emagpen1,end0,end1
329 : : real(dp),intent(out) :: enl0,enl1,eovl1,epaw1,etotal,evdw,evxctau0,evxctau1,exc1,residm
330 : : real(dp),optional,intent(out) :: residm_mq !-q duplicate
331 : : real(dp),intent(inout) :: fermie
332 : : real(dp),intent(in) :: qphon(3)
333 : : ! nfft**(1-1/nsym1) is 1 if nsym1==1, and nfft otherwise
334 : : integer,intent(in) :: ngfftf(18)
335 : : real(dp),intent(in) :: cg(2,mpw*dtset%nspinor*mband_mem_rbz*mkmem*dtset%nsppol)
336 : : real(dp),intent(inout) :: cg1(2,mpw1*dtset%nspinor*mband_mem_rbz*mk1mem*dtset%nsppol)
337 : : real(dp),intent(out) :: cg1_active(2,mpw1*dtset%nspinor*mband_mem_rbz*mk1mem*dtset%nsppol*dim_eig2rf)
338 : : real(dp),intent(out) :: gh1c_set(2,mpw1*dtset%nspinor*mband_mem_rbz*mk1mem*dtset%nsppol*dim_eig2rf)
339 : : real(dp),intent(out) :: gh0c1_set(2,mpw1*dtset%nspinor*mband_mem_rbz*mk1mem*dtset%nsppol*dim_eig2rf)
340 : : real(dp),intent(in) :: cgq(2,mpw1*dtset%nspinor*mband_mem_rbz*mkqmem*dtset%nsppol)
341 : : real(dp),optional,intent(inout) :: cg1_mq(2,mpw1_mq*dtset%nspinor*mband_mem_rbz*mk1mem*dtset%nsppol) !start -q duplicates
342 : : real(dp),optional,intent(out) :: cg1_active_mq(2,mpw1_mq*dtset%nspinor*mband_mem_rbz*mk1mem*dtset%nsppol*dim_eig2rf)!
343 : : real(dp),optional,intent(out) :: gh1c_set_mq(2,mpw1_mq*dtset%nspinor*mband_mem_rbz*mk1mem*dtset%nsppol*dim_eig2rf) !
344 : : real(dp),optional,intent(out) :: gh0c1_set_mq(2,mpw1_mq*dtset%nspinor*mband_mem_rbz*mk1mem*dtset%nsppol*dim_eig2rf) !
345 : : real(dp),optional,intent(in) :: cg_mq(2,mpw1_mq*dtset%nspinor*mband_mem_rbz*mkqmem*dtset%nsppol) !
346 : : real(dp),optional,intent(in) :: eigen_mq(dtset%mband*nkpt_rbz*dtset%nsppol) !
347 : : real(dp),optional,intent(in) :: docckde_mq(dtset%mband*nkpt_rbz*dtset%nsppol) !
348 : : real(dp),optional,intent(out) :: eigen1_mq(2*dtset%mband*dtset%mband*nkpt_rbz*dtset%nsppol) !
349 : : real(dp),optional,intent(in) :: occk_mq(dtset%mband*nkpt_rbz*dtset%nsppol) !
350 : : real(dp),optional,intent(out) :: resid_mq(dtset%mband*nkpt_rbz*nspden) !end
351 : : real(dp),intent(out) :: d2bbb(2,3,3,mpert,dtset%mband,dtset%mband*prtbbb)
352 : : real(dp),intent(out) :: d2lo(2,3,mpert,3,mpert),d2nl(2,3,mpert,3,mpert)
353 : : real(dp),intent(out) :: d2ovl(2,3,mpert,3,mpert*psps%usepaw)
354 : : real(dp),intent(in) :: dielt(3,3)
355 : : real(dp),intent(in) :: doccde_rbz(dtset%mband*nkpt_rbz*dtset%nsppol)
356 : : real(dp),intent(in) :: docckqde(dtset%mband*nkpt_rbz*dtset%nsppol)
357 : : real(dp),intent(in) :: eigen0(dtset%mband*nkpt_rbz*dtset%nsppol)
358 : : real(dp),intent(out) :: eigen1(2*dtset%mband*dtset%mband*nkpt_rbz*dtset%nsppol)
359 : : real(dp),intent(in) :: eigenq(dtset%mband*nkpt_rbz*dtset%nsppol)
360 : : real(dp),intent(in) :: kpt_rbz(3,nkpt_rbz),kxc(nfftf,nkxc)
361 : : real(dp),intent(in) :: nhat(nfftf,dtset%nspden)
362 : : real(dp),intent(in) :: occ_rbz(dtset%mband*nkpt_rbz*dtset%nsppol)
363 : : real(dp),intent(in) :: occkq(dtset%mband*nkpt_rbz*dtset%nsppol)
364 : : real(dp),intent(in) :: ph1d(2,3*(2*dtset%mgfft+1)*dtset%natom),ph1df(2,3*(2*mgfftf+1)*dtset%natom)
365 : : real(dp),intent(in) :: phnons1(2,dtset%nfft**(1-1/nsym1),(dtset%nspden/dtset%nsppol)-3*(dtset%nspden/4))
366 : : real(dp),intent(out) :: resid(dtset%mband*nkpt_rbz*nspden)
367 : : real(dp),intent(in) :: rhog(2,nfftf),rhor(nfftf,nspden),rprimd(3,3)
368 : : real(dp),intent(inout) :: rhog1(2,nfftf),rhor1(cplex*nfftf,nspden),xred(3,dtset%natom)
369 : : real(dp),optional,intent(inout) :: rhog1_pq(2,nfftf),rhor1_pq(cplex*nfftf,nspden) !+q/-q duplicates
370 : : real(dp),optional,intent(inout) :: rhog1_mq(2,nfftf),rhor1_mq(cplex*nfftf,nspden) !
371 : : real(dp),intent(in) :: tnons1(3,nsym1)
372 : : real(dp),target,intent(in) :: vtrial(nfftf,nspden)
373 : : real(dp),intent(in) :: vpsp1(cplex*nfftf),vxc(nfftf,nspden)
374 : : real(dp),intent(inout) :: vxctau(nfftf,dtset%nspden,4*usevxctau)
375 : : real(dp),intent(in) :: wtk_rbz(nkpt_rbz),xccc3d1(cplex*n3xccc)
376 : : real(dp),intent(in) :: ylm(mpw*mkmem,psps%mpsang*psps%mpsang*psps%useylm)
377 : : real(dp),intent(in) :: ylm1(mpw1*mk1mem,psps%mpsang*psps%mpsang*psps%useylm)
378 : : real(dp),intent(in) :: ylmgr(mpw*mkmem,3,psps%mpsang*psps%mpsang*psps%useylm*useylmgr)
379 : : real(dp),intent(in) :: ylmgr1(mpw1*mk1mem,3+6*((ipert-dtset%natom)/10),psps%mpsang*psps%mpsang*psps%useylm*useylmgr1)
380 : : real(dp),optional,intent(in) :: ylm1_mq(mpw1_mq*mk1mem,psps%mpsang*psps%mpsang*psps%useylm)
381 : : real(dp),optional,intent(in) :: ylmgr1_mq(mpw1_mq*mk1mem,3+6*((ipert-dtset%natom)/10),psps%mpsang*psps%mpsang*psps%useylm*useylmgr1)
382 : : real(dp),intent(in) :: zeff(3,3,dtset%natom)
383 : : type(pawcprj_type),intent(in) :: cprj(dtset%natom,dtset%nspinor*mband_mem_rbz*mkmem*dtset%nsppol*usecprj)
384 : : type(pawcprj_type),intent(in) :: cprjq(dtset%natom,dtset%nspinor*mband_mem_rbz*mkqmem*dtset%nsppol*usecprj)
385 : : type(datafiles_type),intent(in) :: dtfil
386 : : type(hdr_type),intent(inout) :: hdr
387 : : type(pawang_type),intent(in) :: pawang,pawang1
388 : : type(pawfgr_type),intent(in) :: pawfgr
389 : : type(paw_an_type),intent(in) :: paw_an(my_natom*psps%usepaw)
390 : : type(paw_ij_type),intent(in) :: paw_ij(my_natom*psps%usepaw)
391 : : type(pawfgrtab_type),intent(inout) :: pawfgrtab(my_natom*psps%usepaw)
392 : : type(pawrad_type),intent(in) :: pawrad(psps%ntypat*psps%usepaw)
393 : : type(pawrhoij_type),intent(in) :: pawrhoij(my_natom*psps%usepaw)
394 : : type(pawrhoij_type),intent(inout) :: pawrhoij1(my_natom*psps%usepaw)
395 : : type(pawtab_type), intent(in) :: pawtab(psps%ntypat*psps%usepaw)
396 : : type(MPI_type),intent(inout) :: mpi_enreg
397 : : type(wfk_t),intent(inout) :: ddk_f(4)
398 : :
399 : : !Local variables-------------------------------
400 : : !scalars
401 : : integer,parameter :: level=12,response=1
402 : : integer :: afford,bantot_rbz,choice,cplex_rhoij,dbl_nnsclo
403 : : integer :: has_dijfr,has_diju,iatom,ider,idir_dum,idir_paw1,ierr,errid,denpot
404 : : integer :: iprcel,iscf10_mod,iscf_mod,ispden,ispmix
405 : : integer :: istep,istep_fock_outer,istep_mix,itypat,izero,me,mgfftdiel,mvdum !lmn2_size,
406 : : integer :: nfftdiel,nfftmix,nfftotf,nhat1grdim,npawmix,npwdiel,nspden_rhoij,nstep,nzlmopt
407 : : integer :: optene,optfr,option,optres,prtfor,qphase_rhoij,quit,quit_sum,qzero
408 : : integer :: my_quit,quitsum_request,timelimit_exit,varid,ncerr,ncid
409 : : integer ABI_ASYNC :: quitsum_async
410 : : integer :: rdwrpaw,spaceComm,sz1,sz2,usexcnhat,with_vectornd,Z_kappa
411 : : integer :: dbl_nnsclo_mq,ifft !-q duplicate for dbl_nnsclo
412 : : !integer :: pqmq ! pqmq = indicator for potential mixing
413 : : logical :: need_fermie1,nmxc,paral_atom,use_nhat_gga
414 : : real(dp) :: wtime_step,now,prev
415 : : real(dp) :: born,born_bar,boxcut,deltae,diffor,diel_q,dum,ecut,ecutf,elast,maxmag,difmag
416 : : real(dp) :: eta,evar,fe1fixed,fermie1,gsqcut,omega,qphon_norm,maxfor,renorm,res2,res3,residm2
417 : : real(dp) :: ucvol,vxcavg,elmag1,el_temp
418 : : real(dp) :: res2_mq,fe1fixed_mq,elast_mq
419 : : real(dp) :: eberry_mq,edocc_mq,eeig0_mq,ehart01_mq,ehart1_mq,ek0_mq,ek1_mq,eloc0_mq,elpsp1_mq
420 : : real(dp) :: end0_mq,end1_mq,enl0_mq,enl1_mq,eovl1_mq,epaw1_mq,exc1_mq,fermie1_mq,deltae_mq,elmag1_mq
421 : : real(dp) :: etotal_mq,evar_mq,omega_mq
422 : : real(dp) :: evxctau0_mq,evxctau1_mq
423 : : character(len=500) :: msg
424 : : character(len=500),parameter :: MY_NAME="dfpt_scfcv"
425 : : character(len=fnlen) :: fi1o
426 : : !character(len=fnlen) :: fi1o_vtk
427 : : integer :: prtopt
428 : : type(abi_mixing_object) :: mix
429 : 2354 : type(efield_type) :: dtefield
430 : : type(paw_energies_type) :: paw1_energies
431 : : !arrays
432 : : integer :: ngfftmix(18)
433 : 2354 : integer,allocatable :: dimcprj(:),pwindall(:,:,:)
434 : 2354 : integer,pointer :: my_atmtab(:)
435 : : real(dp) :: dielar(7)
436 : : real(dp) :: favg(3),gmet(3,3),gprimd(3,3),q_cart(3),qphon2(3),qphon_mq(3),qred2cart(3,3)
437 : 4708 : real(dp) :: rhomag(2,nspden),rmet(3,3),tollist(12),tsec(2)
438 : : real(dp) :: zeff_red(3),zeff_bar(3,3)
439 : 7062 : real(dp) :: intgden(cplex,dtset%nspden,dtset%natom),dentot(dtset%nspden)
440 : 4708 : real(dp) :: intgden0(cplex,dtset%nspden,dtset%natom)
441 : : !real(dp) :: zdmc_red(3),zdmc_bar(3,3),mean_rhor1(1) !dynamic magnetic charges and mean density
442 : 2354 : real(dp),allocatable :: d2bbb_mq(:,:,:,:,:,:),d2lo_mq(:,:,:,:,:),d2nl_mq(:,:,:,:,:)
443 : 2354 : real(dp),allocatable :: d2bbb_pq(:,:,:,:,:,:),d2lo_pq(:,:,:,:,:),d2nl_pq(:,:,:,:,:)
444 : 2354 : real(dp),allocatable :: dielinv(:,:,:,:,:)
445 : 2354 : real(dp),allocatable :: fcart(:,:),nhat1(:,:),nhat1gr(:,:,:),nhatfermi(:,:),nvresid1(:,:),nvresid2(:,:)
446 : 2354 : real(dp),allocatable :: qmat(:,:,:,:,:,:),resid2(:),rhog2(:,:),rhor2(:,:),rhorfermi(:,:)
447 : 2354 : real(dp),allocatable :: susmat(:,:,:,:,:),vectornd(:,:,:),vhartr1(:),vxc1(:,:)
448 : 2354 : real(dp),allocatable :: vhartr1_tmp(:,:)
449 : 2354 : real(dp),allocatable,target :: vtrial1(:,:),vtrial2(:,:)
450 : 2354 : real(dp),allocatable :: vtrial1_mq(:,:),rhorfermi_mq(:,:)
451 : 2354 : real(dp),allocatable :: nvresid1_mq(:,:)
452 : 2354 : real(dp),pointer :: vtrial1_tmp(:,:)
453 : 2354 : type(pawcprj_type),allocatable :: cprj1(:,:)
454 : 2354 : type(paw_an_type),allocatable :: paw_an1(:)
455 : 2354 : type(paw_ij_type),allocatable :: paw_ij1(:)
456 : 2354 : type(pawrhoij_type),allocatable :: pawrhoijfermi(:)
457 : : ! *********************************************************************
458 : : DBG_ENTER("COLL")
459 : :
460 : 2354 : if (dtset%occopt == 9) then
461 : 0 : write(msg,'(a)') "Cannot perform dfpt with occopt = 9: not yet implemented"
462 : 0 : ABI_ERROR(msg)
463 : : end if
464 : :
465 : 2354 : call timab(120,1,tsec)
466 : 2354 : call timab(154,1,tsec)
467 : :
468 : : ! intel 18 really needs this to be initialized
469 : 2354 : maxfor = zero
470 : :
471 : : ! enable time limit handler if not done in callers.
472 [ - + ]: 2354 : if (enable_timelimit_in(MY_NAME) == MY_NAME) then
473 [ - - ]: 2354 : write(std_out,*)"Enabling timelimit check in function: ",trim(MY_NAME)," with timelimit: ",trim(sec2str(get_timelimit()))
474 : : end if
475 : :
476 : : !Parallelism data
477 : 2354 : spaceComm=mpi_enreg%comm_cell
478 : 2354 : me=mpi_enreg%me_kpt
479 : 2354 : paral_atom=(my_natom/=dtset%natom)
480 : 2354 : my_atmtab=>mpi_enreg%my_atmtab
481 : :
482 : : !Save some variables from dataset definition
483 : 2354 : ecut=dtset%ecut
484 [ + + ]: 2354 : ecutf=ecut;if (psps%usepaw==1) ecutf=dtset%pawecutdg
485 : 2354 : iprcel=dtset%iprcel
486 : 2354 : tollist(1)=dtset%tolmxf;tollist(2)=dtset%tolwfr
487 : 2354 : tollist(3)=dtset%toldff;tollist(4)=dtset%toldfe
488 : 2354 : tollist(6)=dtset%tolvrs;tollist(7)=dtset%tolrff
489 : 2354 : tollist(9)=dtset%toldmag
490 [ + + ]: 9416 : nfftotf=product(ngfftf(1:3))
491 : 2354 : nstep=dtset%nstep
492 : 2354 : iscf_mod=dtset%iscf
493 : 2354 : iscf10_mod=mod(iscf_mod,10)
494 : :
495 [ + + ]: 2354 : qzero=0; if(qphon(1)**2+qphon(2)**2+qphon(3)**2 < tol14) qzero=1
496 : :
497 : : need_fermie1=((qzero==1.and.dtset%frzfermi==0.and.nstep>0).and.&
498 : : & (dtset%occopt>=3.and.dtset%occopt<=8).and. &
499 : : & (ipert<=dtset%natom.or.ipert==dtset%natom+3.or.ipert==dtset%natom+4.or.&
500 : : & ipert==dtset%natom+5.or.ipert==dtset%natom+6.or.&
501 [ + + + - : 1630 : & (ipert>dtset%natom+11.and.ipert<=2*dtset%natom+11)))
+ + + + +
+ + + + +
- + - + -
- ]
502 : :
503 : : !The value of iscf must be modified if ddk perturbation, see dfpt_looppert.f
504 [ + + + + : 2354 : if (ipert==dtset%natom+1.or.ipert==dtset%natom+10.or.ipert==dtset%natom+11) iscf_mod=-3
+ + ]
505 : :
506 : : !Get electronic temperature from dtset
507 [ + - - - : 2354 : el_temp=merge(dtset%tphysel,dtset%tsmear,dtset%tphysel>tol8.and.dtset%occopt/=3.and.dtset%occopt/=9)
- - ]
508 : :
509 : : !Compute different geometric tensor, as well as ucvol, from rprimd
510 : 2354 : call metric(gmet,gprimd,-1,rmet,rprimd,ucvol)
511 : :
512 : : !Compute large sphere cut-off gsqcut
513 [ + + ]: 2354 : qphon2(:)=zero;if (psps%usepaw==1) qphon2(:)=qphon(:)
514 : 2354 : call getcut(boxcut,ecutf,gmet,gsqcut,dtset%iboxcut,std_out,qphon2,ngfftf)
515 : :
516 : : !Some variables need to be initialized/nullify at start
517 : 2354 : quit=0 ; dbl_nnsclo=0 ; elast=zero; conv_retcode = -1
518 [ - + ]: 2354 : optres=merge(0,1,abs(iscf_mod)<10)
519 [ + + + - ]: 2354 : nmxc=(dtset%usepaw==1.and.mod(abs(dtset%usepawu),10)==4)
520 : 2354 : usexcnhat=0
521 : : !This might be taken away later
522 : 2354 : edocc=zero ; eeig0=zero ; ehart01=zero ; ehart1=zero ; ek0=zero ; ek1=zero
523 : 2354 : eloc0=zero ; elpsp1=zero ; end0=zero; end1=zero;
524 : 2354 : enl0=zero ; enl1=zero ; eovl1=zero; evxctau0=zero; evxctau1=zero; exc1=zero
525 : 2354 : deltae=zero ; fermie1=zero ; epaw1=zero ; eberry=zero ; elmag1=zero
526 : 2354 : elast_mq=zero ; emagpen1=zero
527 : 2354 : dbl_nnsclo_mq=0
528 : : !This might be taken away later
529 : 2354 : edocc_mq=zero ; eeig0_mq=zero ; ehart01_mq=zero ; ehart1_mq=zero ; ek0_mq=zero ; ek1_mq=zero
530 : 2354 : eloc0_mq=zero ; elpsp1_mq=zero ; enl0_mq=zero ; enl1_mq=zero ;
531 : 2354 : end0_mq=zero; end1_mq=zero; eovl1_mq=zero; evxctau0_mq=zero; evxctau1_mq=zero; exc1_mq=zero
532 : 2354 : deltae_mq=zero ; fermie1_mq=zero ; epaw1_mq=zero ; eberry_mq=zero ; elmag1_mq=zero
533 : 2354 : res2_mq=zero
534 : :
535 : : !Examine tolerance criteria, and eventually print a line to the output
536 : : !file (with choice=1, the only non-dummy arguments of scprqt are
537 : : !nstep, tollist and iscf - still, diffor,res2,prtfor,fcart are here initialized to 0)
538 : 2354 : choice=1 ; prtfor=0 ; diffor=zero ; res2=zero
539 : 2354 : maxmag=zero;difmag=zero
540 [ + + + + : 21379 : intgden=zero
+ + ]
541 [ - + + - : 7062 : ABI_MALLOC(fcart,(3,dtset%natom))
+ - + - -
+ - + ]
542 : :
543 : : !At present, no double loop
544 : 2354 : istep_mix=1 ; istep_fock_outer=1
545 : :
546 : : call scprqt(choice,cpus,deltae,diffor,maxmag,difmag,dtset,eigen0,&
547 : : & etotal,favg,fcart,fermie,fermie,dtfil%fnametmp_eig,dtfil%filnam_ds(1),&
548 : : & 1,iscf_mod,istep,istep_fock_outer,istep_mix,kpt_rbz,maxfor,&
549 : : & mvdum,mpi_enreg,nband_rbz,nkpt_rbz,&
550 : : & nstep,occ_rbz,0,prtfor,0,&
551 : : & quit,res2,resid,residm,response,&
552 : 2354 : & tollist,psps%usepaw,vxcavg,wtk_rbz,xred,conv_retcode)
553 : :
554 : : !Allocations/initializations for PAW only
555 [ + + ]: 2354 : if(psps%usepaw==1) then
556 [ + + ]: 1151 : usexcnhat=maxval(pawtab(:)%usexcnhat)
557 [ + + + - : 409 : use_nhat_gga=(dtset%xclevel==2.and.dtset%pawnhatxc>0.and.usexcnhat>0)
+ + ]
558 : : ! 1st-order compensation density
559 [ - + + - : 1636 : ABI_MALLOC(nhat1,(cplex*nfftf,dtset%nspden))
- + + - +
- + - - +
- + ]
560 [ + + + + ]: 22252739 : nhat1=zero
561 : : ! Projections of 1-st order WF on nl projectors
562 [ - + + - : 243192 : ABI_MALLOC(cprj1,(dtset%natom,dtset%nspinor*mband_mem_rbz*mk1mem*dtset%nsppol*usecprj))
- + + - +
- + - - +
- + + + +
+ ]
563 [ + - + - ]: 409 : if (usecprj==1.and.mk1mem/=0) then
564 : : !cprj ordered by atom-type
565 [ - + + - : 1227 : ABI_MALLOC(dimcprj,(dtset%natom))
+ - + - -
+ - + ]
566 : 409 : call pawcprj_getdim(dimcprj,dtset%natom,nattyp,dtset%ntypat,dtset%typat,pawtab,'O')
567 : 409 : call pawcprj_alloc(cprj1,0,dimcprj)
568 [ - + ]: 409 : ABI_FREE(dimcprj)
569 : : end if
570 : : ! 1st-order arrays/variables related to the PAW spheres
571 [ + + + - : 2011 : ABI_MALLOC(paw_an1,(my_natom))
+ - + + -
+ - + + +
+ - ]
572 [ + + + - : 2011 : ABI_MALLOC(paw_ij1,(my_natom))
+ - + + -
+ - + + +
+ - ]
573 : 409 : call paw_an_nullify(paw_an1)
574 : 409 : call paw_ij_nullify(paw_ij1)
575 : :
576 [ + + + + ]: 409 : has_dijfr=0;if (ipert/=dtset%natom+1.and.ipert/=dtset%natom+10) has_dijfr=1
577 [ - + ]: 409 : has_diju=merge(0,1,dtset%usepawu==0)
578 : : call paw_an_init(paw_an1,dtset%natom,dtset%ntypat,0,0,dtset%nspden,&
579 : : & cplex,dtset%pawxcdev,dtset%typat,pawang,pawtab,has_vxc=1,has_vxctau=usevxctau,&
580 : 409 : & comm_atom=mpi_enreg%comm_atom,mpi_atmtab=mpi_enreg%my_atmtab)
581 : : call paw_ij_init(paw_ij1,cplex,dtset%nspinor,dtset%nsppol,dtset%nspden,0,dtset%natom,&
582 : : & dtset%ntypat,dtset%typat,pawtab,&
583 : : & has_dij=1,has_dijhartree=1,has_dijfr=has_dijfr,has_dijU=has_diju,&
584 : 409 : & mpi_atmtab=mpi_enreg%my_atmtab, comm_atom=mpi_enreg%comm_atom)
585 : : else
586 [ - + ]: 1945 : ABI_MALLOC(nhat1,(0,0))
587 [ - + ]: 1945 : ABI_MALLOC(cprj1,(0,0))
588 [ - + ]: 1945 : ABI_MALLOC(paw_an1,(0))
589 [ - + ]: 1945 : ABI_MALLOC(paw_ij1,(0))
590 : : end if ! PAW
591 : :
592 : : !Various allocations (potentials)
593 [ - + + - : 7062 : ABI_MALLOC(vhartr1,(cplex*nfftf))
+ - + - -
+ - + -
+ ]
594 [ - + + - : 9416 : ABI_MALLOC(vtrial1,(cplex*nfftf,nspden))
- + + - +
- + - - +
- + ]
595 [ + + ]: 2354 : if(.not.kramers_deg) then
596 [ - + + - : 33 : ABI_MALLOC(vtrial1_mq,(cplex*nfftf,nspden))
- + + - -
+ - + ]
597 [ - + + - : 55 : ABI_MALLOC(d2bbb_mq,(2,3,3,mpert,dtset%mband,dtset%mband*prtbbb))
- + + - +
- - - + -
- + - + -
+ ]
598 [ - + + - : 44 : ABI_MALLOC(d2bbb_pq,(2,3,3,mpert,dtset%mband,dtset%mband*prtbbb))
- + + - +
- - - - +
- + ]
599 [ - + + - : 55 : ABI_MALLOC(d2lo_mq,(2,3,mpert,3,mpert))
+ - - + +
- + - + -
- + - + ]
600 [ - + + - : 33 : ABI_MALLOC(d2lo_pq,(2,3,mpert,3,mpert))
- + + - -
+ - + ]
601 [ - + + - : 33 : ABI_MALLOC(d2nl_mq,(2,3,mpert,3,mpert))
- + + - -
+ - + ]
602 [ - + + - : 33 : ABI_MALLOC(d2nl_pq,(2,3,mpert,3,mpert))
- + + - -
+ - + ]
603 [ - + - - : 11 : d2bbb_mq=zero
- - - - -
- - - ]
604 [ - + - - : 11 : d2bbb_pq=zero
- - - - -
- - - ]
605 [ + + + + : 133563 : d2lo_mq=zero
+ + + + +
+ ]
606 [ + + + + : 133563 : d2lo_pq=zero
+ + + + +
+ ]
607 [ + + + + : 133563 : d2nl_mq=zero
+ + + + +
+ ]
608 [ + + + + : 133563 : d2nl_pq=zero
+ + + + +
+ ]
609 : : end if
610 : : ! TODO: for non collinear case this should always be nspden, in NCPP case as well!!!
611 [ - + + - : 9416 : ABI_MALLOC(vxc1,(cplex*nfftf,nspden*(1-usexcnhat))) ! Not always needed
+ + + - +
- + + - +
- + - + ]
612 : 2354 : vtrial1_tmp => vtrial1 ! this is to avoid errors when vtrial1_tmp is unused
613 : :
614 : : !Several parameters and arrays for the SCF mixing:
615 : : !These arrays are needed only in the self-consistent case
616 [ + + ]: 2354 : if (iscf_mod>0.or.iscf_mod==-3) then
617 [ - + + - : 8920 : ABI_MALLOC(nvresid1,(cplex*nfftf,dtset%nspden))
- + + - +
- + - - +
- + ]
618 [ - + - - : 2230 : if (nstep==0) nvresid1=zero
- - ]
619 [ + + + + : 2230 : if ((dtset%getddb .ne. 0 .or. dtset%irdddb .ne.0) .and. qzero .ne. 1) then
+ - ]
620 [ - + + - : 36 : ABI_MALLOC(nvresid2,(cplex*nfftf,dtset%nspden))
- + + - -
+ - + ]
621 [ - + - - : 12 : if (nstep==0) nvresid2=zero
- - ]
622 : : end if
623 [ + + ]: 2230 : if (.not.kramers_deg) then
624 [ - + + - : 33 : ABI_MALLOC(nvresid1_mq,(cplex*nfftf,dtset%nspden))
- + + - -
+ - + ]
625 [ - + - - : 11 : if (nstep==0) nvresid1_mq=zero
- - ]
626 : : end if
627 : : else
628 [ - + ]: 124 : ABI_MALLOC(nvresid1,(0,0))
629 [ - + ]: 124 : if(.not.kramers_deg) then
630 [ # # ]: 0 : ABI_MALLOC(nvresid1_mq,(0,0))
631 : : end if
632 : : end if
633 [ + - + + ]: 2354 : if(nstep>0 .and. iscf_mod>0) then
634 : 1600 : dielar(1)=dtset%diecut;dielar(2)=dtset%dielng
635 : 1600 : dielar(3)=dtset%diemac;dielar(4)=dtset%diemix
636 : 1600 : dielar(5)=dtset%diegap;dielar(6)=dtset%dielam
637 [ - + ]: 1600 : dielar(7)=dtset%diemix;if (dtset%iscf>=10) dielar(7)=dtset%diemixmag
638 : : ! Additional allocation for mixing within PAW
639 : 1600 : npawmix=0
640 [ + + ]: 1600 : if(psps%usepaw==1) then
641 [ + + ]: 653 : do iatom=1,my_natom
642 : 435 : itypat=pawrhoij1(iatom)%itypat
643 : 435 : pawrhoij1(iatom)%use_rhoijres=1
644 : 435 : sz1=pawrhoij1(iatom)%cplex_rhoij*pawrhoij1(iatom)%qphase*pawrhoij1(iatom)%lmn2_size
645 : 435 : sz2=pawrhoij1(iatom)%nspden
646 [ - + + - : 1740 : ABI_MALLOC(pawrhoij1(iatom)%rhoijres,(sz1,sz2))
- + + - +
- + - - +
- + - + ]
647 [ + + ]: 902 : do ispden=1,pawrhoij1(iatom)%nspden
648 [ + + ]: 23028 : pawrhoij1(iatom)%rhoijres(:,ispden)=zero
649 : : end do
650 [ - + + - : 1305 : ABI_MALLOC(pawrhoij1(iatom)%kpawmix,(pawtab(itypat)%lmnmix_sz))
+ - + - -
+ - + -
+ ]
651 : 435 : pawrhoij1(iatom)%lmnmix_sz=pawtab(itypat)%lmnmix_sz
652 [ + - - + : 18208 : pawrhoij1(iatom)%kpawmix=pawtab(itypat)%kmix
- - - - +
+ ]
653 : : npawmix=npawmix+pawrhoij1(iatom)%nspden*pawtab(itypat)%lmnmix_sz &
654 : 653 : & *pawrhoij1(iatom)%cplex_rhoij*pawrhoij1(iatom)%qphase
655 : : end do
656 : : end if
657 : 1600 : denpot = ABI_MIXING_POTENTIAL
658 [ - + ]: 1600 : if (dtset%iscf > 10) denpot = ABI_MIXING_DENSITY
659 [ + + + - ]: 1600 : if (psps%usepaw==1.and.dtset%pawmixdg==0) then
660 [ + + ]: 4142 : ispmix=ABI_MIXING_FOURRIER_SPACE;nfftmix=dtset%nfft;ngfftmix(:)=dtset%ngfft(:)
661 : : else
662 : 1382 : ispmix=ABI_MIXING_REAL_SPACE;nfftmix=nfftf;ngfftmix(:)=ngfftf(:)
663 : : end if
664 [ - + ]: 1600 : if (iscf10_mod == 5 .or. iscf10_mod == 6) then
665 : : call abi_mixing_new(mix, iscf10_mod, denpot, cplex, &
666 : : & nfftf, dtset%nspden, npawmix, errid, msg, dtset%npulayit, &
667 : 0 : & pulayhist_storage=dtset%pulayhiststore)
668 : : else
669 : : call abi_mixing_new(mix, iscf10_mod, denpot, max(cplex, ispmix), &
670 : : & nfftmix, dtset%nspden, npawmix, errid, msg, dtset%npulayit, &
671 : 1600 : & pulayhist_storage=dtset%pulayhiststore)
672 : : end if
673 [ - + ]: 1600 : if (errid /= AB7_NO_ERROR) then
674 : 0 : ABI_ERROR(msg)
675 : : end if
676 [ - + ]: 1600 : if (dtset%mffmem == 0) then
677 : 0 : call abi_mixing_use_disk_cache(mix, dtfil%fnametmp_fft)
678 : : end if
679 : : end if ! iscf, nstep
680 : :
681 : : !Here, allocate arrays for computation of susceptibility and dielectric matrix or for TDDFT
682 [ + - + + : 2354 : if( (nstep>0 .and. iscf_mod>0) .or. iscf_mod==-1 ) then
- + ]
683 : : ! Here, for TDDFT, artificially set iprcel . Also set a variable to reduce the memory needs.
684 : 1600 : afford=1
685 [ - + ]: 1600 : if(iscf_mod==-1) then
686 : 0 : iprcel=21
687 : 0 : afford=0
688 : : end if
689 : 1600 : npwdiel=1
690 : 1600 : mgfftdiel=1
691 : 1600 : nfftdiel=1
692 : : ! Now, performs allocation
693 : : ! CAUTION : the dimensions are still those of GS, except for phnonsdiel
694 [ - + + - : 6400 : ABI_MALLOC(dielinv,(2,npwdiel*afford,nspden,npwdiel,nspden))
- + + - +
- + - - +
- + ]
695 [ - + + - : 4800 : ABI_MALLOC(susmat,(2,npwdiel*afford,nspden,npwdiel,nspden))
- + + - -
+ - + ]
696 : : end if
697 : :
698 : : !Initialize Berry-phase related stuffs
699 : : if (dtset%berryopt== 4.or.dtset%berryopt== 6.or.dtset%berryopt== 7.or.&
700 [ + + ]: 2354 : & dtset%berryopt==14.or.dtset%berryopt==16.or.dtset%berryopt==17) then
701 [ - + + - : 36 : ABI_MALLOC(pwindall,(max(mpw,mpw1)*mkmem,8,3))
+ - + - +
- - + -
+ ]
702 : : call dfptff_initberry(dtefield,dtset,gmet,kg,kg1,dtset%mband,mkmem,mpi_enreg,&
703 : 9 : & mpw,mpw1,nkpt,npwarr,npwar1,dtset%nsppol,occ_rbz,pwindall,rprimd)
704 : : ! calculate inverse of the overlap matrix
705 [ - + + - : 63 : ABI_MALLOC(qmat,(2,dtefield%mband_occ,dtefield%mband_occ,nkpt,2,3))
- + + - -
+ + - + -
+ - + - +
- - + -
+ ]
706 : : call qmatrix(cg,dtefield,qmat,mpi_enreg,mpw,mpw1,mkmem,dtset%mband,mband_mem_rbz,&
707 : 9 : & npwarr,nkpt,dtset%nspinor,dtset%nsppol,pwindall)
708 : : else
709 [ - + ]: 2345 : ABI_MALLOC(pwindall,(0,0,0))
710 [ - + ]: 2345 : ABI_MALLOC(qmat,(0,0,0,0,0,0))
711 : : end if
712 : :
713 : : ! if any nuclear dipoles are nonzero, compute the vector potential in real space
714 : 2354 : with_vectornd = 0
715 : : ! nuclear dipoles only work with the DDK response function
716 [ + + + + : 23650 : if ( (ANY(ABS(dtset%nucdipmom(:,:))>tol8)) .AND. (ipert.EQ.dtset%natom+1) ) with_vectornd = 1
+ + + + +
- ]
717 : : ABI_SFREE(vectornd)
718 [ + + + - : 11770 : ABI_MALLOC(vectornd,(with_vectornd*nfftf,dtset%nspden,3))
- + + - +
- + - + +
- + - + ]
719 [ + + ]: 2354 : if(with_vectornd .EQ. 1) then
720 : : call make_vectornd(1,gsqcut,psps%usepaw,mpi_enreg,dtset%natom,nfftf,&
721 : 60 : & ngfftf,dtset%nspden,dtset%nucdipmom,rprimd,vectornd,xred)
722 : : endif
723 : :
724 : : ! Set the value of omega for a finite-frequency calculation
725 : 2354 : omega=dtset%rfomega
726 : 2354 : eta=dtset%rfeta
727 [ + + ]: 2354 : if (.not.kramers_deg) then
728 : 11 : omega_mq=-dtset%rfomega
729 [ + + ]: 44 : qphon_mq(:)=-qphon(:)
730 : : end if
731 : : #ifdef HAVE_OPENMP_OFFLOAD
732 : : ! Upload cgq array to GPU
733 : : !$OMP TARGET ENTER DATA MAP(to:cgq) IF(dtset%gpu_option==ABI_GPU_OPENMP)
734 : : #endif
735 : :
736 : 2354 : call timab(154,2,tsec)
737 : :
738 : : !######################################################################
739 : : !PERFORM ELECTRONIC ITERATIONS
740 : : !######################################################################
741 : :
742 : : !Offer option of computing 2nd-order total energy with existing
743 : : !wavefunctions when nstep<=0, else do nstep iterations
744 : : !Note that for non-self-consistent calculations, this loop will be exited
745 : : !after the first call to dfpt_vtorho
746 : :
747 : : !Pass through the first routines even when nstep==0
748 : : !write(std_out,*) 'dfpt_scfcv, nstep=', max(1,nstep)
749 : :
750 : 2354 : quitsum_request = xmpi_request_null; timelimit_exit = 0
751 : :
752 : : ABI_NVTX_START_RANGE(NVTX_DFPT_SCF)
753 [ + + ]: 18936 : do istep=1,max(1,nstep)
754 : :
755 : : ! Handle time limit condition.
756 [ + + ]: 18756 : if (istep == 1) prev = abi_wtime()
757 [ + + ]: 18756 : if (istep > 1) then
758 : 16402 : now = abi_wtime()
759 : 16402 : wtime_step = now - prev
760 : 16402 : prev = now
761 : 16402 : call wrtout(std_out,sjoin(" dfpt_scfcv: previous iteration took ",sec2str(wtime_step)))
762 : :
763 [ - + ]: 16402 : if (have_timelimit_in(MY_NAME)) then
764 [ # # ]: 0 : if (istep > 2) then
765 : 0 : call xmpi_wait(quitsum_request,ierr)
766 [ # # ]: 0 : if (quitsum_async > 0) then
767 [ # # ]: 0 : write(msg,"(3a)")" Approaching time limit ",trim(sec2str(get_timelimit())),". Will exit istep loop in dfpt_scfcv."
768 : 0 : ABI_COMMENT(msg)
769 : 0 : call wrtout(ab_out, msg, "COLL")
770 : 0 : timelimit_exit = 1
771 : 0 : exit
772 : : end if
773 : : end if
774 : :
775 [ # # ]: 0 : my_quit = 0; if (now - get_start_time() + 2.15 * wtime_step > get_timelimit()) my_quit = 1
776 : 0 : call xmpi_isum(my_quit,quitsum_async,spacecomm,quitsum_request,ierr)
777 : : end if
778 : : end if
779 : :
780 : : ! ######################################################################
781 : : ! The following steps are done once
782 : : ! ----------------------------------------------------------------------
783 [ + + ]: 18756 : if (istep==1)then
784 : :
785 : : ! PAW only: compute frozen part of 1st-order compensation density
786 : : ! and frozen part of psp strengths Dij
787 : : ! ----------------------------------------------------------------------
788 [ + + ]: 2354 : if (psps%usepaw==1) then
789 : 409 : optfr=0
790 : 409 : idir_paw1 = idir
791 [ + + ]: 409 : if (ipert==dtset%natom+11) then
792 : 30 : call rf2_getidirs(idir,idir_dum,idir_paw1)
793 : : end if
794 : : call pawdijfr(gprimd,idir_paw1,ipert,my_natom,dtset%natom,nfftf,ngfftf,nspden,dtset%nsppol,&
795 : : & psps%ntypat,optfr,paw_ij1,pawang,pawfgrtab,pawrad,pawtab,cplex,qphon,&
796 : : & rprimd,ucvol,vpsp1,vtrial,vxc,xred,&
797 : 409 : & mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom)
798 : :
799 [ + + + + : 409 : if ((iscf_mod>=0.or.usexcnhat==0).and.(dtset%pawstgylm/=0)) then
+ - ]
800 [ + + + + ]: 346 : ider=0;if ((ipert<=dtset%natom).and.(use_nhat_gga)) ider=1
801 : : call pawnhatfr(ider,idir_paw1,ipert,my_natom,dtset%natom,nspden,psps%ntypat,&
802 : : & pawang,pawfgrtab,pawrhoij,pawtab,rprimd,&
803 : 346 : & mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom)
804 : : end if
805 : : end if
806 : :
807 : : ! PAW only: we sometimes have to compute 1st-order compensation density
808 : : ! and eventually add it to density from 1st-order WFs
809 : : ! ----------------------------------------------------------------------
810 : 2354 : nhat1grdim=0
811 [ - + - + ]: 2354 : ABI_MALLOC(nhat1gr,(0,0,0))
812 [ + + + + : 2354 : if (psps%usepaw==1.and.ipert/=dtset%natom+1.and.ipert/=dtset%natom+10) then
+ + ]
813 : 248 : call timab(564,1,tsec)
814 [ + + ]: 248 : nhat1grdim=0;if (dtset%xclevel==2) nhat1grdim=usexcnhat*dtset%pawnhatxc
815 : 248 : ider=2*nhat1grdim;izero=0
816 [ + + ]: 248 : if (nhat1grdim>0) then
817 [ - + ]: 2 : ABI_FREE(nhat1gr)
818 [ - + + - : 10 : ABI_MALLOC(nhat1gr,(cplex*nfftf,dtset%nspden,3*nhat1grdim))
- + + - -
+ + - + -
+ - - + -
+ ]
819 : : end if
820 : : call pawmknhat(dum,cplex,ider,idir_paw1,ipert,izero,gprimd,my_natom,dtset%natom,&
821 : : & nfftf,ngfftf,nhat1grdim,nspden,psps%ntypat,pawang,pawfgrtab,nhat1gr,nhat1,&
822 : : & pawrhoij1,pawrhoij,pawtab,qphon,rprimd,ucvol,dtset%usewvl,xred,&
823 : 248 : & mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom)
824 [ - + - - : 248 : if (dtfil%ireadwf/=0.and.dtset%get1den==0.and.dtset%ird1den==0.and.initialized==0) then
- - - - ]
825 [ # # # # ]: 0 : rhor1(:,:)=rhor1(:,:)+nhat1(:,:)
826 : 0 : call fourdp(cplex,rhog1,rhor1(:,1),-1,mpi_enreg,nfftf,1, ngfftf,0)
827 : : end if
828 : 248 : call timab(564,2,tsec)
829 : : end if
830 : : ! Set initial guess for 1st-order potential
831 : : ! ----------------------------------------------------------------------
832 [ + + ]: 2354 : option=1;optene=0;if (iscf_mod==-2) optene=1
833 : : call dfpt_rhotov(cplex,ehart01,ehart1,elmag1,elpsp1,emagpen1,exc1,gsqcut,dtset%icutcoul,idir,ipert,&
834 : : & dtset%ixc,kxc,dtset%magpen,dtset%mpatpol,dtset%mpdir,mpi_enreg,dtset%natom,nfftf,ngfftf,nhat,nhat1,nhat1gr,nhat1grdim,&
835 : : & nkxc,nspden,dtset%ntypat,n3xccc,nmxc,optene,option,dtset%qptn,dtset%ratsm,dtset%ratsph,&
836 : : & rhog,rhog1,rhor,rhor1,rprimd,dtset%typat,ucvol,psps%usepaw,usexcnhat,dtset%vcutgeo,vhartr1,vpsp1,&
837 : 2354 : & nvresid1,res2,vtrial1,vxc,vxc1,xccc3d1,dtset%ixcrot,xred,dtset%qgbt,dtset%use_gbt)
838 : :
839 : : !Compute vtrial1 at (+q,+omega) and (-q,-omega) with specific local part if q/=0
840 [ + + ]: 2354 : if (.not.kramers_deg) then
841 : 11 : call dfpt_vtrial1_mq(cplex,nfftf,dtset%nspden,nvresid1,nvresid1_mq,vtrial1,vtrial1_mq)
842 : : end if
843 : :
844 : : ! For Q=0 and metallic occupation, initialize quantities needed to
845 : : ! compute the first-order Fermi energy
846 : : ! ----------------------------------------------------------------------
847 [ + + ]: 2354 : if (need_fermie1) then
848 [ - + + - : 768 : ABI_MALLOC(rhorfermi,(cplex*nfftf,nspden))
- + + - +
- + - - +
- + - + ]
849 [ - + ]: 192 : if(.not.kramers_deg) then
850 [ # # # # : 0 : ABI_MALLOC(rhorfermi_mq,(cplex*nfftf,nspden))
# # # # #
# # # # #
# # # # ]
851 : : end if
852 [ + + + + ]: 192 : if (psps%usepaw==1.and.usexcnhat==0) then
853 [ - + + - : 68 : ABI_MALLOC(nhatfermi,(cplex*nfftf,nspden))
- + + - +
- + - - +
- + - + ]
854 : : else
855 [ - + - + ]: 175 : ABI_MALLOC(nhatfermi,(0,0))
856 : : end if
857 [ + + + - : 832 : ABI_MALLOC(pawrhoijfermi,(my_natom*psps%usepaw))
+ - + + -
+ - + - +
+ + ]
858 [ + + ]: 192 : if (psps%usepaw==1) then
859 : : !Q phase should be 1 because Q=0
860 : : call pawrhoij_inquire_dim(cplex_rhoij=cplex_rhoij,qphase_rhoij=qphase_rhoij,nspden_rhoij=nspden_rhoij,&
861 : 115 : & nspden=dtset%nspden,spnorb=dtset%pawspnorb,cplex=cplex,cpxocc=dtset%pawcpxocc)
862 : : call pawrhoij_alloc(pawrhoijfermi,cplex_rhoij,nspden_rhoij,dtset%nspinor,&
863 : : & dtset%nsppol,dtset%typat,pawtab=pawtab,mpi_atmtab=mpi_enreg%my_atmtab,&
864 : 115 : & comm_atom=mpi_enreg%comm_atom)
865 : : end if
866 : :
867 : : call dfpt_rhofermi(cg,cgq,cplex,cprj,cprjq,&
868 : : & doccde_rbz,docckqde,dtfil,dtset,eigenq,eigen0,eigen1,fe1fixed,gmet,gprimd,idir,&
869 : : & indsy1,ipert,irrzon1,istwfk_rbz,kg,kg1,kpt_rbz,dtset%mband,mband_mem_rbz,mkmem,mkqmem,mk1mem,mpi_enreg,&
870 : : & mpw,mpw1,my_natom,dtset%natom,nband_rbz,ncpgr,nfftf,ngfftf,nhatfermi,nkpt_rbz,npwarr,npwar1,&
871 : : & nspden,dtset%nsppol,nsym1,occkq,occ_rbz,&
872 : : & paw_ij,pawang,pawang1,pawfgr,pawfgrtab,pawrad,pawrhoijfermi,pawtab,&
873 : : & phnons1,ph1d,dtset%prtvol,psps,rhorfermi,rmet,rprimd,symaf1,symrc1,symrl1,tnons1,&
874 : : & ucvol,usecprj,useylmgr1,vtrial,vxc,wtk_rbz,xred,ylm,ylm1,ylmgr1,&
875 : 192 : & eta=eta,omega=omega)
876 [ - + ]: 192 : if (.not.kramers_deg) then
877 : : call dfpt_rhofermi(cg,cg_mq,cplex,cprj,cprjq,&
878 : : & doccde_rbz,docckde_mq,dtfil,dtset,eigen_mq,eigen0,eigen1_mq,fe1fixed_mq,gmet,gprimd,idir,&
879 : : & indsy1,ipert,irrzon1,istwfk_rbz,kg,kg1_mq,kpt_rbz,dtset%mband,mband_mem_rbz,mkmem,mkqmem,mk1mem,mpi_enreg,&
880 : : & mpw,mpw1_mq,my_natom,dtset%natom,nband_rbz,ncpgr,nfftf,ngfftf,nhatfermi,nkpt_rbz,npwarr,npwar1_mq,&
881 : : & nspden,dtset%nsppol,nsym1,occk_mq,occ_rbz,&
882 : : & paw_ij,pawang,pawang1,pawfgr,pawfgrtab,pawrad,pawrhoijfermi,pawtab,&
883 : : & phnons1,ph1d,dtset%prtvol,psps,rhorfermi_mq,rmet,rprimd,symaf1,symrc1,symrl1,tnons1,&
884 : : & ucvol,usecprj,useylmgr1,vtrial,vxc,wtk_rbz,xred,ylm,ylm1_mq,ylmgr1_mq,&
885 : 0 : & eta=eta,omega=omega) !is OK, no _mq is needed here
886 : : end if
887 : :
888 : : end if
889 : :
890 : : end if ! End the condition of istep==1
891 : :
892 : : ! ######################################################################
893 : : ! The following steps are done at every iteration
894 : : ! ----------------------------------------------------------------------
895 : :
896 [ + + ]: 18756 : if (psps%usepaw==1)then
897 : : ! Computation of "on-site" 2nd-order energy, first-order potentials, first-order densities
898 [ + + + - ]: 3568 : nzlmopt=0;if (istep==2.and.dtset%pawnzlm>0) nzlmopt=-1
899 [ + + ]: 3568 : if (istep>2) nzlmopt=dtset%pawnzlm
900 : 3568 : call paw_an_reset_flags(paw_an1) ! Force the recomputation of on-site potentials
901 : 3568 : call paw_ij_reset_flags(paw_ij1,self_consistent=.true.) ! Force the recomputation of Dij
902 [ + + + - ]: 3568 : option=0;if (dtset%iscf>0.and.dtset%iscf<10.and.nstep>0) option=1
903 : : call pawdenpot(dum,el_temp,gprimd,ipert,dtset%ixc,my_natom,dtset%natom,&
904 : : & dtset%nspden,psps%ntypat,dtset%nucdipmom,nzlmopt,option,paw_an1,paw_an,paw1_energies,&
905 : : & paw_ij1,pawang,dtset%pawprtvol,pawrad,pawrhoij1,dtset%pawspnorb,pawtab,dtset%pawxcdev,&
906 : : & dtset%spnorbscl,dtset%xclevel,dtset%xc_denpos,dtset%xc_taupos,xred,ucvol,psps%znuclpsp,dtset%spinaxis,&
907 : 3568 : & comm_atom=mpi_enreg%comm_atom,mpi_atmtab=mpi_enreg%my_atmtab)
908 : 3568 : epaw1=paw1_energies%epaw
909 : :
910 : : ! First-order Dij computation
911 : 3568 : call timab(561,1,tsec)
912 [ + + ]: 3568 : if (has_dijfr>0) then
913 : : !vpsp1 contribution to Dij already stored in frozen part of Dij
914 [ - + + - : 10708 : ABI_MALLOC(vtrial1_tmp,(cplex*nfftf,nspden))
- + + - +
- + - - +
- + ]
915 [ + - + + : 105694641 : vtrial1_tmp=vtrial1
+ + + + +
+ ]
916 [ + + ]: 5779 : do ispden=1,min(dtset%nspden,2)
917 [ + + ]: 52848659 : vtrial1_tmp(:,ispden)=vtrial1_tmp(:,ispden)-vpsp1(:)
918 : : end do
919 : : else
920 : 891 : vtrial1_tmp => vtrial1
921 : : end if
922 : : call pawdij(cplex,dtset%enunit,gprimd,ipert,my_natom,dtset%natom,&
923 : : & nfftf,nfftotf,dtset%nspden,psps%ntypat,paw_an1,paw_ij1,pawang,&
924 : : & pawfgrtab,dtset%pawprtvol,pawrad,pawrhoij1,dtset%pawspnorb,pawtab,&
925 : : & dtset%pawxcdev,qphon,dtset%spnorbscl,ucvol,dtset%cellcharge(1),vtrial1_tmp,vxc1,xred,dtset%znucl,&
926 [ - + ]: 3568 : & mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom,spinaxis=dtset%spinaxis)
927 [ + + ]: 3568 : if (has_dijfr>0) then
928 [ - + ]: 2677 : ABI_FREE(vtrial1_tmp)
929 : : end if
930 : :
931 : : call symdij(gprimd,indsy1,ipert,my_natom,dtset%natom,nsym1,psps%ntypat,0,&
932 : : & paw_ij1,pawang1,dtset%pawprtvol,pawtab,rprimd,symaf1,symrc1, &
933 : : & mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom,&
934 : 3568 : & qphon=qphon)
935 : 3568 : call timab(561,2,tsec)
936 : : end if ! end usepaw section
937 : :
938 : : ! ######################################################################
939 : : ! The following steps are done only when nstep>0
940 : : ! ----------------------------------------------------------------------
941 : :
942 [ + + + - ]: 18756 : if(iscf_mod>0.and.nstep>0)then
943 : 15026 : write(msg, '(a,a,i4)' )ch10,' ITER STEP NUMBER ',istep
944 : 15026 : call wrtout(std_out,msg,'COLL')
945 : : end if
946 : :
947 : : ! Update vtrial1_mq
948 [ + + + + ]: 18756 : if (nstep>1.and..not.kramers_deg) then
949 : 80 : call dfpt_vtrial1_mq(cplex,nfftf,dtset%nspden,nvresid1,nvresid1_mq,vtrial1,vtrial1_mq)
950 : : end if
951 : :
952 : : ! For Q=0 and metallic occupation, calculate the first-order Fermi energy
953 [ + + ]: 18756 : if (need_fermie1) then
954 : : call newfermie1(cplex,fermie1,fe1fixed,ipert,istep,dtset%ixc,my_natom,dtset%natom,&
955 : : & nfftf,nfftotf,nhatfermi,nspden,dtset%ntypat,dtset%occopt,paw_an,paw_an1,paw_ij1,pawang,&
956 : : & dtset%pawnzlm,pawrad,pawrhoij1,pawrhoijfermi,pawtab,dtset%pawxcdev,&
957 : : & dtset%prtvol,rhorfermi,ucvol,psps%usepaw,usexcnhat,vtrial1,vxc1,dtset%xclevel,&
958 : 1678 : & mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom)
959 [ - + ]: 1678 : if (.not.kramers_deg) then
960 : : !fermie1_mq is updated as well at "-q"
961 : : call newfermie1(cplex,fermie1_mq,fe1fixed_mq,ipert,istep,dtset%ixc,my_natom,dtset%natom,&
962 : : & nfftf,nfftotf,nhatfermi,nspden,dtset%ntypat,dtset%occopt,paw_an,paw_an1,paw_ij1,pawang,&
963 : : & dtset%pawnzlm,pawrad,pawrhoij1,pawrhoijfermi,pawtab,dtset%pawxcdev,&
964 : : & dtset%prtvol,rhorfermi_mq,ucvol,psps%usepaw,usexcnhat,vtrial1_mq,vxc1,dtset%xclevel,&
965 : 0 : & mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom)
966 : : end if
967 : : end if
968 : :
969 : : ! No need to continue and call dfpt_vtorho, when nstep==0
970 [ + - ]: 18756 : if(nstep==0) exit
971 : :
972 : :
973 : : ! #######################e1magh###############################################
974 : : ! Compute the 1st-order density rho1 from the 1st-order trial potential
975 : : ! ----------------------------------------------------------------------
976 : : call dfpt_vtorho(cg,cgq,cg1,cg1_active,cplex,cprj,cprjq,cprj1,&
977 : : & dbl_nnsclo,dim_eig2rf,doccde_rbz,docckqde,dtefield,dtfil,dtset,dtset%qptn,edocc,&
978 : : & eeig0,eigenq,eigen0,eigen1,ek0,ek1,eloc0,end0,end1,enl0,enl1,evxctau0,evxctau1,&
979 : : & fermie1,gh0c1_set,gh1c_set,&
980 : : & gmet,gprimd,idir,indsy1,ipert,irrzon1,istwfk_rbz,kg,kg1,kpt_rbz,dtset%mband,mband_mem_rbz,&
981 : : & mkmem,mkqmem,mk1mem,mpi_enreg,mpw,mpw1,my_natom,dtset%natom,nband_rbz,ncpgr,nfftf,&
982 : : & nhat1,nkpt_rbz,npwarr,npwar1,res2,nspden,dtset%nsppol,nsym1,dtset%ntypat,nvresid1,&
983 : : & occkq,occ_rbz,optres,paw_ij,paw_ij1,pawang,pawang1,pawfgr,pawfgrtab,pawrhoij,&
984 : : & pawrhoij1,pawtab,phnons1,ph1d,dtset%prtvol,psps,pwindall,qmat,resid,residm,rhog1,&
985 : : & rhor1,rmet,rprimd,symaf1,symrc1,symrl1,tnons1,ucvol,usecprj,useylmgr1,usevxctau,ddk_f,&
986 : : & vectornd,vtrial,vtrial1,vxctau,with_vectornd,wtk_rbz,xred,ylm,ylm1,ylmgr1,&
987 : 18756 : & eta=eta,omega=omega) !optional arguments for finite-w calculation
988 : :
989 [ + + ]: 18756 : if (.not.kramers_deg) then
990 [ + + + + ]: 4743568 : rhor1_pq(:,:)=rhor1(:,:) !at this stage rhor1_pq contains only one term of the 1st order density at +q
991 [ + + + + ]: 1778768 : rhog1_pq(:,:)=rhog1(:,:) !same for rhog1_pq
992 : :
993 : : !get the second term related to 1st order wf at -q
994 : : call dfpt_vtorho(cg,cg_mq,cg1_mq,cg1_active_mq,cplex,cprj,cprjq,cprj1,&
995 : : & dbl_nnsclo_mq,dim_eig2rf,doccde_rbz,docckde_mq,dtefield,dtfil,dtset,-dtset%qptn,edocc_mq,&
996 : : & eeig0_mq,eigen_mq,eigen0,eigen1_mq,ek0_mq,ek1_mq,eloc0_mq,end0_mq,end1_mq,&
997 : : & enl0_mq,enl1_mq,evxctau0_mq,evxctau1_mq,fermie1_mq,gh0c1_set_mq,gh1c_set_mq,&
998 : : & gmet,gprimd,idir,indsy1,ipert,irrzon1,istwfk_rbz,kg,kg1_mq,kpt_rbz,dtset%mband,mband_mem_rbz,&
999 : : & mkmem,mkqmem,mk1mem,mpi_enreg,mpw,mpw1_mq,my_natom,dtset%natom,nband_rbz,ncpgr,nfftf,&
1000 : : & nhat1,nkpt_rbz,npwarr,npwar1_mq,res2_mq,nspden,dtset%nsppol,nsym1,dtset%ntypat,nvresid1_mq,&
1001 : : & occk_mq,occ_rbz,optres,paw_ij,paw_ij1,pawang,pawang1,pawfgr,pawfgrtab,pawrhoij,&
1002 : : & pawrhoij1,pawtab,phnons1,ph1d,dtset%prtvol,psps,pwindall,qmat,resid_mq,residm_mq,rhog1_mq,&
1003 : : & rhor1_mq,rmet,rprimd,symaf1,symrc1,symrl1,tnons1,ucvol,usecprj,useylmgr1,usevxctau,ddk_f,&
1004 : : & vectornd,vtrial,vtrial1_mq,vxctau,with_vectornd,wtk_rbz,xred,ylm,ylm1_mq,ylmgr1_mq,&
1005 [ + + ]: 320 : & eta=eta,omega=omega_mq) !optional arguments for finite-w calculation
1006 : :
1007 : : !reconstruct the total density from the resonant (+q,+w) and antiresonant (-q,-w) ones.
1008 [ + + ]: 592976 : do ifft=1,nfftf
1009 [ + + ]: 2964480 : rhor1(2*ifft-1,:) = half*(rhor1_pq(2*ifft-1,:)+rhor1_mq(2*ifft-1,:))
1010 [ + + ]: 2964560 : rhor1(2*ifft ,:) = half*(rhor1_pq(2*ifft ,:)-rhor1_mq(2*ifft ,:))
1011 : : end do
1012 : 80 : call fourdp(cplex,rhog1,rhor1(:,1),-1,mpi_enreg,nfftf,1, ngfftf, 0)
1013 : :
1014 : : end if
1015 : :
1016 : :
1017 : : if (dtset%berryopt== 4.or.dtset%berryopt== 6.or.dtset%berryopt== 7.or.&
1018 [ + + ]: 18756 : & dtset%berryopt==14.or.dtset%berryopt==16.or.dtset%berryopt==17) then
1019 : :
1020 : : ! calculate \Omega E \cdot P term
1021 [ + + ]: 97 : if (ipert<=dtset%natom) then
1022 : : ! phonon perturbation
1023 : : call dfptff_ebp(cg,cg1,dtefield,eberry,dtset%mband,mband_mem_rbz,mkmem,&
1024 : 61 : & mpi_enreg,mpw,mpw1,nkpt,npwarr,npwar1,dtset%nsppol,dtset%nspinor,pwindall,qmat)
1025 [ + - ]: 36 : else if (ipert==dtset%natom+2) then
1026 : : ! electric field perturbation
1027 : : call dfptff_edie(cg,cg1,dtefield,eberry,idir,dtset%mband,mband_mem_rbz,mkmem,&
1028 : 36 : & mpi_enreg,mpw,mpw1,nkpt,npwarr,npwar1,dtset%nsppol,dtset%nspinor,pwindall,qmat,rprimd)
1029 : : end if
1030 : : end if
1031 : :
1032 : : ! SPr: don't remove the following comments for debugging
1033 : : ! call calcdenmagsph(mpi_enreg,dtset%natom,nfftf,ngfftf,nspden,&
1034 : : !& dtset%ntypat,dtset%ratsm,dtset%ratsph,rhor1,rprimd,dtset%typat,xred,&
1035 : : !& idir+1,cplex,intgden=intgden,rhomag=rhomag)
1036 : : ! call prtdenmagsph(cplex,intgden,dtset%natom,nspden,dtset%ntypat,[ab_out],idir+1,dtset%ratsm,dtset%ratsph,rhomag,dtset%typat)
1037 : :
1038 : : ! write(*,*) ' n ( 1,2)',intgden(1,1),' ',intgden(1,2)
1039 : : ! write(*,*) ' mx( 1,2)',intgden(2,1),' ',intgden(2,2)
1040 : : ! write(*,*) ' my( 1,2)',intgden(3,1),' ',intgden(3,2)
1041 : : ! write(*,*) ' mz( 1,2)',intgden(4,1),' ',intgden(4,2)
1042 : : ! call dfpt_etot(dtset%berryopt,deltae,eberry,edocc,eeig0,eew,efrhar,efrkin,&
1043 : : !& efrloc,efrnl,efrx1,efrx2,ehart1,ek0,ek1,eii,elast,eloc0,elpsp1,&
1044 : : !& enl0,enl1,epaw1,etotal,evar,evdw,exc1,elmag1,ipert,dtset%natom,optene)
1045 : : ! write(*,*) 'SPr: ek1=',ek1,' exc1=',exc1,' elmag1=',elmag
1046 : : ! if (ipert==dtset%natom+5) then
1047 : : ! !calculate 1st order magnetic potential contribution to the energy
1048 : : ! call dfpt_e1mag(e1mag,rhor1,rhog1);
1049 : : ! endif
1050 : :
1051 : : ! ######################################################################
1052 : : ! Skip out of step loop if non-SCF (completed)
1053 : : ! ----------------------------------------------------------------------
1054 : :
1055 : : ! Indeed, nstep loops have been done inside dfpt_vtorho
1056 [ + + ]: 18756 : if (iscf_mod<=0 .and. iscf_mod/=-3) exit
1057 : :
1058 : : ! ######################################################################
1059 : : ! In case of density mixing , compute the total 2nd-order energy,
1060 : : ! check the exit criterion, then mix the 1st-order density
1061 : : ! ----------------------------------------------------------------------
1062 : :
1063 : : ! For tim1rev=0 we need to compute the SCF energies from the physically
1064 : : ! meaningful first-order density
1065 [ + + + + : 18632 : if (.not.kramers_deg.and.(ipert<dtset%natom+10.or.(ipert>dtset%natom+11.and.ipert<=2*dtset%natom+11))) then
+ - + - ]
1066 : 80 : optene=1
1067 : : call dfpt_rhotov(cplex,ehart01,ehart1,elmag1,elpsp1,emagpen1,exc1,gsqcut,dtset%icutcoul,idir,ipert,&
1068 : : & dtset%ixc,kxc,dtset%magpen,dtset%mpatpol,dtset%mpdir,mpi_enreg,dtset%natom,nfftf,ngfftf,nhat,nhat1,nhat1gr,nhat1grdim,nkxc,&
1069 : : & nspden,dtset%ntypat,n3xccc,nmxc,optene,optres,dtset%qptn,dtset%ratsm,dtset%ratsph,rhog,rhog1,rhor,rhor1,&
1070 : : & rprimd,dtset%typat,ucvol,psps%usepaw,usexcnhat,dtset%vcutgeo,vhartr1,vpsp1,nvresid1,res2,vtrial1,&
1071 : 80 : & vxc,vxc1,xccc3d1,dtset%ixcrot,xred,dtset%qgbt,dtset%use_gbt)
1072 : : end if
1073 : :
1074 [ - + ]: 18632 : if (iscf_mod>=10) then
1075 : 0 : optene = 0
1076 : : call dfpt_etot(dtset%berryopt,deltae,eberry,edocc,eeig0,eew,efrhar,efrkin,&
1077 : : & efrloc,efrnl,efrx1,efrx2,ehart1,ek0,ek1,eii,elast,elmag1,eloc0,elpsp1,emagpen1,&
1078 : 0 : & end0,end1,enl0,enl1,epaw1,etotal,evar,evdw,evxctau0,evxctau1,exc1,ipert,dtset%natom,optene)
1079 : 0 : call timab(152,1,tsec)
1080 [ # # ]: 0 : if(.not.kramers_deg) then
1081 : : call dfpt_etot(dtset%berryopt,deltae_mq,eberry_mq,edocc_mq,eeig0_mq,eew,efrhar,efrkin,&
1082 : : & efrloc,efrnl,efrx1,efrx2,ehart1,ek0_mq,ek1_mq,eii,elast_mq,elmag1,eloc0_mq,elpsp1,emagpen1,&
1083 : 0 : & end0_mq,end1_mq,enl0_mq,enl1_mq,epaw1_mq,etotal_mq,evar_mq,evdw,evxctau0,evxctau1,exc1,ipert,dtset%natom,optene)
1084 : :
1085 : : call dfpt_etot_avg_mq(deltae,deltae_mq,edocc,edocc_mq,eeig0,eeig0_mq,ek0,ek0_mq,ek1,ek1_mq,&
1086 : : & eloc0,eloc0_mq,end0,end0_mq,end1,end1_mq,enl0,enl0_mq,enl1,enl1_mq,epaw1,epaw1_mq,&
1087 : 0 : & etotal,etotal_mq,evar,evar_mq)
1088 : : end if
1089 : :
1090 : 0 : choice=2
1091 [ # # # # ]: 0 : if((iscf_mod>0).and.(dtset%nsppol==2.or.dtset%nspden>1)) then
1092 [ # # # # : 0 : intgden0=intgden
# # ]
1093 : : call calcdenmagsph(mpi_enreg,dtset%natom,nfftf,ngfftf,nspden,&
1094 : : & dtset%ntypat,dtset%ratsm,dtset%ratsph,rhor1,rprimd,dtset%typat,xred,&
1095 : 0 : & prtopt,cplex,dtset%qgbt,dtset%use_gbt,intgden=intgden,dentot=dentot,rhomag=rhomag)
1096 : 0 : call calmaxdifmag(cplex,intgden,intgden0,dtset%natom,dtset%nspden,maxmag,difmag)
1097 : : endif
1098 : : call scprqt(choice,cpus,deltae,diffor,maxmag,difmag,dtset,eigen0,&
1099 : : & etotal,favg,fcart,fermie,fermie,dtfil%fnametmp_eig,dtfil%filnam_ds(1),&
1100 : : & 1,iscf_mod,istep,istep_fock_outer,istep_mix,kpt_rbz,maxfor,&
1101 : : & mvdum,mpi_enreg,nband_rbz,nkpt_rbz,&
1102 : : & nstep,occ_rbz,0,prtfor,0,&
1103 : : & quit,res2,resid,residm,response,&
1104 : 0 : & tollist,psps%usepaw,vxcavg,wtk_rbz,xred,conv_retcode)
1105 : 0 : call timab(152,2,tsec)
1106 : :
1107 [ # # ]: 0 : if (istep==nstep) quit=1
1108 : : ! If criteria in scprqt say to quit, then exit the loop over istep
1109 : 0 : quit_sum=quit
1110 : 0 : call xmpi_sum(quit_sum,spaceComm,ierr)
1111 : :
1112 [ # # ]: 0 : if (quit_sum>0) exit
1113 : : ! INSERT HERE CALL TO NEWRHO3 : to be implemented
1114 [ # # ]: 0 : if (psps%usepaw==1) then
1115 : 0 : ABI_BUG("newrho3 not implemented: use potential mixing!")
1116 : : end if
1117 : 0 : initialized=1
1118 : : end if
1119 : :
1120 : : ! ######################################################################
1121 : : ! Compute the new 1st-order potential from the 1st-order density
1122 : : ! ----------------------------------------------------------------------
1123 : :
1124 [ + + + + : 18632 : if (kramers_deg.and.(ipert<dtset%natom+10.or.(ipert>dtset%natom+11.and.ipert<=2*dtset%natom+11))) then
+ + + - ]
1125 : 18373 : optene=1
1126 : : call dfpt_rhotov(cplex,ehart01,ehart1,elmag1,elpsp1,emagpen1,exc1,gsqcut,dtset%icutcoul,idir,ipert,&
1127 : : & dtset%ixc,kxc,dtset%magpen,dtset%mpatpol,dtset%mpdir,mpi_enreg,dtset%natom,nfftf,ngfftf,nhat,nhat1,nhat1gr,nhat1grdim,nkxc,&
1128 : : & nspden,dtset%ntypat,n3xccc,nmxc,optene,optres,dtset%qptn,dtset%ratsm,dtset%ratsph,rhog,rhog1,rhor,rhor1,&
1129 : : & rprimd,dtset%typat,ucvol,psps%usepaw,usexcnhat,dtset%vcutgeo,vhartr1,vpsp1,nvresid1,res2,vtrial1,vxc,vxc1,xccc3d1,dtset%ixcrot,xred,&
1130 : 18373 : & dtset%qgbt,dtset%use_gbt)
1131 : : end if
1132 : :
1133 [ + + - + ]: 18632 : if (ipert/=dtset%natom+1.and.dtset%prt1mag==2) then
1134 : 0 : prtopt=1
1135 : : call calcdenmagsph(mpi_enreg,dtset%natom,nfftf,ngfftf,nspden,&
1136 : : & dtset%ntypat,dtset%ratsm,dtset%ratsph,rhor1,rprimd,dtset%typat,xred,&
1137 : : & prtopt,cplex,dtset%qgbt,dtset%use_gbt,intgden=intgden,dentot=dentot,rhomag=rhomag,&
1138 : 0 : & qphon=qphon)
1139 : : end if
1140 : :
1141 : : ! ######################################################################
1142 : : ! In case of potential mixing , compute the total 2nd-order energy,
1143 : : ! check the exit criterion, then mix the 1st-order potential
1144 : : ! ----------------------------------------------------------------------
1145 : :
1146 [ - + ]: 20986 : if (iscf_mod<10) then
1147 : :
1148 : : ! PAW: has to compute here the "on-site" 2nd-order energy
1149 [ + + ]: 18632 : if (psps%usepaw==1) then
1150 [ + + + - ]: 3568 : nzlmopt=0;if (istep==1.and.dtset%pawnzlm>0) nzlmopt=-1
1151 [ + + ]: 3568 : if (istep>1) nzlmopt=dtset%pawnzlm
1152 : 3568 : call paw_an_reset_flags(paw_an1) ! Force the recomputation of on-site potentials
1153 : 3568 : option=2
1154 : : call pawdenpot(dum,el_temp,gprimd,ipert,dtset%ixc,my_natom,dtset%natom,dtset%nspden,&
1155 : : & psps%ntypat,dtset%nucdipmom,nzlmopt,option,paw_an1,paw_an,paw1_energies,&
1156 : : & paw_ij1,pawang,dtset%pawprtvol,pawrad,pawrhoij1,dtset%pawspnorb,pawtab,&
1157 : : & dtset%pawxcdev,dtset%spnorbscl,dtset%xclevel,dtset%xc_denpos,dtset%xc_taupos,xred,&
1158 : 3568 : & ucvol,psps%znuclpsp,dtset%spinaxis,mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom)
1159 : 3568 : epaw1=paw1_energies%epaw
1160 : : end if
1161 : :
1162 : 18632 : optene = 0 ! use direct scheme
1163 : : call dfpt_etot(dtset%berryopt,deltae,eberry,edocc,eeig0,eew,efrhar,efrkin,&
1164 : : & efrloc,efrnl,efrx1,efrx2,ehart1,ek0,ek1,eii,elast,elmag1,eloc0,elpsp1,emagpen1,&
1165 : 18632 : & end0,end1,enl0,enl1,epaw1,etotal,evar,evdw,evxctau0,evxctau1,exc1,ipert,dtset%natom,optene)
1166 : : !& enl0,enl1,epaw1,etotal,evar,evdw,exc1,elmag1,ipert,dtset%natom,optene)
1167 : : ! !debug: compute the d2E/d-qd+q energy, should be equal to the one from previous line
1168 [ + + ]: 18632 : if(.not.kramers_deg) then
1169 : : call dfpt_etot(dtset%berryopt,deltae_mq,eberry_mq,edocc_mq,eeig0_mq,eew,efrhar,efrkin,&
1170 : : & efrloc,efrnl,efrx1,efrx2,ehart1,ek0_mq,ek1_mq,eii,elast_mq,elmag1,eloc0_mq,elpsp1,emagpen1,&
1171 : 80 : & end0_mq,end1_mq,enl0_mq,enl1_mq,epaw1_mq,etotal_mq,evar_mq,evdw,evxctau0,evxctau1,exc1,ipert,dtset%natom,optene)
1172 : :
1173 : : call dfpt_etot_avg_mq(deltae,deltae_mq,edocc,edocc_mq,eeig0,eeig0_mq,ek0,ek0_mq,ek1,ek1_mq,&
1174 : : & eloc0,eloc0_mq,end0,end0_mq,end1,end1_mq,enl0,enl0_mq,enl1,enl1_mq,epaw1,epaw1_mq,&
1175 : 80 : & etotal,etotal_mq,evar,evar_mq)
1176 : : end if
1177 : :
1178 : 18632 : call timab(152,1,tsec)
1179 : 18632 : choice=2
1180 : : ! To take into account new definition of hdr_update;
1181 : : ! test to avoid dfpt and occopt 9 was already done
1182 : : ! so we can just set fermih = fermie
1183 [ + + + + : 18632 : if((iscf_mod>0).and.(dtset%nsppol==2.or.dtset%nspden>1)) then
+ + ]
1184 [ + + + + : 22148 : intgden0=intgden
+ + ]
1185 : : call calcdenmagsph(mpi_enreg,dtset%natom,nfftf,ngfftf,nspden,&
1186 : : & dtset%ntypat,dtset%ratsm,dtset%ratsph,rhor1,rprimd,dtset%typat,xred,&
1187 : 1568 : & prtopt,cplex,dtset%qgbt,dtset%use_gbt,intgden=intgden,dentot=dentot,rhomag=rhomag)
1188 : 1568 : call calmaxdifmag(cplex,intgden,intgden0,dtset%natom,dtset%nspden,maxmag,difmag)
1189 : : endif
1190 : : call scprqt(choice,cpus,deltae,diffor,maxmag,difmag,dtset,eigen0,&
1191 : : & etotal,favg,fcart,fermie,fermie,dtfil%fnametmp_eig,dtfil%filnam_ds(1),&
1192 : : & 1,iscf_mod,istep,istep_fock_outer,istep_mix,kpt_rbz,maxfor,&
1193 : : & mvdum,mpi_enreg,nband_rbz,nkpt_rbz,&
1194 : : & nstep,occ_rbz,0,prtfor,0,&
1195 : : & quit,res2,resid,residm,response,&
1196 : 18632 : & tollist,psps%usepaw,vxcavg,wtk_rbz,xred,conv_retcode)
1197 : : ! endif
1198 : 18632 : call timab(152,2,tsec)
1199 : :
1200 : : ! If criteria in scprqt say to quit, then exit the loop over istep
1201 : 18632 : quit_sum=quit
1202 : 18632 : call xmpi_sum(quit_sum,spaceComm,ierr)
1203 [ + + ]: 18632 : if (quit_sum>0) exit
1204 : :
1205 : : ! TODO
1206 : : ! Better error handling is the SCF cycle goes bananas:
1207 : : ! Write a BIG warning in the output file and save the wavefunctions.
1208 : : ! so that we can restart.
1209 [ + + ]: 16582 : if(iscf_mod/=-3)then
1210 : : ! Note that nvresid1 and vtrial1 are called vresid and vtrial inside this routine
1211 : : call dfpt_newvtr(cplex,dbl_nnsclo,dielar,dtset,etotal,pawfgr%fintocoa,&
1212 : : & initialized,iscf_mod,ispmix,istep,mix,pawfgr%coatofin,&
1213 : : & mpi_enreg,my_natom,nfftf,nfftmix,ngfftf,ngfftmix,npawmix,pawrhoij1,&
1214 [ + - - - : 13541 : & qphon,rhor1,rprimd,psps%usepaw,nvresid1,vtrial1)
- - + - -
- - - - +
- + ]
1215 : 13541 : initialized=1
1216 : : end if
1217 : : end if
1218 : :
1219 : : ! ######################################################################
1220 : : ! END MINIMIZATION ITERATIONS
1221 : : ! Note that there are different "exit" instructions within the loop
1222 : : ! ######################################################################
1223 : : end do ! istep
1224 : : ABI_NVTX_END_RANGE()
1225 : :
1226 : : ! Avoid pending requests if itime == ntime.
1227 : 2354 : call xmpi_wait(quitsum_request,ierr)
1228 [ - + ]: 2354 : if (timelimit_exit == 1) istep = istep - 1
1229 : :
1230 : : !SP : Here read the _DDB file and extract the Born effective charge and
1231 : : ! dielectric constant.
1232 : : ! The idea is to supress the divergence due to a residual Born effective charge
1233 : : ! by renormalizing the v_hart1. For this, the difference between the ionic
1234 : : ! Z_kappa and the Born effective charge divided by the dielectric constant is used.
1235 : : ! ---------------------------------------------------------------------------------
1236 [ + + + + : 2354 : if ((dtset%getddb .ne. 0 .or. dtset%irdddb .ne.0) .and. qzero .ne. 1) then
+ - ]
1237 [ - + + - : 48 : ABI_MALLOC(rhor2,(cplex*nfftf,nspden))
- + + - +
- + - - +
- + ]
1238 [ - + + - : 36 : ABI_MALLOC(resid2,(dtset%mband*nkpt_rbz*nspden))
+ - + - -
+ - + ]
1239 [ - + + - : 36 : ABI_MALLOC(rhog2,(2,nfftf))
+ - + - -
+ - + ]
1240 [ - + + - : 36 : ABI_MALLOC(vtrial2,(cplex*nfftf,nspden))
- + + - -
+ - + ]
1241 : :
1242 : 12 : Z_kappa = nint(psps%ziontypat(dtset%typat(ipert))) ! Charge ionic from the psp
1243 [ + + + + ]: 156 : qred2cart = two_pi*gprimd
1244 [ + + + + ]: 156 : q_cart = MATMUL(qred2cart,qphon)
1245 [ + + + + ]: 84 : q_cart = q_cart/SQRT(dot_product(q_cart,q_cart))
1246 [ + + + + : 192 : diel_q = dot_product(MATMUL(dielt,q_cart),q_cart)
+ + ]
1247 [ + + + + : 372 : zeff_bar = SUM(zeff(:,:,:),DIM=3)/dtset%natom
+ + ]
1248 [ + + + + : 192 : zeff_red = MATMUL(zeff_bar(:,:),rprimd(:,idir))/two_pi
+ + ]
1249 : : qphon_norm = SQRT(dot_product(qphon,qphon))
1250 [ + + + + ]: 156 : q_cart = MATMUL(qred2cart,qphon)
1251 [ + + ]: 48 : born_bar = dot_product(q_cart,zeff_red(:))
1252 [ + + + + : 192 : zeff_red = MATMUL(zeff(:,:,ipert),rprimd(:,idir))/two_pi
+ + ]
1253 [ + + ]: 48 : born = dot_product(q_cart,zeff_red(:))
1254 : :
1255 : : ! To avoid problem of divergence (0/0) we add a small value to qphon
1256 [ + + ]: 48 : qphon2 = qphon + tol6
1257 : 12 : renorm = (1-(qphon2(idir)*Z_kappa-(born-born_bar)/diel_q)/(qphon2(idir)*Z_kappa-born/diel_q))
1258 : :
1259 [ + + ]: 81012 : vtrial2(:,1) = vtrial1(:,1) -renorm*vhartr1
1260 : :
1261 : : call dfpt_vtorho(cg,cgq,cg1,cg1_active,cplex,cprj,cprjq,cprj1,&
1262 : : & dbl_nnsclo,dim_eig2rf,doccde_rbz,docckqde,dtefield,dtfil,dtset,dtset%qptn,edocc,&
1263 : : & eeig0,eigenq,eigen0,eigen1,ek0,ek1,eloc0,end0,end1,enl0,enl1,evxctau0,evxctau1,&
1264 : : & fermie1,gh0c1_set,gh1c_set,&
1265 : : & gmet,gprimd,idir,indsy1,ipert,irrzon1,istwfk_rbz,kg,kg1,kpt_rbz,dtset%mband,mband_mem_rbz,&
1266 : : & mkmem,mkqmem,mk1mem,mpi_enreg,mpw,mpw1,my_natom,dtset%natom,nband_rbz,ncpgr,nfftf,&
1267 : : & nhat1,nkpt_rbz,npwarr,npwar1,res3,nspden,dtset%nsppol,nsym1,dtset%ntypat,nvresid2,&
1268 : : & occkq,occ_rbz,optres,paw_ij,paw_ij1,pawang,pawang1,pawfgr,pawfgrtab,pawrhoij,&
1269 : : & pawrhoij1,pawtab,phnons1,ph1d,dtset%prtvol,psps,pwindall,qmat,resid2,residm2,rhog2,&
1270 : : & rhor2,rmet,rprimd,symaf1,symrc1,symrl1,tnons1,ucvol,usecprj,useylmgr1,usevxctau,ddk_f,&
1271 : 12 : & vectornd,vtrial,vtrial2,vxctau,with_vectornd,wtk_rbz,xred,ylm,ylm1,ylmgr1,1)
1272 : :
1273 : : write(msg,'(a)') ' '//char(10)//&
1274 : 12 : ' ---------------------------------'
1275 : 12 : call wrtout(ab_out,msg,'COLL')
1276 : : write(msg,'(a,a)')' The charge sum rule is activated'//char(10)//&
1277 : 12 : ' ---------------------------------'
1278 : 12 : call wrtout(ab_out,msg,'COLL')
1279 : 12 : write(msg,'(a,i4)') ' Z_ion (psp):',Z_kappa
1280 : 12 : call wrtout(ab_out,msg,'COLL')
1281 : 12 : write(msg,'(a,f12.8)') ' Residual Born effective charge: ',born
1282 : 12 : call wrtout(ab_out,msg,'COLL')
1283 : 12 : write(msg,'(a,f12.8)') ' Renormalisation: ',renorm
1284 : 12 : call wrtout(ab_out,msg,'COLL')
1285 [ + + ]: 12 : if (renorm > 0.01 ) then
1286 : : write(msg,'(a,a)')' WARNING: The renormalisation seems large (> 0.01).'//char(10)//&
1287 : 4 : ' You might consider increasing the k-point grid.'
1288 : 4 : ABI_WARNING(msg)
1289 : 4 : call wrtout(ab_out,msg,'COLL')
1290 : : end if
1291 : 12 : write(msg,'(a)') ' '
1292 : 12 : call wrtout(ab_out,msg,'COLL')
1293 : :
1294 [ - + ]: 12 : ABI_FREE(nvresid2)
1295 [ - + ]: 12 : ABI_FREE(rhor2)
1296 [ - + ]: 12 : ABI_FREE(resid2)
1297 [ - + ]: 12 : ABI_FREE(rhog2)
1298 [ - + ]: 12 : ABI_FREE(vtrial2)
1299 : : end if
1300 : :
1301 [ + + ]: 2354 : if (iscf_mod>0.or.iscf_mod==-3) then
1302 [ - + ]: 2230 : ABI_FREE(nvresid1)
1303 [ + + ]: 2230 : if (.not.kramers_deg) then
1304 [ - + ]: 11 : ABI_FREE(nvresid1_mq)
1305 : : end if
1306 : : end if
1307 : :
1308 : : !######################################################################
1309 : : !Additional steps after SC iterations
1310 : : !----------------------------------------------------------------------
1311 : :
1312 : 2354 : call timab(160,1,tsec)
1313 : :
1314 : : !Compute Dynamic magnetic charges (dmc) in case of rfphon,
1315 : : !and magnetic susceptibility in case of rfmagn from first order density
1316 : : !(results to be comapred to dmc from d2e)
1317 : : !SPr deb
1318 : : !if (ipert<=dtset%natom.and.dtset%nspden>=2) then
1319 : : !
1320 : : ! mpi_comm_sphgrid=mpi_enreg%comm_fft
1321 : : ! call mean_fftr(rhor1(:,1),mean_rhor1,nfftf,nfftotf,1,mpi_comm_sphgrid)
1322 : : ! write(*,*) ' Mean 1st order density: ', mean_rhor1
1323 : : ! call mean_fftr(rhor1(:,2),mean_rhor1,nfftf,nfftotf,1,mpi_comm_sphgrid)
1324 : : ! if (dtset%nspden==2) then
1325 : : ! write(*,*) ' 1st order m_z : ', mean_rhor1
1326 : : ! else !nspden==4
1327 : : ! write(*,*) ' 1st order m_x : ', mean_rhor1
1328 : : ! call mean_fftr(rhor1(:,3),mean_rhor1,nfftf,nfftotf,1,mpi_comm_sphgrid)
1329 : : ! write(*,*) ' 1st order m_y : ', mean_rhor1
1330 : : ! call mean_fftr(rhor1(:,4),mean_rhor1,nfftf,nfftotf,1,mpi_comm_sphgrid)
1331 : : ! write(*,*) ' 1st order m_z : ', mean_rhor1
1332 : : ! endif
1333 : : !
1334 : : !endif
1335 : :
1336 : :
1337 : : !Eventually close the DDK file, before calling dfpt_nstdy
1338 : : if ((ipert==dtset%natom+2.and.sum((dtset%qptn(1:3))**2)<=1.0d-7.and.&
1339 : : & (dtset%berryopt/=4 .and.dtset%berryopt/= 6.and.dtset%berryopt/= 7.and.&
1340 : : & dtset%berryopt/=14.and.dtset%berryopt/=16.and.dtset%berryopt/=17)).or.&
1341 [ + + + + : 9416 : & ipert==dtset%natom+10.or.ipert==dtset%natom+11) then
+ - + + +
+ + + ]
1342 : 370 : call ddk_f(1)%close()
1343 : : end if
1344 [ + + + + : 2354 : if ((ipert==dtset%natom+10 .and. idir>3) .or. ipert==dtset%natom+11) then
+ + ]
1345 : 130 : call ddk_f(2)%close()
1346 : : end if
1347 [ + + ]: 2354 : if (ipert==dtset%natom+11) then
1348 : 48 : call ddk_f(3)%close()
1349 [ + + ]: 48 : if(idir>3) call ddk_f(4)%close()
1350 : : end if
1351 : :
1352 : : !Deallocate the no more needed arrays
1353 [ + + + - ]: 2354 : if (iscf_mod>0.and.nstep>0) then
1354 : 1600 : call abi_mixing_deallocate(mix)
1355 : : end if
1356 [ + - + + : 2354 : if( (nstep>0 .and. iscf_mod>0) .or. iscf_mod==-1 ) then
- + ]
1357 [ - + ]: 1600 : ABI_FREE(dielinv)
1358 [ - + ]: 1600 : ABI_FREE(susmat)
1359 : : end if
1360 [ + + ]: 2354 : ABI_SFREE(rhorfermi)
1361 [ - + ]: 2354 : ABI_SFREE(rhorfermi_mq)
1362 [ + + ]: 2354 : ABI_SFREE(nhatfermi)
1363 [ + + ]: 2354 : if(allocated(pawrhoijfermi)) then
1364 : 192 : call pawrhoij_free(pawrhoijfermi)
1365 [ + - + + : 448 : ABI_FREE(pawrhoijfermi)
- + - + -
+ - + - +
- + - + ]
1366 : : end if
1367 [ + + ]: 2354 : if(psps%usepaw==1) then
1368 [ + - + - ]: 409 : if (mk1mem/=0.and.usecprj==1) then
1369 : 409 : call pawcprj_free(cprj1)
1370 : : end if
1371 [ + + ]: 1193 : do iatom=1,my_natom
1372 [ + + ]: 784 : if (pawfgrtab(iatom)%nhatfr_allocated>0) then
1373 [ - + ]: 377 : ABI_FREE(pawfgrtab(iatom)%nhatfr)
1374 : : end if
1375 : 1193 : pawfgrtab(iatom)%nhatfr_allocated=0
1376 : : end do
1377 [ + - + + ]: 409 : if (nstep>0.and.iscf_mod>0) then
1378 [ + + ]: 653 : do iatom=1,my_natom
1379 : 435 : pawrhoij1(iatom)%lmnmix_sz=0
1380 : 435 : pawrhoij1(iatom)%use_rhoijres=0
1381 [ - + ]: 435 : ABI_FREE(pawrhoij1(iatom)%kpawmix)
1382 [ - + ]: 653 : ABI_FREE(pawrhoij1(iatom)%rhoijres)
1383 : : end do
1384 : : end if
1385 : : end if ! PAW
1386 [ + - + + : 161230 : ABI_FREE(cprj1)
- + - + -
+ ]
1387 [ - + ]: 2354 : ABI_FREE(nhat1gr)
1388 : :
1389 : 2354 : call timab(160,2,tsec)
1390 : 2354 : call timab(150,1,tsec)
1391 : :
1392 [ + + + - : 2354 : if (psps%usepaw==0.and.dtset%userie/=919.and. &
+ + + + ]
1393 : : & (ipert==dtset%natom+3.or.ipert==dtset%natom+4)) then
1394 [ - + - - ]: 96 : if (.not.kramers_deg.and.abs(omega)>tol7) then
1395 : 0 : ABI_ERROR('Finte-omega calculations not yet implemented for rfstrs')
1396 : : end if
1397 : : call dfpt_nselt(blkflg,cg,cg1,cplex,&
1398 : : & d2bbb,d2lo,d2nl,ecut,dtset%ecutsm,dtset%effmass_free,&
1399 : : & gmet,gprimd,gsqcut,idir,&
1400 : : & ipert,istwfk_rbz,kg,kg1,kpt_rbz,kxc,dtset%mband,mband_mem_rbz,mgfftf,&
1401 : : & mkmem,mk1mem,mpert,mpi_enreg,psps%mpsang,mpw,mpw1,&
1402 : : & dtset%natom,nband_rbz,nfftf,ngfftf,&
1403 : : & nkpt_rbz,nkxc,dtset%nloalg,&
1404 : : & npwarr,npwar1,nspden,dtset%nspinor,dtset%nsppol,&
1405 : : & nsym1,dtset%ntypat,occ_rbz,&
1406 : : & ph1d,dtset%prtbbb,psps,dtset%qptn,rhog,&
1407 : : & rhor,rhor1,rmet,rprimd,symrc1,dtset%typat,ucvol,&
1408 : : & wtk_rbz,xred,ylm,ylm1,ylmgr,ylmgr1,&
1409 : 96 : & rfstrs_ref=dtset%rfstrs_ref)
1410 : : end if
1411 : :
1412 : : !Use of NSTPAW3 for NCPP (instead of DFPT_NSELT/DFPT_NSTDY) can be forced with userie=919
1413 : : !!MT oct. 2015: this works perfectly on all automatic tests
1414 : : !MS jan. 2025: As dfpt_nstpaw has been ported and optimised on OpenMP GPU,
1415 : : ! use it when OpenMP GPU is requested (outside of rfstrs).
1416 : : ! if(ipert<=dtset%natom+4)then
1417 [ + + + + ]: 2354 : if (ipert<dtset%natom+10.or.ipert>dtset%natom+11) then
1418 [ + + + - : 2175 : if (psps%usepaw==1.or.dtset%userie==919.or.&
- + - - -
- ]
1419 : : & (dtset%gpu_option==ABI_GPU_OPENMP.and.(ipert/=dtset%natom+3.and.ipert/=dtset%natom+4))) then
1420 : : call dfpt_nstpaw(blkflg,cg,cgq,cg1,cplex,cprj,cprjq,docckqde,doccde_rbz,dtfil,dtset,d2lo,d2nl,d2ovl,&
1421 : : & eigenq,eigen0,eigen1,eovl1,gmet,gprimd,gsqcut,idir,indkpt1,indsy1,ipert,irrzon1,istwfk_rbz,&
1422 : : & kg,kg1,kpt_rbz,kxc,mgfftf,mkmem,mkqmem,mk1mem,mpert,mpi_enreg,mpw,mpw1,nattyp,nband_rbz,mband_mem_rbz,ncpgr,&
1423 : : & nfftf,ngfftf,nhat,nhat1,nkpt_rbz,nkxc,npwarr,npwar1,nspden,dtset%nspinor,dtset%nsppol,&
1424 : : & nsym1,n3xccc,occkq,occ_rbz,paw_an,paw_an1,paw_ij,paw_ij1,pawang,pawang1,pawfgr,pawfgrtab,pawrad,&
1425 : : & pawrhoij,pawrhoij1,pawtab,phnons1,ph1d,ph1df,psps,rhog,rhor,rhor1,rmet,rprimd,symaf1,symrc1,&
1426 : : & symrl1,tnons1,ucvol,usecprj,psps%usepaw,usevxctau,usexcnhat,useylmgr1,vectornd,vhartr1,vpsp1,vtrial,vtrial1,&
1427 : 359 : & vxc,vxctau,with_vectornd,wtk_rbz,xccc3d1,xred,ylm,ylm1,ylmgr1)
1428 : : else
1429 [ + + ]: 1816 : if(kramers_deg) then
1430 [ + + ]: 1805 : if (dtset%nspden==4) then
1431 : : call dfpt_nstdy(atindx,blkflg,cg,cg1,cplex,dtfil,dtset,d2bbb,d2lo,d2nl,eigen0,eigen1,gmet,&
1432 : : & gsqcut,idir,indkpt1,indsy1,ipert,istwfk_rbz,kg,kg1,kpt_rbz,kxc,mband_mem_rbz,mkmem,mk1mem,mpert,mpi_enreg,&
1433 : : & mpw,mpw1,nattyp,nband_rbz,nfftf,ngfftf,nkpt,nkpt_rbz,nkxc,npwarr,npwar1,nspden,&
1434 : : & dtset%nsppol,nsym1,occ_rbz,ph1d,psps,qphon,rhor1,rmet,rprimd,symrc1,ucvol,&
1435 : 16 : & wtk_rbz,xred,ylm,ylm1,rhor=rhor,vxc=vxc,ixcrot=dtset%ixcrot)
1436 : : else
1437 : : call dfpt_nstdy(atindx,blkflg,cg,cg1,cplex,dtfil,dtset,d2bbb,d2lo,d2nl,eigen0,eigen1,gmet,&
1438 : : & gsqcut,idir,indkpt1,indsy1,ipert,istwfk_rbz,kg,kg1,kpt_rbz,kxc,mband_mem_rbz,mkmem,mk1mem,mpert,mpi_enreg,&
1439 : : & mpw,mpw1,nattyp,nband_rbz,nfftf,ngfftf,nkpt,nkpt_rbz,nkxc,npwarr,npwar1,nspden,&
1440 : : & dtset%nsppol,nsym1,occ_rbz,ph1d,psps,qphon,rhor1,rmet,rprimd,symrc1,ucvol,&
1441 : 1789 : & wtk_rbz,xred,ylm,ylm1)
1442 : : end if
1443 : : else if(.not.kramers_deg) then
1444 [ + - ]: 11 : if (dtset%nspden==4) then
1445 : : call dfpt_nstdy(atindx,blkflg,cg,cg1,cplex,dtfil,dtset,d2bbb_pq,d2lo_pq,d2nl_pq,eigen0,eigen1,gmet,&
1446 : : & gsqcut,idir,indkpt1,indsy1,ipert,istwfk_rbz,kg,kg1,kpt_rbz,kxc,mband_mem_rbz,mkmem,mk1mem,mpert,mpi_enreg,&
1447 : : & mpw,mpw1,nattyp,nband_rbz,nfftf,ngfftf,nkpt,nkpt_rbz,nkxc,npwarr,npwar1,nspden,&
1448 : : & dtset%nsppol,nsym1,occ_rbz,ph1d,psps,qphon,rhor1_pq,rmet,rprimd,symrc1,ucvol,&
1449 : 11 : & wtk_rbz,xred,ylm,ylm1,rhor=rhor,vxc=vxc,ixcrot=dtset%ixcrot)
1450 : : else
1451 : : call dfpt_nstdy(atindx,blkflg,cg,cg1,cplex,dtfil,dtset,d2bbb_pq,d2lo_pq,d2nl_pq,eigen0,eigen1,gmet,&
1452 : : & gsqcut,idir,indkpt1,indsy1,ipert,istwfk_rbz,kg,kg1,kpt_rbz,kxc,mband_mem_rbz,mkmem,mk1mem,mpert,mpi_enreg,&
1453 : : & mpw,mpw1,nattyp,nband_rbz,nfftf,ngfftf,nkpt,nkpt_rbz,nkxc,npwarr,npwar1,nspden,&
1454 : : & dtset%nsppol,nsym1,occ_rbz,ph1d,psps,qphon,rhor1_pq,rmet,rprimd,symrc1,ucvol,&
1455 : 0 : & wtk_rbz,xred,ylm,ylm1)
1456 : : end if
1457 [ + - ]: 11 : if (dtset%nspden==4) then
1458 : : call dfpt_nstdy(atindx,blkflg,cg,cg1_mq,cplex,dtfil,dtset,d2bbb_mq,d2lo_mq,d2nl_mq,eigen0,eigen1_mq,gmet,&
1459 : : & gsqcut,idir,indkpt1,indsy1,ipert,istwfk_rbz,kg,kg1_mq,kpt_rbz,kxc,mband_mem_rbz,mkmem,mk1mem,mpert,mpi_enreg,&
1460 : : & mpw,mpw1_mq,nattyp,nband_rbz,nfftf,ngfftf,nkpt,nkpt_rbz,nkxc,npwarr,npwar1_mq,nspden,&
1461 : : & dtset%nsppol,nsym1,occ_rbz,ph1d,psps,qphon_mq,rhor1_mq,rmet,rprimd,symrc1,ucvol,&
1462 : 11 : & wtk_rbz,xred,ylm,ylm1_mq,rhor=rhor,vxc=vxc,ixcrot=dtset%ixcrot)
1463 : : else
1464 : : call dfpt_nstdy(atindx,blkflg,cg,cg1_mq,cplex,dtfil,dtset,d2bbb_mq,d2lo_mq,d2nl_mq,eigen0,eigen1_mq,gmet,&
1465 : : & gsqcut,idir,indkpt1,indsy1,ipert,istwfk_rbz,kg,kg1_mq,kpt_rbz,kxc,mband_mem_rbz,mkmem,mk1mem,mpert,mpi_enreg,&
1466 : : & mpw,mpw1_mq,nattyp,nband_rbz,nfftf,ngfftf,nkpt,nkpt_rbz,nkxc,npwarr,npwar1_mq,nspden,&
1467 : : & dtset%nsppol,nsym1,occ_rbz,ph1d,psps,qphon_mq,rhor1_mq,rmet,rprimd,symrc1,ucvol,&
1468 : 0 : & wtk_rbz,xred,ylm,ylm1_mq)
1469 : : end if
1470 : :
1471 : : !Mix up (q,w) and (-q,-w) second-order derivatives
1472 [ - + - - : 11 : d2bbb(1,:,idir,ipert,:,:)=half*(d2bbb_pq(1,:,idir,ipert,:,:)+d2bbb_mq(1,:,idir,ipert,:,:))
- - ]
1473 [ - + - - : 11 : d2bbb(2,:,idir,ipert,:,:)=half*(d2bbb_pq(2,:,idir,ipert,:,:)-d2bbb_mq(2,:,idir,ipert,:,:))
- - ]
1474 [ + + + + ]: 843 : d2lo(1,:,:,idir,ipert)=half*(d2lo_pq(1,:,:,idir,ipert)+d2lo_mq(1,:,:,idir,ipert))
1475 [ + + + + ]: 843 : d2lo(2,:,:,idir,ipert)=half*(d2lo_pq(2,:,:,idir,ipert)-d2lo_mq(2,:,:,idir,ipert))
1476 [ + + + + ]: 843 : d2nl(1,:,:,idir,ipert)=half*(d2nl_pq(1,:,:,idir,ipert)+d2nl_mq(1,:,:,idir,ipert))
1477 [ + + + + ]: 843 : d2nl(2,:,:,idir,ipert)=half*(d2nl_pq(2,:,:,idir,ipert)-d2nl_mq(2,:,:,idir,ipert))
1478 : :
1479 : : end if
1480 : : end if
1481 : : end if
1482 : :
1483 : 2354 : call timab(150,2,tsec)
1484 : 2354 : call timab(160,1,tsec)
1485 : :
1486 : :
1487 : : !calculate Born effective charge and store it in d2lo
1488 : : if ((dtset%berryopt== 4.or.dtset%berryopt== 6.or.dtset%berryopt== 7.or.&
1489 [ + + + + ]: 2354 : & dtset%berryopt==14.or.dtset%berryopt==16.or.dtset%berryopt==17).and.&
1490 : : & ipert<=dtset%natom) then
1491 : : call dfptff_bec(cg,cg1,dtefield,dtset%natom,d2lo,idir,ipert,dtset%mband,mband_mem_rbz,mkmem,&
1492 : 6 : & mpi_enreg,mpw,mpw1,mpert,nkpt,npwarr,npwar1,dtset%nsppol,dtset%nspinor,pwindall,qmat,rprimd)
1493 [ + + + + : 162 : blkflg(:,dtset%natom+2,:,1:dtset%natom)=1
+ + ]
1494 : : end if
1495 : :
1496 : :
1497 : : !calculate dielectric tensor and store it in d2lo
1498 : : if ((dtset%berryopt== 4.or.dtset%berryopt== 6.or.dtset%berryopt== 7.or.&
1499 [ + + ]: 9 : & dtset%berryopt==14.or.dtset%berryopt==16.or.dtset%berryopt==17).and.&
1500 : : & ipert==dtset%natom+2) then
1501 : : call dfptff_die(cg,cg1,dtefield,d2lo,idir,ipert,dtset%mband,mband_mem_rbz,mkmem,&
1502 : 3 : & mpi_enreg,mpw,mpw1,mpert,nkpt,npwarr,npwar1,dtset%nsppol,dtset%nspinor,pwindall,qmat,rprimd)
1503 [ + + + + ]: 39 : blkflg(:,dtset%natom+2,:,dtset%natom+2)=1
1504 : : end if
1505 : :
1506 : :
1507 : : !If SCF convergence was not reached (for nstep>0),
1508 : : !print a warning to the output file (non-dummy arguments: nstep,
1509 : : !residm, diffor - infos from tollist have been saved inside )
1510 : : !Set also the value of conv_retcode
1511 : 2354 : choice=3
1512 : : call scprqt(choice,cpus,deltae,diffor,maxmag,difmag,dtset,eigen0,&
1513 : : & etotal,favg,fcart,fermie,fermie,dtfil%fnametmp_eig,dtfil%filnam_ds(1),&
1514 : : & 1,iscf_mod,istep,istep_fock_outer,istep_mix,kpt_rbz,maxfor,&
1515 : : & mvdum,mpi_enreg,nband_rbz,nkpt_rbz,&
1516 : : & nstep,occ_rbz,0,prtfor,0,&
1517 : : & quit,res2,resid,residm,response,&
1518 : 2354 : & tollist,psps%usepaw,vxcavg,wtk_rbz,xred,conv_retcode)
1519 : :
1520 : : !Update the content of the header (evolving variables)
1521 [ + + ]: 151816 : bantot_rbz = sum(nband_rbz(1:nkpt_rbz*dtset%nsppol))
1522 : : call hdr%update(bantot_rbz,etotal,fermie,fermie,&
1523 : : & residm,rprimd,occ_rbz,pawrhoij1,xred,dtset%amu_orig(:,1),&
1524 : 2354 : & comm_atom=mpi_enreg%comm_atom,mpi_atmtab=mpi_enreg%my_atmtab )
1525 : :
1526 : : !Optionally provide output of charge density and/or potential in real space,
1527 : : !as well as analysis of geometrical factors (bond lengths and bond angles).
1528 : : !Warnings :
1529 : : !- core charge is excluded from the charge density;
1530 : : !- the potential is the INPUT vtrial.
1531 : :
1532 [ + + + + ]: 2354 : if (ipert/=dtset%natom+1.and.dtset%prt1mag/=0) then
1533 : 12 : prtopt=1
1534 : : ! if(ipert==dtset%natom+5 .or. ipert==dtset%natom+6 .or. ipert>dtset%natom+11 ) then
1535 : : ! prtopt=idir+1;
1536 : : call calcdenmagsph(mpi_enreg,dtset%natom,nfftf,ngfftf,nspden,&
1537 : : & dtset%ntypat,dtset%ratsm,dtset%ratsph,rhor1,rprimd,dtset%typat,xred,&
1538 : : & prtopt,cplex,dtset%qgbt,dtset%use_gbt,intgden=intgden,dentot=dentot,rhomag=rhomag,&
1539 : 12 : & qphon=qphon)
1540 : :
1541 : : call magmom_to_d2(blkflg,cplex,d2lo,idir,intgden,ipert,mpert,&
1542 : 12 : & dtset%natom,nspden,rhomag)
1543 : : end if
1544 : : ! end if
1545 [ + + + + : 2354 : if((iscf_mod>0).and.(dtset%nsppol==2.or.dtset%nspden>1)) then
+ + ]
1546 [ + + ]: 216 : call prtdenmagsph(cplex,intgden,dtset%natom,nspden,dtset%ntypat,[ab_out],1,dtset%qgbt,dtset%ratsm,dtset%ratsph,rhomag,dtset%typat,dtset%znucl,dtset%spinaxis)
1547 : : endif
1548 : :
1549 : : !MR: Next call to calcdenmagsph is commented since it provides redundant information
1550 : : ! if(ipert==dtset%natom+5.or.ipert<=dtset%natom)then
1551 : : ! prtopt=1
1552 : : ! if(ipert==dtset%natom+5) then
1553 : : ! prtopt=idir+1;
1554 : : ! call calcdenmagsph(mpi_enreg,dtset%natom,nfftf,ngfftf,nspden,&
1555 : : ! & dtset%ntypat,dtset%ratsm,dtset%ratsph,rhor1,rprimd,dtset%typat,xred,&
1556 : : ! & prtopt,cplex,intgden=intgden,dentot=dentot,rhomag=rhomag)
1557 : : ! call prtdenmagsph(cplex,intgden,dtset%natom,nspden,dtset%ntypat,ab_out,prtopt,dtset%ratsm,dtset%ratsph,rhomag,dtset%typat)
1558 : : ! !debug: write out the vtk first-order density components
1559 : : ! ! call appdig(pertcase,dtfil%fnameabo_den,fi1o_vtk)
1560 : : ! ! call printmagvtk(mpi_enreg,cplex,nspden,nfftf,ngfftf,rhor1,rprimd,adjustl(adjustr(fi1o_vtk)//"_PQ"))
1561 : : ! ! call printmagvtk(mpi_enreg,cplex,nspden,nfftf,ngfftf,rhor1,rprimd,adjustl(adjustr(fi1o_vtk)//"_MQ"))
1562 : : ! !SPr: add calculation of the contributions to susceptibility from all atomic spheres
1563 : : ! end if
1564 : : ! end if
1565 : :
1566 [ + + ]: 2354 : if (iwrite_fftdatar(mpi_enreg)) then
1567 [ + + ]: 2053 : if (dtset%prtden>0) then
1568 : 1841 : rdwrpaw=0
1569 : 1841 : call appdig(pertcase,dtfil%fnameabo_den,fi1o)
1570 : : ! TODO: should we write pawrhoij1 or pawrhoij. Note that ioarr writes hdr%pawrhoij
1571 : : call fftdatar_write_from_hdr("first_order_density",fi1o,dtset%iomode,hdr,&
1572 : 1841 : ngfftf,cplex,nfftf,dtset%nspden,rhor1,mpi_enreg)
1573 : : end if
1574 : :
1575 : : ! Write first order potentials (needed by EPH)
1576 : : ! In DFPT, prtpot is automatically set to 1 unless the user set it to 0 explictly in the input
1577 : : ! See invars2
1578 : : ! (actually we should avoid writing 1WFK)
1579 [ + + ]: 2053 : if (dtset%prtpot > 0) then
1580 : 2006 : rdwrpaw=0
1581 : 2006 : call appdig(pertcase,dtfil%fnameabo_pot,fi1o)
1582 : : ! TODO: should we write pawrhoij1 or pawrhoij. Note that ioarr writes hdr%pawrhoij
1583 : : call fftdatar_write_from_hdr("first_order_potential",fi1o,dtset%iomode,hdr,&
1584 : 2006 : ngfftf,cplex,nfftf,dtset%nspden,vtrial1,mpi_enreg)
1585 : :
1586 : : ! Add rhog1(G=0) to file
1587 : : ! This part is obsolete. I keep it just to maintain compatibility with the fileformat.
1588 [ + - ]: 2006 : if (mpi_enreg%me_g0 == 1) then
1589 [ + - ]: 2006 : if (dtset%iomode == IO_MODE_ETSF) then
1590 [ - + ]: 2006 : NCF_CHECK(nctk_open_modify(ncid, nctk_ncify(fi1o), xmpi_comm_self))
1591 : 2006 : ncerr = nctk_def_one_array(ncid, nctkarr_t('rhog1_g0', "dp", "two"), varid=varid)
1592 [ - + ]: 2006 : NCF_CHECK(ncerr)
1593 [ - + ]: 2006 : NCF_CHECK(nctk_set_datamode(ncid))
1594 [ - + ]: 2006 : NCF_CHECK(nf90_put_var(ncid, varid, rhog1(:,1)))
1595 [ - + ]: 2006 : NCF_CHECK(nf90_close(ncid))
1596 : : else
1597 : : ! Handle Fortran files.
1598 [ # # ]: 0 : if (open_file(fi1o, msg, newunit=ncid, form='unformatted', status='old', action="readwrite") /= 0) then
1599 : 0 : ABI_ERROR(msg)
1600 : : end if
1601 [ # # ]: 0 : if (fort_denpot_skip(ncid, msg) /= 0) ABI_ERROR(msg)
1602 : 0 : write(ncid) rhog1(:,1)
1603 : 0 : close(ncid)
1604 : : end if
1605 : : end if
1606 : :
1607 : : end if
1608 : :
1609 : : ! output files for perturbed potential components: vhartr1,vpsp1,vxc
1610 : : ! NB: only 1 spin for these
1611 [ - + ]: 2053 : if (dtset%prtvha > 0) then
1612 : 0 : rdwrpaw=0
1613 [ # # # # : 0 : ABI_MALLOC(vhartr1_tmp, (cplex*nfftf, dtset%nspden))
# # # # #
# # # # #
# # ]
1614 [ # # # # ]: 0 : vhartr1_tmp = zero
1615 [ # # ]: 0 : vhartr1_tmp(:,1) = vhartr1(:)
1616 : 0 : call appdig(pertcase,dtfil%fnameabo_vha,fi1o)
1617 : : ! TODO: should we write pawrhoij1 or pawrhoij. Note that ioarr writes hdr%pawrhoij
1618 : : call fftdatar_write_from_hdr("first_order_vhartree",fi1o,dtset%iomode,hdr,&
1619 : 0 : ngfftf,cplex,nfftf,dtset%nspden,vhartr1_tmp,mpi_enreg)
1620 [ # # ]: 0 : ABI_FREE(vhartr1_tmp)
1621 : : end if
1622 : :
1623 : : ! vpsp1 needs to be copied to a temp array - intent(inout) in fftdatar_write_from_hdr though I do not know why
1624 : : ! if (dtset%prtvpsp > 0) then
1625 : : ! rdwrpaw=0
1626 : : ! call appdig(pertcase,dtfil%fnameabo_vpsp,fi1o)
1627 : : ! ! TODO: should we write pawrhoij1 or pawrhoij. Note that ioarr writes hdr%pawrhoij
1628 : : ! call fftdatar_write_from_hdr("first_order_vpsp",fi1o,dtset%iomode,hdr,&
1629 : : ! ngfftf,cplex,nfftf,1,vpsp1,mpi_enreg)
1630 : : ! end if
1631 : :
1632 [ - + ]: 2053 : if (dtset%prtvxc > 0) then
1633 : 0 : rdwrpaw=0
1634 : 0 : call appdig(pertcase,dtfil%fnameabo_vxc,fi1o)
1635 : : ! TODO: should we write pawrhoij1 or pawrhoij. Note that ioarr writes hdr%pawrhoij
1636 : : call fftdatar_write_from_hdr("first_order_vxc",fi1o,dtset%iomode,hdr,&
1637 : 0 : ngfftf,cplex,nfftf,dtset%nspden,vxc1,mpi_enreg)
1638 : : end if
1639 : :
1640 : : end if ! iwrite_fftdatar(mpi_enreg)
1641 : :
1642 : : !All procs waiting here...
1643 [ - + ]: 2354 : if(mpi_enreg%paral_kgb==1)then
1644 : 0 : call timab(61,1,tsec)
1645 : 0 : call xmpi_barrier(spaceComm)
1646 : 0 : call timab(61,2,tsec)
1647 : : end if
1648 : :
1649 : : !Deallocate arrays
1650 : : #ifdef HAVE_OPENMP_OFFLOAD
1651 : : !$OMP TARGET EXIT DATA MAP(delete:cgq) IF(dtset%gpu_option==ABI_GPU_OPENMP)
1652 : : #endif
1653 : :
1654 [ - + ]: 2354 : ABI_FREE(fcart)
1655 [ - + ]: 2354 : ABI_FREE(vtrial1)
1656 [ + + ]: 2354 : if (.not.kramers_deg) then
1657 [ - + ]: 11 : ABI_FREE(vtrial1_mq)
1658 [ - + ]: 11 : ABI_FREE(d2bbb_mq)
1659 [ - + ]: 11 : ABI_FREE(d2lo_mq)
1660 [ - + ]: 11 : ABI_FREE(d2nl_mq)
1661 [ - + ]: 11 : ABI_FREE(d2bbb_pq)
1662 [ - + ]: 11 : ABI_FREE(d2lo_pq)
1663 [ - + ]: 11 : ABI_FREE(d2nl_pq)
1664 : : end if
1665 [ - + ]: 2354 : ABI_FREE(vhartr1)
1666 [ - + ]: 2354 : ABI_FREE(vxc1)
1667 [ - + ]: 2354 : ABI_FREE(pwindall)
1668 [ - + + + ]: 2354 : ABI_FREE(qmat)
1669 : : if (dtset%berryopt== 4.or.dtset%berryopt== 6.or.dtset%berryopt== 7.or.&
1670 : : dtset%berryopt==14.or.dtset%berryopt==16.or.dtset%berryopt==17) then
1671 : 9 : call dtefield%free()
1672 [ - + ]: 9 : ABI_SFREE(mpi_enreg%kpt_loc2ibz_sp)
1673 : : end if
1674 : :
1675 [ + - ]: 2354 : ABI_SFREE(vectornd)
1676 : :
1677 [ + + ]: 2354 : if(psps%usepaw==1) then
1678 : 409 : call paw_an_free(paw_an1)
1679 : 409 : call paw_ij_free(paw_ij1)
1680 : : end if
1681 [ + - + + : 3138 : ABI_FREE(paw_an1)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + -
+ ]
1682 [ + - + + : 3138 : ABI_FREE(paw_ij1)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + ]
1683 [ - + ]: 2354 : ABI_FREE(nhat1)
1684 : :
1685 : 2354 : call timab(160,2,tsec)
1686 : 2354 : call timab(120,2,tsec)
1687 : :
1688 : : DBG_EXIT("COLL")
1689 : :
1690 [ + + + + : 9438 : end subroutine dfpt_scfcv
- + - + -
+ - + - +
- + - - -
- - - - -
- - - - -
- - + - +
+ + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - -
- - - - -
+ - + - +
- + - + -
+ - + -
+ ]
1691 : : !!***
1692 : :
1693 : : !!****f* ABINIT/dfpt_etot
1694 : : !! NAME
1695 : : !! dfpt_etot
1696 : : !!
1697 : : !! FUNCTION
1698 : : !! Assemble different contributions to the variational part of the
1699 : : !! 2nd derivative of total energy
1700 : : !!
1701 : : !! INPUTS
1702 : : !! berryopt= 4/14: electric field is on; berryopt = 6/7/16/17: electric displacement field is on;
1703 : : !! eberry=energy associated with Berry phase
1704 : : !! edocc=correction to 2nd-order total energy coming from changes of occupation
1705 : : !! ehart1=1st-order Hartree part of 2nd-order total energy
1706 : : !! eeig0=0th-order eigenenergies part of 2nd-order total energy
1707 : : !! eew=2nd derivative of Ewald energy (hartree)
1708 : : !! efrhar=contrib. from frozen-wavefunction, hartree energy, to the 2nd-derivative of total energy
1709 : : !! efrkin=contrib. from frozen-wavefunction, kinetic energy, to the 2nd-derivative of total energy
1710 : : !! efrloc=contrib. from frozen-wavefunction, local potential, to the 2nd-derivative of total energy
1711 : : !! efrnl=contribution from frozen-wavefunction, non-local potential, to the 2nd-derivative of total energy
1712 : : !! efrx1=contrib. from frozen-wavefunction, xc core correction(1), to the 2nd-derivative of total energy
1713 : : !! efrx2=contribution from frozen-wavefunction, xc core correction(2),
1714 : : !! to the second-derivative of total energy.
1715 : : !! ek0=0th-order kinetic energy part of 2nd-order total energy.
1716 : : !! ek1=1st-order kinetic energy part of 2nd-order total energy.
1717 : : !! eii=2nd derivative of pseudopotential core energy (hartree)
1718 : : !! elmag1=1st-order Zeeman part of 2nd-order total energy.
1719 : : !! eloc0=0th-order local (psp+vxc+Hart) part of 2nd-order total energy
1720 : : !! elpsp1=1st-order local pseudopot. part of 2nd-order total energy.
1721 : : !! emagpen1= Magnetic penalty term entering the 2nd-onder total energy.
1722 : : !! end0=0th-order nuclear dipole energy part of 2nd-order total energy.
1723 : : !! end1=1st-order nuclear dipole energy part of 2nd-order total energy.
1724 : : !! enl0=0th-order nonlocal pseudopot. part of 2nd-order total energy.
1725 : : !! enl1=1st-order nonlocal pseudopot. part of 2nd-order total energy.
1726 : : !! epaw1=1st-order PAW on-sitew part of 2nd-order total energy.
1727 : : !! evdw=DFT-D semi-empirical part of 2nd-order total energy
1728 : : !! evxctau0=0th-order vxctau energy
1729 : : !! evxctau1=1st-order vxctau energy
1730 : : !! exc1=1st-order exchange-correlation part of 2nd-order total energy
1731 : : !! ipert=type of the perturbation
1732 : : !! natom=number of atoms
1733 : : !! optene=option for the computation of 2nd-order total energy
1734 : : !! (-1=no computation; 0=direct scheme; 1=double-counting scheme)
1735 : : !!
1736 : : !! OUTPUT
1737 : : !! deltae=change in energy between the previous and present SCF cycle
1738 : : !! and previous SCF cycle.
1739 : : !! etotal=2nd-order total energy
1740 : : !! evar=variational part of the 2nd-order total energy
1741 : : !!
1742 : : !! SIDE EFFECTS
1743 : : !! input/output
1744 : : !! elast=previous value of the 2nd-order total energy, needed to compute deltae,
1745 : : !! then updated (cannot simply be saved, because set to zero
1746 : : !! at each new call of dfpt_scfcv).
1747 : : !!
1748 : : !! SOURCE
1749 : :
1750 : 18712 : subroutine dfpt_etot(berryopt,deltae,eberry,edocc,eeig0,eew,efrhar,efrkin,efrloc,&
1751 : : & efrnl,efrx1,efrx2,ehart1,ek0,ek1,eii,elast,elmag1,eloc0,elpsp1,emagpen1,&
1752 : : & end0,end1,enl0,enl1,epaw1,etotal,evar,evdw,evxctau0,evxctau1,&
1753 : : & exc1,ipert,natom,optene)
1754 : :
1755 : : !Arguments ------------------------------------
1756 : : !scalars
1757 : : integer,intent(in) :: berryopt,ipert,natom,optene
1758 : : real(dp),intent(in) :: eberry,edocc,eeig0,eew,efrhar,efrkin,efrloc,efrnl,efrx1
1759 : : real(dp),intent(in) :: efrx2,ehart1,eii,ek0,ek1,elmag1,eloc0,elpsp1,emagpen1,end0,end1,enl0,enl1,epaw1
1760 : : real(dp),intent(in) :: evdw,evxctau0,evxctau1,exc1
1761 : : real(dp),intent(inout) :: elast
1762 : : real(dp),intent(out) :: deltae,etotal,evar
1763 : :
1764 : : !Local variables-------------------------------
1765 : : !scalars
1766 : : ! character(len=500) :: msg
1767 : : ! *********************************************************************
1768 : :
1769 [ - + ]: 18712 : if (optene==1) then
1770 : 0 : ABI_BUG('Double-counting scheme not yet allowed!')
1771 : : end if
1772 : :
1773 [ + - ]: 18712 : if (optene>-1) then
1774 : :
1775 : : ! Compute 2nd-order variational energy by direct scheme
1776 [ + - ]: 18712 : if (optene==0) then
1777 : :
1778 : : ! Atomic displ. perturbation
1779 [ + - + + ]: 18712 : if ( ipert>=1 .and. ipert<=natom ) then
1780 : 11388 : evar=ek0+edocc+eeig0+eloc0+enl0+ehart1+exc1+enl1+epaw1+elpsp1+emagpen1
1781 : :
1782 [ + + ]: 7324 : else if (ipert==natom+1) then
1783 : 3422 : evar=ek0+edocc+eeig0+eloc0+ek1+ehart1+exc1+enl0+enl1+end0+end1+evxctau0+evxctau1
1784 : :
1785 [ + + + + ]: 3902 : else if (ipert==natom+10 .or. ipert==natom+11) then
1786 : 179 : evar=ek0+edocc+eeig0+eloc0+enl0 +ek1 ! here ek1 contains a lot of contributions
1787 : :
1788 : : ! For ipert==natom+2, some contributions vanish, noticeably ek1
1789 [ + + ]: 3723 : else if (ipert==natom+2) then
1790 : 2067 : evar=ek0+edocc+eeig0+eloc0+enl0+ehart1+exc1+enl1+ek1+epaw1+emagpen1
1791 : :
1792 : : ! All terms enter for strain perturbation
1793 [ + + + + ]: 1656 : else if ( ipert==natom+3 .or. ipert==natom+4 ) then
1794 : 1507 : evar=ek0+edocc+eeig0+eloc0+enl0+ehart1+exc1+enl1+ek1+epaw1+elpsp1
1795 : :
1796 : : ! terms for Zeeman or scalar potential perturbation, SPr 2deb
1797 [ + + + + ]: 149 : else if ( ipert==natom+5 .or. ipert==natom+6 ) then
1798 : 125 : evar=ek0+edocc+eeig0+eloc0+enl0+ehart1+exc1+epaw1+emagpen1+elmag1
1799 : :
1800 : : ! terms for atomic-spheres local Zeeman perturbation
1801 [ + - + - ]: 24 : else if ( ipert>natom+11.and.ipert<=2*natom+11 ) then
1802 : 24 : evar=ek0+edocc+eeig0+eloc0+enl0+ehart1+exc1+epaw1+emagpen1+elmag1
1803 : : end if
1804 : : end if
1805 : :
1806 : : ! Compute energy residual
1807 : 18712 : deltae=evar-elast
1808 : 18712 : elast=evar
1809 : :
1810 : : ! Compute 2nd-order total energy by direct scheme
1811 [ + - ]: 18712 : if (optene==0) then
1812 [ + + ]: 18712 : if (berryopt==4 .or. berryopt==6 .or. berryopt==7 .or. berryopt==14 .or. berryopt==16 .or. berryopt==17) then
1813 [ + + ]: 97 : if (ipert<=natom) then
1814 : 61 : etotal=evar+eew+evdw+eii+efrhar+efrkin+efrloc+efrnl+efrx1+efrx2+two*eberry
1815 [ + - ]: 36 : else if (ipert==natom+2) then
1816 : 36 : etotal=half*evar+eew+evdw+eii+efrhar+efrkin+efrloc+efrnl+efrx1+efrx2+two*eberry
1817 : : end if
1818 : : else
1819 [ + + + + ]: 18615 : if (ipert/=natom+10 .and. ipert/=natom+11) then
1820 : 18436 : etotal=evar+eew+evdw+eii+efrhar+efrkin+efrloc+efrnl+efrx1+efrx2
1821 : : else
1822 : 179 : etotal=evar ! For 2nd order sternheimer equations, the total (4th order) energy is not used (yet)
1823 : : end if
1824 : : end if
1825 : : end if
1826 : :
1827 : : end if
1828 : :
1829 : 18712 : end subroutine dfpt_etot
1830 : : !!***
1831 : :
1832 : : !!****f* ABINIT/dfpt_etot_avg_mq
1833 : : !! NAME
1834 : : !! dfpt_etot_avg_mq
1835 : : !!
1836 : : !! FUNCTION
1837 : : !! When time-reversal symmetry cannot be used to relate the +q and -q
1838 : : !! responses (kramers_deg=.false.), the contributions to the 2nd-order
1839 : : !! energy are computed separately at (+q,+omega) and (-q,-omega).
1840 : : !! This routine replaces each +q contribution by the average of the
1841 : : !! +q and -q ones, half*(E(+q)+E(-q)).
1842 : : !!
1843 : : !! Note that elast is deliberately NOT averaged: elast and elast_mq keep
1844 : : !! the evar of the previous SCF step for each branch separately, so that
1845 : : !! the averaged deltae is the change of the averaged evar.
1846 : : !! eberry is not averaged either, since it is only computed at +q.
1847 : : !!
1848 : : !! INPUTS
1849 : : !! deltae_mq,edocc_mq,eeig0_mq,ek0_mq,ek1_mq,eloc0_mq,end0_mq,end1_mq,
1850 : : !! enl0_mq,enl1_mq,epaw1_mq,etotal_mq,evar_mq=
1851 : : !! contributions to the 2nd-order energy at (-q,-omega)
1852 : : !! (see dfpt_etot for the meaning of each term)
1853 : : !!
1854 : : !! SIDE EFFECTS
1855 : : !! deltae,edocc,eeig0,ek0,ek1,eloc0,end0,end1,enl0,enl1,epaw1,etotal,evar=
1856 : : !! input: contributions to the 2nd-order energy at (+q,+omega)
1857 : : !! output: average of the (+q,+omega) and (-q,-omega) contributions
1858 : : !!
1859 : : !! SOURCE
1860 : :
1861 : 80 : subroutine dfpt_etot_avg_mq(deltae,deltae_mq,edocc,edocc_mq,eeig0,eeig0_mq,ek0,ek0_mq,ek1,ek1_mq,&
1862 : : & eloc0,eloc0_mq,end0,end0_mq,end1,end1_mq,enl0,enl0_mq,enl1,enl1_mq,epaw1,epaw1_mq,&
1863 : : & etotal,etotal_mq,evar,evar_mq)
1864 : :
1865 : : !Arguments ------------------------------------
1866 : : !scalars
1867 : : real(dp),intent(in) :: deltae_mq,edocc_mq,eeig0_mq,ek0_mq,ek1_mq,eloc0_mq,end0_mq,end1_mq
1868 : : real(dp),intent(in) :: enl0_mq,enl1_mq,epaw1_mq,etotal_mq,evar_mq
1869 : : real(dp),intent(inout) :: deltae,edocc,eeig0,ek0,ek1,eloc0,end0,end1
1870 : : real(dp),intent(inout) :: enl0,enl1,epaw1,etotal,evar
1871 : :
1872 : : ! *********************************************************************
1873 : :
1874 : 80 : deltae= half*(deltae+deltae_mq)
1875 : 80 : edocc = half*(edocc +edocc_mq )
1876 : 80 : eeig0 = half*(eeig0 +eeig0_mq )
1877 : 80 : ek0 = half*(ek0 +ek0_mq )
1878 : 80 : ek1 = half*(ek1 +ek1_mq )
1879 : 80 : eloc0 = half*(eloc0 +eloc0_mq )
1880 : 80 : end0 = half*(end0 +end0_mq )
1881 : 80 : end1 = half*(end1 +end1_mq )
1882 : 80 : enl0 = half*(enl0 +enl0_mq )
1883 : 80 : enl1 = half*(enl1 +enl1_mq )
1884 : 80 : epaw1 = half*(epaw1 +epaw1_mq )
1885 : 80 : etotal= half*(etotal+etotal_mq)
1886 : 80 : evar = half*(evar +evar_mq )
1887 : :
1888 : 80 : end subroutine dfpt_etot_avg_mq
1889 : : !!***
1890 : :
1891 : : !!****f* ABINIT/newfermie1
1892 : : !! NAME
1893 : : !! newfermie1
1894 : : !!
1895 : : !! FUNCTION
1896 : : !! This routine computes the derivative of the fermi energy wrt
1897 : : !! the active perturbation for use in evaluating the edocc term
1898 : : !! and active subspace contribution to the first-order wavefunctions
1899 : : !! in the case of metals. This is presently used only for the
1900 : : !! strain and magnetic field perturbations, and only for Q = 0.
1901 : : !!
1902 : : !! INPUTS
1903 : : !! cplex: if 1, real space 1-order functions on FFT grid are REAL,
1904 : : !! if 2, COMPLEX
1905 : : !! fe1fixed=fixed contribution to the first-order Fermi energy
1906 : : !! ipert=index of perturbation
1907 : : !! istep=index of the number of steps in the routine scfcv
1908 : : !! ixc= choice of exchange-correlation scheme
1909 : : !! mpi_atmtab(:)=--optional-- indexes of the atoms treated by current proc
1910 : : !! comm_atom=--optional-- MPI communicator over atoms
1911 : : !! my_natom=number of atoms treated by current processor
1912 : : !! natom=number of atoms
1913 : : !! nfft=(effective) number of FFT grid points (for this processor)
1914 : : !! nfftot= total number of FFT grid points
1915 : : !! nhatfermi(nfft,nspden)=fermi-level compensation charge density (PAW only)
1916 : : !! nspden=number of spin-density components
1917 : : !! ntypat=number of atom types
1918 : : !! occopt=option for occupancies
1919 : : !! paw_an(natom) <type(paw_an_type)>=paw arrays for 0th-order quantities given on angular mesh
1920 : : !! paw_an1(natom) <type(paw_an_type)>=paw arrays for 1st-order quantities given on angular mesh
1921 : : !! paw_ij1(natom) <type(paw_ij_type)>=(1st-order) paw arrays given on (i,j) channels
1922 : : !! pawang <type(pawang_type)>=paw angular mesh and related data
1923 : : !! pawnzlm=-- PAW only -- option for the computation of non-zero
1924 : : !! lm moments of the on-sites densities
1925 : : !! pawrad(ntypat) <type(pawrad_type)>=paw radial mesh and related data
1926 : : !! pawrhoij1(natom) <type(pawrhoij_type)>= paw rhoij 1st-order occupancies
1927 : : !! pawrhoijfermi(natom) <type(pawrhoij_type)>=paw rhoij occupancies at Fermi level
1928 : : !! pawtab(ntypat) <type(pawtab_type)>=paw tabulated starting data
1929 : : !! pawxcdev=Choice of XC development (0=no dev. (use of angular mesh) ; 1 or 2=dev. on moments)
1930 : : !! xclevel= XC functional level
1931 : : !! prtvol=control print volume and debugging output
1932 : : !! rhorfermi(nfft,nspden)=fermi-level electronic density
1933 : : !! ucvol=unit cell volume in bohr**3
1934 : : !! usepaw=1 if PAW is activated
1935 : : !! usexcnhat= -PAW only- flag controling use of compensation density in Vxc
1936 : : !! vtrial1(cplex*nfft,nspden)=1-st order potential
1937 : : !! vxc1(cplex*nfft,nspden)=1-st order XC potential
1938 : : !!
1939 : : !! OUTPUT
1940 : : !! (see side effects)
1941 : : !!
1942 : : !! SIDE EFFECTS
1943 : : !! fermie1=derivative of fermi energy wrt perturbation
1944 : : !! at input : old value
1945 : : !! at output : updated value
1946 : : !!
1947 : : !! SOURCE
1948 : :
1949 : 1678 : subroutine newfermie1(cplex,fermie1,fe1fixed,ipert,istep,ixc,my_natom,natom,nfft,nfftot,&
1950 [ - + ]: 1678 : & nhatfermi,nspden,ntypat,occopt,paw_an,paw_an1,paw_ij1,pawang,pawnzlm,pawrad,&
1951 : 1678 : & pawrhoij1,pawrhoijfermi,pawtab,pawxcdev,prtvol,rhorfermi,&
1952 [ - + ]: 1678 : & ucvol,usepaw,usexcnhat,vtrial1,vxc1,xclevel,&
1953 [ + - + + : 1678 : & mpi_atmtab,comm_atom) ! optional arguments (parallelism)
- + ]
1954 : :
1955 : : !Arguments -------------------------------
1956 : : !scalars
1957 : : integer,intent(in) :: cplex,ipert,istep,ixc,my_natom,natom,nfft,nfftot,nspden,ntypat
1958 : : integer,intent(in) :: occopt,pawnzlm,pawxcdev,prtvol,usepaw,usexcnhat,xclevel
1959 : : integer,optional,intent(in) :: comm_atom
1960 : : real(dp),intent(in) :: fe1fixed,ucvol
1961 : : real(dp),intent(inout) :: fermie1
1962 : : type(pawang_type),intent(in) :: pawang
1963 : : !arrays
1964 : : integer,optional,target,intent(in) :: mpi_atmtab(:)
1965 : : real(dp),intent(in) :: rhorfermi(nfft,nspden),vtrial1(cplex*nfft,nspden)
1966 : : real(dp),intent(in) :: nhatfermi(:,:),vxc1(:,:)
1967 : : type(paw_an_type),intent(in) :: paw_an(my_natom*usepaw)
1968 : : type(paw_an_type),intent(inout) :: paw_an1(my_natom*usepaw)
1969 : : type(paw_ij_type),intent(inout) :: paw_ij1(my_natom*usepaw)
1970 : : type(pawrad_type),intent(in) :: pawrad(ntypat*usepaw)
1971 : : type(pawrhoij_type),intent(in) :: pawrhoij1(my_natom*usepaw),pawrhoijfermi(my_natom*usepaw)
1972 : : type(pawtab_type),intent(in) :: pawtab(ntypat*usepaw)
1973 : :
1974 : : !Local variables-------------------------------
1975 : : !scalars
1976 : : integer :: ipert0,my_comm_atom,nzlmopt,nzlmopt_fermi,option,pawprtvol
1977 : : logical :: my_atmtab_allocated,paral_atom
1978 : : real(dp) :: doti,fe1_scf,fe1_tmp,fermie1_new,fermie1rs
1979 : : character(len=500) :: msg
1980 : : !arrays
1981 : 1678 : integer, pointer :: my_atmtab(:)
1982 : : real(dp) :: fe1_paw(2)
1983 : 1678 : real(dp), allocatable :: rhor_nonhat(:,:),vtrial1_novxc(:,:)
1984 : : ! *********************************************************************
1985 : :
1986 : : !Tests
1987 : 1678 : if (cplex==2) then
1988 : 0 : ABI_BUG('Not compatible with cplex=2!')
1989 : : end if
1990 [ + + + + : 8390 : if (usepaw==1.and.usexcnhat==0.and.(size(nhatfermi)<=0.or.size(vxc1)<=0)) then
+ + + + +
- - + ]
1991 : 0 : ABI_BUG('Should have nhatfermi and vxc1 allocated with usexcnhat=0!')
1992 : : end if
1993 : :
1994 : : !Set up parallelism over atoms
1995 [ + - + + ]: 1678 : paral_atom=(present(comm_atom).and.(my_natom/=natom))
1996 [ + + ]: 1678 : nullify(my_atmtab);if (present(mpi_atmtab)) my_atmtab => mpi_atmtab
1997 [ + - ]: 1678 : my_comm_atom=xmpi_comm_self;if (present(comm_atom)) my_comm_atom=comm_atom
1998 : 1678 : call get_my_atmtab(my_comm_atom,my_atmtab,my_atmtab_allocated,paral_atom,natom,my_natom_ref=my_natom)
1999 : :
2000 [ + - ]: 1678 : if(occopt>=3 .and. occopt <=8) then
2001 : :
2002 : : ! The product of the current trial potential and the so-called Fermi level
2003 : : ! density is integrated to give the local potential contributions to the
2004 : : ! first-order Fermi level.
2005 : 1678 : option=1
2006 [ + + + + ]: 1678 : if (usepaw==1.and.usexcnhat==0) then
2007 [ - + + - : 604 : ABI_MALLOC(rhor_nonhat,(nfft,nspden))
- + + - +
- + - - +
- + ]
2008 [ - + + - : 453 : ABI_MALLOC(vtrial1_novxc,(nfft,nspden))
- + + - -
+ + - ]
2009 [ + + + + ]: 1300838 : rhor_nonhat(1:nfft,1:nspden)=rhorfermi(1:nfft,1:nspden)-nhatfermi(1:nfft,1:nspden)
2010 [ + + + + ]: 1300838 : vtrial1_novxc(1:nfft,1:nspden)=vtrial1(1:nfft,1:nspden)-vxc1(1:nfft,1:nspden)
2011 : : call dotprod_vn(cplex,rhor_nonhat,fe1_scf,doti,nfft,nfftot,&
2012 : 151 : & nspden,option,vtrial1,ucvol)
2013 : : call dotprod_vn(cplex,nhatfermi,fe1_tmp,doti,nfft,nfftot,&
2014 [ - + - - : 151 : & nspden,option,vtrial1_novxc,ucvol)
- - - - -
+ ]
2015 : 151 : fe1_scf=fe1_scf+fe1_tmp
2016 [ - + ]: 151 : ABI_FREE(rhor_nonhat)
2017 [ - + ]: 302 : ABI_FREE(vtrial1_novxc)
2018 : : else
2019 : : call dotprod_vn(cplex,rhorfermi,fe1_scf,doti,nfft,nfftot,&
2020 : 1527 : & nspden,option,vtrial1,ucvol)
2021 : : end if
2022 : :
2023 : 1678 : fe1_paw(:)=zero
2024 : : ! PAW on-site contribution (use Fermi level occupation matrix)
2025 [ + + ]: 1678 : if (usepaw==1) then
2026 : 1250 : ipert0=0;pawprtvol=0
2027 [ + + ]: 1250 : nzlmopt=0;if (istep>1) nzlmopt=pawnzlm
2028 [ + + + - ]: 1250 : if (istep==1.and.pawnzlm>0) nzlmopt=-1
2029 [ + - ]: 1250 : nzlmopt_fermi=0;if (pawnzlm>0) nzlmopt_fermi=-1
2030 : : call pawdfptenergy(fe1_paw,ipert,ipert0,ixc,my_natom,natom,ntypat,nzlmopt,&
2031 : : & nzlmopt_fermi,paw_an,paw_an1,paw_ij1,pawang,pawprtvol,pawrad,&
2032 : : & pawrhoij1,pawrhoijfermi,pawtab,pawxcdev,xclevel,&
2033 : 1250 : & mpi_atmtab=my_atmtab, comm_atom=my_comm_atom)
2034 : : end if
2035 : :
2036 : : ! The fixed contributions consisting of non-local potential and kinetic terms
2037 : : ! are added
2038 : 1678 : fermie1_new=fe1fixed+fe1_scf+fe1_paw(1)
2039 : 1678 : fermie1rs=(fermie1-fermie1_new)**2
2040 : 1678 : fermie1=fermie1_new
2041 : :
2042 [ + + ]: 1678 : if(prtvol>=10)then
2043 : 1233 : write(msg, '(a,i5,2es18.8)' ) ' fermie1, residual squared',istep,fermie1,fermie1rs
2044 : 1233 : call wrtout(std_out,msg,'COLL')
2045 : : end if
2046 : :
2047 : : else
2048 : 0 : fermie1=zero
2049 : : end if
2050 : :
2051 : : !Destroy atom table used for parallelism
2052 : 1678 : call free_my_atmtab(my_atmtab,my_atmtab_allocated)
2053 : :
2054 [ - + ]: 1678 : end subroutine newfermie1
2055 : : !!***
2056 : :
2057 : : !!****f* ABINIT/dfpt_newvtr
2058 : : !! NAME
2059 : : !! dfpt_newvtr
2060 : : !!
2061 : : !! FUNCTION
2062 : : !! Compute new first-order trial potential by mixing new and old values.
2063 : : !! First, compute preconditioned residual first-order potential.
2064 : : !! Then, call one of the self-consistency drivers, and update vtrial.
2065 : : !!
2066 : : !! INPUTS
2067 : : !! cplex: if 1, real space 1-order functions on FFT grid are REAL, if 2, COMPLEX
2068 : : !! dielar(7)=input parameters for dielectric matrix:
2069 : : !! diecut,dielng,diemac,diemix,diegap,dielam,diemixmag.
2070 : : !! dtset <type(dataset_type)>=all input variables in this dataset
2071 : : !! | isecur=level of security of the computation
2072 : : !! | mffmem=governs the number of FFT arrays which are fit in core memory
2073 : : !! | it is either 1, in which case the array f_fftgr is used,
2074 : : !! | or 0, in which case the array f_fftgr_disk is used
2075 : : !! | natom=number of atoms
2076 : : !! | nspden=number of spin-density components
2077 : : !! | paral_kgb=option for (kpt,g vectors,bands) parallelism
2078 : : !! | pawoptmix= - PAW only - 1 if the computed residuals include the PAW (rhoij) part
2079 : : !! etotal=the total energy obtained from the input vtrial
2080 : : !! ffttomix(nfft*(1-nfftmix/nfft))=Index of the points of the FFT (fine) grid on the grid used for mixing (coarse)
2081 : : !! initialized= if 0 the initialization of the RF run is not yet finished
2082 : : !! iscf=( <= 0 =>non-SCF), >0 => SCF)
2083 : : !! iscf =1 => determination of the largest eigenvalue of the SCF cycle
2084 : : !! iscf =2 => SCF cycle, simple mixing
2085 : : !! iscf =3 => SCF cycle, Anderson mixing
2086 : : !! iscf =4 => SCF cycle, Anderson mixing (order 2)
2087 : : !! iscf =5 => SCF cycle, CG based on the minimization of the energy
2088 : : !! iscf =7 => SCF cycle, Pulay mixing
2089 : : !! ispmix=1 if mixing is done in real space, 2 if mixing is done in reciprocal space
2090 : : !! istep= number of the step in the SCF cycle
2091 : : !! mixtofft(nfftmix*(1-nfftmix/nfft))=Index of the points of the FFT grid used for mixing (coarse) on the FFT (fine) grid
2092 : : !! mpi_enreg=information about MPI parallelization
2093 : : !! my_natom=number of atoms treated by current processor
2094 : : !! nfft=(effective) number of FFT grid points (for this processor)
2095 : : !! nfftmix=dimension of FFT grid used to mix the densities (used in PAW only)
2096 : : !! ngfft(18)=contain all needed information about 3D FFT, see ~abinit/doc/variables/vargs.htm#ngfft
2097 : : !! ngfftmix(18)=contain all needed information about 3D FFT, for the grid corresponding to nfftmix
2098 : : !! npawmix=-PAW only- number of spherical part elements to be mixed
2099 : : !! qphon(3)=reduced coordinates for the phonon wavelength (needed if cplex==2).
2100 : : !! pawrhoij(natom) <type(pawrhoij_type)>= paw rhoij occupancies and related data
2101 : : !! Use here rhoij residuals (and gradients)
2102 : : !! rhor(cplex*nfft,nspden)=array for 1st-order electron density
2103 : : !! in electrons/bohr**3.
2104 : : !! rprimd(3,3)=dimensional primitive translations in real space (bohr)
2105 : : !! usepaw= 0 for non paw calculation; =1 for paw calculation
2106 : : !! vresid(cplex*nfft,nspden)=array for the residual of the potential
2107 : : !! xred(3,natom)=reduced dimensionless atomic coordinates
2108 : : !!
2109 : : !! OUTPUT
2110 : : !! dbl_nnsclo=1 if nnsclo has to be doubled to secure the convergence.
2111 : : !!
2112 : : !! SIDE EFFECTS
2113 : : !! vtrial(cplex*nfft,nspden)= at input, it is the "in" trial potential that gave vresid=(v_out-v_in)
2114 : : !! at output, it is an updated "mixed" trial potential
2115 : : !! ==== if usepaw==1
2116 : : !! pawrhoij(natom)%nrhoijsel,rhoijselect,rhoijp= several arrays
2117 : : !! containing new values of rhoij (augmentation occupancies)
2118 : : !!
2119 : : !! NOTES
2120 : : !! In case of PAW calculations:
2121 : : !! Computations are done either on the fine FFT grid or the coarse grid (depending on dtset%pawmixdg)
2122 : : !! All variables (nfft,ngfft,mgfft) refer to the fine FFT grid.
2123 : : !! All arrays (densities/potentials...) are computed on this fine FFT grid.
2124 : : !! Developpers have to be careful when introducing others arrays:
2125 : : !! they have to be stored on the fine FFT grid.
2126 : : !! In case of norm-conserving calculations the FFT grid is the usual FFT grid.
2127 : : !!
2128 : : !! Subtility in PAW and non-collinear magnetism:
2129 : : !! Potentials are stored in (up-up,dn-dn,Re[up-dn],Im[up-dn]) format
2130 : : !! On-site occupancies (rhoij) are stored in (n,mx,my,mz)
2131 : : !! This is compatible provided that the mixing factors for n and m are identical
2132 : : !! and that the residual is not a combination of V_res and rhoij_res (pawoptmix=0).
2133 : : !!
2134 : : !! SOURCE
2135 : :
2136 : 13541 : subroutine dfpt_newvtr(cplex,dbl_nnsclo,dielar,dtset,etotal,ffttomix,&
2137 : 13541 : & initialized,iscf,ispmix,istep,mix,mixtofft,&
2138 : 13541 : & mpi_enreg,my_natom,nfft,nfftmix,ngfft,ngfftmix,npawmix,pawrhoij,&
2139 : 13541 : & qphon,rhor,rprimd,usepaw,vresid,vtrial)
2140 : :
2141 : : !Arguments-------------------------------
2142 : : !scalars
2143 : : integer,intent(in) :: cplex,initialized,iscf,ispmix,istep,my_natom,nfft
2144 : : integer,intent(in) :: nfftmix,npawmix,usepaw
2145 : : integer,intent(inout) :: dbl_nnsclo !vz_i
2146 : : real(dp),intent(in) :: etotal
2147 : : type(MPI_type),intent(in) :: mpi_enreg
2148 : : type(abi_mixing_object), intent(inout) :: mix
2149 : : type(dataset_type),intent(in) :: dtset
2150 : : !arrays
2151 : : integer,intent(in) :: ffttomix(nfft*(1-nfftmix/nfft))
2152 : : integer,intent(in) :: mixtofft(nfftmix*(1-nfftmix/nfft)),ngfft(18)
2153 : : integer,intent(in) :: ngfftmix(18)
2154 : : real(dp),intent(in) :: dielar(7),qphon(3)
2155 : : real(dp), intent(in), target :: rhor(cplex*nfft,dtset%nspden)
2156 : : real(dp),intent(in) :: rprimd(3,3)
2157 : : real(dp),intent(inout) :: vresid(cplex*nfft,dtset%nspden)
2158 : : real(dp),intent(inout) :: vtrial(cplex*nfft,dtset%nspden)
2159 : : type(pawrhoij_type),intent(inout) :: pawrhoij(my_natom*usepaw)
2160 : :
2161 : : !Local variables-------------------------------
2162 : : !scalars
2163 : : integer :: cplex_mix,cplex_rhoij,dplex,i_vresid1,i_vrespc1,iatom,ifft,indx,iq,iq0
2164 : : integer :: irhoij,ispden,jfft,jrhoij,klmn,kklmn,kmix,moved_atm_inside,nfftot,qphase
2165 : : integer :: mpicomm,errid
2166 : : logical :: mpi_summarize,reset
2167 : : real(dp) :: fact,mixfac,mixfac_eff,mixfacmag,ucvol
2168 : : character(len=500) :: msg
2169 : : !arrays
2170 : : real(dp) :: gmet(3,3),gprimd(3,3),rmet(3,3),tsec(2)
2171 : 13541 : real(dp),allocatable :: rhoijrespc(:),rhoijtmp(:,:)
2172 : 13541 : real(dp),allocatable :: vresid0(:,:),vrespc(:,:),vreswk(:,:)
2173 : 13541 : real(dp), pointer :: vtrial0(:,:),vpaw(:)
2174 : 13541 : real(dp),allocatable :: vtrialg(:,:,:)
2175 : : ! *************************************************************************
2176 : :
2177 : : DBG_ENTER("COLL")
2178 : :
2179 : 13541 : call timab(158,1,tsec)
2180 : :
2181 : : !Compatibility tests
2182 [ + + ]: 13541 : if(usepaw==1) then
2183 [ - + - - ]: 2439 : if(dtset%nspden==4.and.dtset%pawoptmix==1) then
2184 : 0 : ABI_ERROR('pawoptmix=1 is not compatible with nspden=4 !')
2185 : : end if
2186 [ + + ]: 2439 : if (my_natom>0) then
2187 [ - + ]: 2421 : if (pawrhoij(1)%qphase<cplex) then
2188 : 0 : ABI_ERROR('pawrhoij()%qphase must be >=cplex !')
2189 : : end if
2190 : : end if
2191 : : end if
2192 : :
2193 : 13541 : nfftot=ngfft(1)*ngfft(2)*ngfft(3)
2194 : 13541 : cplex_mix=max(cplex,ispmix)
2195 [ + + + + ]: 13541 : if (usepaw==1.and.my_natom>0) then
2196 : 2421 : cplex_rhoij=pawrhoij(1)%cplex_rhoij
2197 : 2421 : qphase=pawrhoij(1)%qphase
2198 : : end if
2199 : :
2200 : : !Compute different geometric tensor, as well as ucvol, from rprimd
2201 : 13541 : call metric(gmet,gprimd,-1,rmet,rprimd,ucvol)
2202 : 13541 : moved_atm_inside=0
2203 : :
2204 : : !Select components of potential to be mixed
2205 [ - + + - : 54164 : ABI_MALLOC(vtrial0,(cplex_mix*nfftmix,dtset%nspden))
- + + - +
- + - - +
- + ]
2206 [ - + + - : 40623 : ABI_MALLOC(vresid0,(cplex_mix*nfftmix,dtset%nspden))
- + + - -
+ - + ]
2207 [ + + + - ]: 13541 : if (ispmix==1.and.nfft==nfftmix) then
2208 [ + + + + : 283102714 : vtrial0=vtrial;vresid0=vresid
+ - - + -
- + + +
+ ]
2209 [ + + ]: 2439 : else if (nfft==nfftmix) then
2210 [ + + ]: 2406 : do ispden=1,dtset%nspden
2211 [ - + ]: 1203 : call fourdp(cplex,vtrial0(:,ispden),vtrial(:,ispden),-1,mpi_enreg,nfft,1, ngfft, 0)
2212 : 2406 : call fourdp(cplex,vresid0(:,ispden),vresid(:,ispden),-1,mpi_enreg,nfft,1, ngfft, 0)
2213 : : end do
2214 : : else
2215 [ - + + - : 4944 : ABI_MALLOC(vtrialg,(2,nfft,dtset%nspden))
- + + - +
- + - - +
- + ]
2216 [ - + + - : 3708 : ABI_MALLOC(vreswk,(2,nfft))
+ - + - -
+ + - ]
2217 [ + + ]: 2859 : do ispden=1,dtset%nspden
2218 [ + + ]: 1623 : fact=dielar(4);if (ispden>1) fact=dielar(7)
2219 : 1623 : call fourdp(cplex,vtrialg(:,:,ispden),vtrial(:,ispden),-1,mpi_enreg,nfft,1, ngfft, 0)
2220 : 1623 : call fourdp(cplex,vreswk,vresid(:,ispden),-1,mpi_enreg,nfft,1, ngfft, 0)
2221 [ + + ]: 32468731 : do ifft=1,nfft
2222 [ + + ]: 32467495 : if (ffttomix(ifft)>0) then
2223 : 10369934 : jfft=2*ffttomix(ifft)
2224 : 10369934 : vtrial0(jfft-1,ispden)=vtrialg(1,ifft,ispden)
2225 : 10369934 : vtrial0(jfft ,ispden)=vtrialg(2,ifft,ispden)
2226 : 10369934 : vresid0(jfft-1,ispden)=vreswk(1,ifft)
2227 : 10369934 : vresid0(jfft ,ispden)=vreswk(2,ifft)
2228 : : else
2229 [ + + ]: 66287814 : vtrialg(:,ifft,ispden)=vtrialg(:,ifft,ispden)+fact*vreswk(:,ifft)
2230 : : end if
2231 : : end do
2232 : : end do
2233 [ - + ]: 1236 : ABI_FREE(vreswk)
2234 : : end if
2235 : :
2236 : : !Precondition the potential residual:
2237 : : !Use a model dielectric function preconditioning, or simple mixing
2238 [ - + + - : 40623 : ABI_MALLOC(vrespc,(cplex_mix*nfftmix,dtset%nspden))
- + + - -
+ - + ]
2239 : 13541 : call moddiel(cplex_mix,dielar,mpi_enreg,nfftmix,ngfftmix,dtset%nspden,ispmix,0,qphon,rprimd,vresid0,vrespc)
2240 : :
2241 : : !PAW only : precondition the rhoij quantities (augmentation occupancies) residuals.
2242 : : !Use a simple preconditionning with the same mixing factor
2243 : : !as the model dielectric function.
2244 [ + + + + ]: 13541 : if (usepaw==1.and.my_natom>0) then
2245 [ - + + - : 7263 : ABI_MALLOC(rhoijrespc,(npawmix))
+ - + - -
+ - + ]
2246 : 2421 : mixfac=dielar(4);mixfacmag=abs(dielar(7))
2247 [ - + ]: 2421 : if (cplex_rhoij==1) then
2248 : : indx=0
2249 [ + + ]: 7393 : do iatom=1,my_natom
2250 [ + + ]: 12881 : do iq=1,qphase
2251 [ + + ]: 5488 : iq0=merge(0,cplex_rhoij*pawrhoij(iatom)%lmn2_size,iq==1)
2252 [ + + ]: 16722 : do ispden=1,pawrhoij(iatom)%nspden
2253 [ + + ]: 6262 : mixfac_eff=mixfac;if (ispden>1) mixfac_eff=mixfacmag
2254 [ + + ]: 250270 : do kmix=1,pawrhoij(iatom)%lmnmix_sz
2255 : 238520 : indx=indx+1;klmn=iq0+pawrhoij(iatom)%kpawmix(kmix)
2256 : 244782 : rhoijrespc(indx)=mixfac_eff*pawrhoij(iatom)%rhoijres(klmn,ispden)
2257 : : end do
2258 : : end do
2259 : : end do
2260 : : end do
2261 : : else
2262 : : indx=-1
2263 [ # # ]: 0 : do iatom=1,my_natom
2264 [ # # ]: 0 : do iq=1,qphase
2265 [ # # ]: 0 : iq0=merge(0,cplex_rhoij*pawrhoij(iatom)%lmn2_size,iq==1)
2266 [ # # ]: 0 : do ispden=1,pawrhoij(iatom)%nspden
2267 [ # # ]: 0 : mixfac_eff=mixfac;if (ispden>1) mixfac_eff=mixfacmag
2268 [ # # ]: 0 : do kmix=1,pawrhoij(iatom)%lmnmix_sz
2269 : 0 : indx=indx+2;klmn=iq0+2*pawrhoij(iatom)%kpawmix(kmix)-1
2270 [ # # ]: 0 : rhoijrespc(indx:indx+1)=mixfac_eff*pawrhoij(iatom)%rhoijres(klmn:klmn+1,ispden)
2271 : : end do
2272 : : end do
2273 : : end do
2274 : : end do
2275 : : end if
2276 : : end if
2277 : :
2278 : : !------Compute new vtrial
2279 : :
2280 : 13541 : i_vresid1=mix%i_vresid(1)
2281 : 13541 : i_vrespc1=mix%i_vrespc(1)
2282 : :
2283 : : !Initialise working arrays for the mixing object.
2284 : 13541 : call abi_mixing_eval_allocate(mix, istep)
2285 : :
2286 : : !Copy current step arrays.
2287 : 13541 : call abi_mixing_copy_current_step(mix, vresid0, errid, msg, arr_respc = vrespc)
2288 : :
2289 [ - + ]: 13541 : if (errid /= AB7_NO_ERROR) then
2290 : 0 : ABI_ERROR(msg)
2291 : : end if
2292 : :
2293 [ - + ]: 13541 : ABI_FREE(vrespc)
2294 [ - + ]: 13541 : ABI_FREE(vresid0)
2295 : :
2296 : : !PAW: either use the array f_paw or the array f_paw_disk
2297 [ + + + - : 40623 : ABI_MALLOC(vpaw,(npawmix*usepaw))
+ - + + -
+ - + ]
2298 [ + + + + ]: 13541 : if (usepaw==1.and.my_natom>0) then
2299 : 2421 : dplex=cplex_rhoij-1 ; indx=-dplex
2300 [ + + ]: 7393 : do iatom=1,my_natom
2301 [ - + + - : 14916 : ABI_MALLOC(rhoijtmp,(cplex_rhoij*pawrhoij(iatom)%lmn2_size,1))
+ - + - -
+ - + ]
2302 [ + + ]: 10460 : do iq=1,qphase
2303 [ + + ]: 5488 : iq0=merge(0,cplex_rhoij*pawrhoij(iatom)%lmn2_size,iq==1)
2304 [ + + ]: 16722 : do ispden=1,pawrhoij(iatom)%nspden
2305 [ + + + + ]: 251044 : rhoijtmp=zero ; jrhoij=iq0+1
2306 [ + + ]: 194459 : do irhoij=1,pawrhoij(iatom)%nrhoijsel
2307 : 188197 : klmn=cplex_rhoij*pawrhoij(iatom)%rhoijselect(irhoij)-dplex
2308 [ + + ]: 376394 : rhoijtmp(klmn:klmn+dplex,1)=pawrhoij(iatom)%rhoijp(jrhoij:jrhoij+dplex,ispden)
2309 : 194459 : jrhoij=jrhoij+cplex_rhoij
2310 : : end do
2311 [ + + ]: 250270 : do kmix=1,pawrhoij(iatom)%lmnmix_sz
2312 : 238520 : indx=indx+cplex_rhoij;klmn=cplex_rhoij*pawrhoij(iatom)%kpawmix(kmix)-dplex ; kklmn=iq0+klmn
2313 [ + + ]: 477040 : vpaw(indx:indx+dplex)=rhoijtmp(klmn:klmn+dplex,1)-pawrhoij(iatom)%rhoijres(kklmn:kklmn+dplex,ispden)
2314 [ + + ]: 477040 : mix%f_paw(indx:indx+dplex,i_vresid1)=pawrhoij(iatom)%rhoijres(kklmn:kklmn+dplex,ispden)
2315 [ + + ]: 483302 : mix%f_paw(indx:indx+dplex,i_vrespc1)=rhoijrespc(indx:indx+dplex)
2316 : : end do
2317 : : end do
2318 : : end do
2319 [ - + ]: 7393 : ABI_FREE(rhoijtmp)
2320 : : end do
2321 : : end if
2322 : :
2323 : : !Unlike for GS, no need to modify the mean of vtrial
2324 : :
2325 : 13541 : mpicomm=0;mpi_summarize=.false.
2326 [ + + ]: 13541 : reset=.false.;if (initialized==0) reset=.true.
2327 : : call abi_mixing_eval(mix, vtrial0, istep, nfftot, ucvol, &
2328 : : & mpicomm, mpi_summarize, errid, msg, &
2329 : : & reset = reset, isecur = dtset%isecur, &
2330 : : & pawopt = dtset%pawoptmix, response = 1, pawarr = vpaw, &
2331 [ - + - + ]: 13541 : & etotal = etotal, potden = rhor, comm_atom=mpi_enreg%comm_atom)
2332 : :
2333 [ - + ]: 13541 : if (errid == AB7_ERROR_MIXING_INC_NNSLOOP) then
2334 : 0 : dbl_nnsclo = 1
2335 [ - + ]: 13541 : else if (errid /= AB7_NO_ERROR) then
2336 : : ! MG FIXME, Why this?
2337 : : ! One should propagate the error so that we can handle it
2338 : : ! in the caller!
2339 : 0 : ABI_ERROR(msg)
2340 : : end if
2341 : :
2342 : : !Do here the mixing of the potential
2343 [ + - ]: 13541 : if(iscf==2 .or. iscf==3 .or. iscf==7)then
2344 : : ! PAW: restore rhoij from compact storage
2345 [ + + + + ]: 13541 : if (usepaw==1.and.my_natom>0) then
2346 : 2421 : dplex=cplex_rhoij-1 ; indx=-dplex
2347 [ + + ]: 7393 : do iatom=1,my_natom
2348 [ - + + - : 19888 : ABI_MALLOC(rhoijtmp,(cplex_rhoij*qphase*pawrhoij(iatom)%lmn2_size,pawrhoij(iatom)%nspden))
- + + - +
- + - - +
- + ]
2349 [ + + + + ]: 249226 : rhoijtmp=zero
2350 [ + + ]: 10460 : do iq=1,qphase
2351 [ + + ]: 5488 : iq0=merge(0,cplex_rhoij*pawrhoij(iatom)%lmn2_size,iq==1)
2352 [ - + ]: 5488 : if (pawrhoij(iatom)%lmnmix_sz<pawrhoij(iatom)%lmn2_size) then
2353 [ # # ]: 0 : do ispden=1,pawrhoij(iatom)%nspden
2354 : 0 : jrhoij=iq0+1
2355 [ # # ]: 0 : do irhoij=1,pawrhoij(iatom)%nrhoijsel
2356 : 0 : klmn=iq0+cplex_rhoij*pawrhoij(iatom)%rhoijselect(irhoij)-dplex
2357 [ # # ]: 0 : rhoijtmp(klmn:klmn+dplex,ispden)=pawrhoij(iatom)%rhoijp(jrhoij:jrhoij+dplex,ispden)
2358 : 0 : jrhoij=jrhoij+cplex_rhoij
2359 : : end do
2360 : : end do
2361 : : end if
2362 [ + + ]: 16722 : do ispden=1,pawrhoij(iatom)%nspden
2363 [ + + ]: 250270 : do kmix=1,pawrhoij(iatom)%lmnmix_sz
2364 : 238520 : indx=indx+cplex_rhoij;klmn=iq0+cplex_rhoij*pawrhoij(iatom)%kpawmix(kmix)-dplex
2365 [ + + ]: 483302 : rhoijtmp(klmn:klmn+dplex,ispden)=vpaw(indx:indx+dplex)
2366 : : end do
2367 : : end do
2368 : : end do
2369 : : call pawrhoij_filter(pawrhoij(iatom)%rhoijp,pawrhoij(iatom)%rhoijselect,&
2370 : : & pawrhoij(iatom)%nrhoijsel,pawrhoij(iatom)%cplex_rhoij,pawrhoij(iatom)%qphase,&
2371 : 4972 : & pawrhoij(iatom)%lmn2_size,pawrhoij(iatom)%nspden,rhoij_input=rhoijtmp)
2372 [ - + ]: 7393 : ABI_FREE(rhoijtmp)
2373 : : end do
2374 : : end if
2375 : :
2376 [ # # ]: 0 : else if(iscf==5 .or. iscf==6)then
2377 [ # # ]: 0 : if(ispmix/=1) then
2378 : 0 : ABI_ERROR('Mixing on reciprocal space not allowed with iscf=5 or 6.')
2379 : : end if
2380 : : ! PAW: apply a simple mixing to rhoij (this is temporary)
2381 [ # # # # ]: 0 : if (usepaw==1.and.my_natom>0) then
2382 : 0 : indx=1-cplex_rhoij
2383 [ # # ]: 0 : do iatom=1,my_natom
2384 [ # # # # : 0 : ABI_MALLOC(rhoijtmp,(cplex_rhoij*qphase*pawrhoij(iatom)%lmn2_size,pawrhoij(iatom)%nspden))
# # # # #
# # # # #
# # ]
2385 [ # # # # ]: 0 : rhoijtmp=zero
2386 [ # # ]: 0 : do iq=1,qphase
2387 [ # # ]: 0 : iq0=merge(0,cplex_rhoij*pawrhoij(iatom)%lmn2_size,iq==1)
2388 [ # # ]: 0 : if (pawrhoij(iatom)%lmnmix_sz<pawrhoij(iatom)%lmn2_size) then
2389 [ # # ]: 0 : do ispden=1,pawrhoij(iatom)%nspden
2390 [ # # ]: 0 : do kmix=1,pawrhoij(iatom)%lmnmix_sz
2391 : 0 : indx=indx+cplex_rhoij;klmn=iq0+cplex_rhoij*pawrhoij(iatom)%kpawmix(kmix)-dplex
2392 : : rhoijtmp(klmn:klmn+dplex,ispden)=rhoijrespc(indx:indx+dplex) &
2393 [ # # ]: 0 : & -pawrhoij(iatom)%rhoijres(klmn:klmn+dplex,ispden)
2394 : : end do
2395 : : end do
2396 : : end if
2397 [ # # ]: 0 : do ispden=1,pawrhoij(iatom)%nspden
2398 : 0 : jrhoij=iq0+1
2399 [ # # ]: 0 : do irhoij=1,pawrhoij(iatom)%nrhoijsel
2400 : 0 : klmn=iq0+cplex_rhoij*pawrhoij(iatom)%rhoijselect(irhoij)-dplex
2401 : : rhoijtmp(klmn:klmn+dplex,ispden)=rhoijtmp(klmn:klmn+dplex,ispden) &
2402 [ # # ]: 0 : & +pawrhoij(iatom)%rhoijp(jrhoij:jrhoij+dplex,ispden)
2403 : 0 : jrhoij=jrhoij+cplex_rhoij
2404 : : end do
2405 : : end do
2406 : : end do
2407 : : call pawrhoij_filter(pawrhoij(iatom)%rhoijp,pawrhoij(iatom)%rhoijselect,&
2408 : : & pawrhoij(iatom)%nrhoijsel,pawrhoij(iatom)%cplex_rhoij,pawrhoij(iatom)%qphase,&
2409 : 0 : & pawrhoij(iatom)%lmn2_size,pawrhoij(iatom)%nspden,rhoij_input=rhoijtmp)
2410 [ # # ]: 0 : ABI_FREE(rhoijtmp)
2411 : : end do
2412 : : end if
2413 : : end if
2414 : :
2415 [ - + ]: 13541 : ABI_FREE(vpaw)
2416 [ + + + + ]: 13541 : if (usepaw==1.and.my_natom>0) then
2417 [ - + ]: 2421 : ABI_FREE(rhoijrespc)
2418 : : end if
2419 : :
2420 : : !Eventually write the data on disk and deallocate f_fftgr_disk
2421 : 13541 : call abi_mixing_eval_deallocate(mix)
2422 : :
2423 : : !Restore potential
2424 [ + + + - ]: 13541 : if (ispmix==1.and.nfft==nfftmix) then
2425 [ + + + + ]: 141551357 : vtrial=vtrial0
2426 [ + + ]: 2439 : else if (nfft==nfftmix) then
2427 [ + + ]: 2406 : do ispden=1,dtset%nspden
2428 [ - + ]: 2406 : call fourdp(cplex,vtrial0(:,ispden),vtrial(:,ispden),+1,mpi_enreg,nfft,1, ngfft,0)
2429 : : end do
2430 : : else
2431 [ + + ]: 2859 : do ispden=1,dtset%nspden
2432 [ + + ]: 10371557 : do ifft=1,nfftmix
2433 : 10369934 : jfft=mixtofft(ifft)
2434 : 10369934 : vtrialg(1,jfft,ispden)=vtrial0(2*ifft-1,ispden)
2435 : 10371557 : vtrialg(2,jfft,ispden)=vtrial0(2*ifft ,ispden)
2436 : : end do
2437 : 2859 : call fourdp(cplex,vtrialg(:,:,ispden),vtrial(:,ispden),+1,mpi_enreg,nfft,1,ngfft,0)
2438 : : end do
2439 [ - + ]: 1236 : ABI_FREE(vtrialg)
2440 : : end if
2441 [ - + ]: 13541 : ABI_FREE(vtrial0)
2442 : :
2443 : 13541 : call timab(158,2,tsec)
2444 : :
2445 : : DBG_ENTER("COLL")
2446 : :
2447 [ - + - + ]: 40623 : end subroutine dfpt_newvtr
2448 : : !!***
2449 : :
2450 : : !!****f* ABINIT/dfpt_nselt
2451 : : !! NAME
2452 : : !! dfpt_nselt
2453 : : !!
2454 : : !! FUNCTION
2455 : : !! This routine compute the non-stationary expression for the
2456 : : !! second derivative of the total energy, wrt strain for a whole row of
2457 : : !! mixed strain derivatives.
2458 : : !!
2459 : : !! INPUTS
2460 : : !! cg(2,mpw*nspinor*mband_mem*mkmem*nsppol)=planewave coefficients of wavefunctions
2461 : : !! cg1(2,mpw1*nspinor*mband_mem*mk1mem*nsppol)=pw coefficients of RF wavefunctions at k,q.
2462 : : !! cplex: if 1, real space 1-order functions on FFT grid are REAL,
2463 : : !! if 2, COMPLEX
2464 : : !! ecut=cut-off energy for plane wave basis sphere (Ha)
2465 : : !! ecutsm=smearing energy for plane wave kinetic energy (Ha)
2466 : : !! effmass_free=effective mass for electrons (1. in common case)
2467 : : !! gmet(3,3)=reciprocal space metric tensor in bohr**-2.
2468 : : !! gprimd(3,3)=dimensional reciprocal space primitive translations
2469 : : !! gsqcut=cutoff on (k+G)^2 (bohr^-2)
2470 : : !! idir=direction of the perturbation
2471 : : !! ipert=type of the perturbation
2472 : : !! istwfk_rbz(nkpt_rbz)=input option parameter that describes the
2473 : : !! storage of wfs
2474 : : !! kg(3,mpw*mkmem)=reduced planewave coordinates.
2475 : : !! kg1(3,mpw1*mk1mem)=reduced planewave coordinates at k+q, with RF k points
2476 : : !! kpt_rbz(3,nkpt_rbz)=reduced coordinates of k points in the reduced BZ
2477 : : !! kxc(nfft,nkxc)=exchange and correlation kernel
2478 : : !! mband=maximum number of bands
2479 : : !! mband_mem=maximum number of bands on this cpu
2480 : : !! mgfft=maximum size of 1D FFTs
2481 : : !! mkmem =number of k points treated by this node.
2482 : : !! mk1mem =number of k points treated by this node (RF data).
2483 : : !! mpert =maximum number of ipert
2484 : : !! mpi_enreg=information about MPI parallelization
2485 : : !! mpsang= 1+maximum angular momentum for nonlocal pseudopotentials
2486 : : !! mpw=maximum dimensioned size of npw or wfs at k
2487 : : !! mpw1=maximum dimensioned size of npw for wfs at k+q (also for 1-order wfs).
2488 : : !! maximum dimension for q points in grids for nonlocal form factors
2489 : : !! natom=number of atoms in cell.
2490 : : !! nband_rbz(nkpt_rbz*nsppol)=number of bands at each RF k point for each spin
2491 : : !! nfft=(effective) number of FFT grid points (for this processor)
2492 : : !! ngfft(18)=contain all needed information about 3D FFT,
2493 : : !! see ~abinit/doc/variables/vargs.htm#ngfft
2494 : : !! nkpt_rbz=number of k points in the reduced BZ for this perturbation
2495 : : !! nkxc=second dimension of the kxc array. If /=0,
2496 : : !! the exchange-correlation kernel must be computed.
2497 : : !! nloalg(3)=governs the choice of the algorithm for non-local operator.
2498 : : !! npwarr(nkpt_rbz)=number of planewaves in basis at this GS k point
2499 : : !! npwar1(nkpt_rbz)=number of planewaves in basis at this RF k+q point
2500 : : !! nspden=number of spin-density components
2501 : : !! nspinor=number of spinorial components of the wavefunctions
2502 : : !! nsppol=1 for unpolarized, 2 for spin-polarized
2503 : : !! nsym1=number of symmetry elements in space group consistent with
2504 : : !! perturbation
2505 : : !! ntypat=number of types of atoms in unit cell.
2506 : : !! occ_rbz(mband*nkpt_rbz*nsppol)=occupation number for each band
2507 : : !! and k in the reduced Brillouin zone (usually =2)
2508 : : !! ph1d(2,3*(2*mgfft+1)*natom)=one-dimensional structure factor information
2509 : : !! prtbbb=if 1, band-by-band decomposition (also dim of d2bbb)
2510 : : !! psps <type(pseudopotential_type)>=variables related to pseudopotentials
2511 : : !! qphon(3)=reduced coordinates for the phonon wavelength
2512 : : !! rhog(2,nfft)=array for Fourier transform of GS electron density
2513 : : !! rhor(nfft,nspden)=GS electron density in electrons/bohr**3.
2514 : : !! rhor1(cplex*nfft,nspden)=RF electron density in electrons/bohr**3.
2515 : : !! rmet(3,3)=real space metric (bohr**2)
2516 : : !! rprimd(3,3)=dimensional primitive translations in real space (bohr)
2517 : : !! symrc1(3,3,nsym1)=symmetry operations in reciprocal space
2518 : : !! typat(natom)=type integer for each atom in cell
2519 : : !! ucvol=unit cell volume in bohr**3.
2520 : : !! wtk_rbz(nkpt_rbz)=weight assigned to each k point in the reduced BZ
2521 : : !! xred(3,natom)=reduced dimensionless atomic coordinates
2522 : : !! ylm(mpw*mkmem,mpsang*mpsang)= real spherical harmonics for each G and k point
2523 : : !! ylm1(mpw1*mk1mem,mpsang*mpsang)= real spherical harmonics for each G and k+q point
2524 : : !! ylmgr(mpw*mkmem,3,mpsang*mpsang*useylm)= gradients of real spherical for each G and k point
2525 : : !! ylmgr1(mpw1*mk1mem,3,mpsang*mpsang*useylm)= gradients of real spherical for each G and k+g point
2526 : : !! [rfstrs_ref]= if eq 1 the reference energy in vlocalstr is shited to the same valuea as in the FxE routines
2527 : : !!
2528 : : !! OUTPUT
2529 : : !! blkflg(3,mpert,3,mpert)=flags for each element of the 2DTE (=1 if computed)
2530 : : !! d2bbb(2,3,3,mpert,mband,mband*prtbbb)=band by band decomposition of some
2531 : : !! second order derivatives
2532 : : !! d2lo(2,3,mpert,3,mpert)=local contributions to the 2DTEs
2533 : : !! d2nl(2,3,mpert,3,mpert)=non-local contributions to the 2DTEs
2534 : : !!
2535 : : !! SOURCE
2536 : :
2537 : 96 : subroutine dfpt_nselt(blkflg,cg,cg1,cplex,&
2538 : 96 : & d2bbb,d2lo,d2nl,ecut,ecutsm,effmass_free,&
2539 : : & gmet,gprimd,gsqcut,idir,&
2540 : 96 : & ipert,istwfk_rbz,kg,kg1,kpt_rbz,kxc,mband,mband_mem,mgfft,&
2541 : : & mkmem,mk1mem,mpert,mpi_enreg,mpsang,mpw,mpw1,&
2542 : 96 : & natom,nband_rbz,nfft,ngfft,&
2543 : 96 : & nkpt_rbz,nkxc,nloalg,npwarr,npwar1,nspden,nspinor,nsppol,&
2544 : 96 : & nsym1,ntypat,occ_rbz,&
2545 : 96 : & ph1d,prtbbb,psps,qphon,rhog,&
2546 : 96 : & rhor,rhor1,rmet,rprimd,symrc1,typat,ucvol,&
2547 : 96 : & wtk_rbz,&
2548 : 96 : & xred,ylm,ylm1,ylmgr,ylmgr1,&
2549 : : & rfstrs_ref)
2550 : :
2551 : : !Arguments -------------------------------
2552 : : !scalars
2553 : : integer,intent(in) :: cplex,idir,ipert,mband,mgfft,mk1mem
2554 : : integer,intent(in) :: mband_mem
2555 : : integer,intent(in) :: mkmem,mpert,mpsang,mpw,mpw1,natom,nfft,nkpt_rbz
2556 : : integer,intent(in) :: nkxc,nspden,nspinor,nsppol,nsym1,ntypat
2557 : : integer,intent(in) :: prtbbb
2558 : : integer,intent(in),optional :: rfstrs_ref
2559 : : real(dp),intent(in) :: ecut,ecutsm,effmass_free,gsqcut,ucvol
2560 : : type(MPI_type),intent(in) :: mpi_enreg
2561 : : type(pseudopotential_type),intent(in) :: psps
2562 : : !arrays
2563 : : integer,intent(in) :: istwfk_rbz(nkpt_rbz)
2564 : : integer,intent(in) :: kg(3,mpw*mkmem),kg1(3,mpw1*mk1mem)
2565 : : integer,intent(in) :: nband_rbz(nkpt_rbz*nsppol),ngfft(18)
2566 : : integer,intent(in) :: nloalg(3),npwar1(nkpt_rbz),npwarr(nkpt_rbz)
2567 : : integer,intent(in) :: symrc1(3,3,nsym1),typat(natom)
2568 : : integer,intent(inout) :: blkflg(3,mpert,3,mpert)
2569 : : real(dp),intent(in) :: cg(2,mpw*nspinor*mband_mem*mkmem*nsppol)
2570 : : real(dp),intent(in) :: cg1(2,mpw1*nspinor*mband_mem*mk1mem*nsppol)
2571 : : real(dp),intent(in) :: gmet(3,3)
2572 : : real(dp),intent(in) :: gprimd(3,3),kpt_rbz(3,nkpt_rbz),kxc(nfft,nkxc)
2573 : : real(dp),intent(in) :: occ_rbz(mband*nkpt_rbz*nsppol)
2574 : : real(dp),intent(in) :: ph1d(2,3*(2*mgfft+1)*natom),qphon(3),rhog(2,nfft)
2575 : : real(dp),intent(in) :: rhor(nfft,nspden)
2576 : : real(dp),intent(in) :: rhor1(cplex*nfft,nspden),rmet(3,3),rprimd(3,3)
2577 : : real(dp),intent(in) :: wtk_rbz(nkpt_rbz),xred(3,natom)
2578 : : real(dp),intent(in) :: ylm(mpw*mkmem,mpsang*mpsang*psps%useylm)
2579 : : real(dp),intent(in) :: ylm1(mpw1*mk1mem,mpsang*mpsang*psps%useylm)
2580 : : real(dp),intent(in) :: ylmgr(mpw*mkmem,3,mpsang*mpsang*psps%useylm)
2581 : : real(dp),intent(in) :: ylmgr1(mpw1*mk1mem,3,mpsang*mpsang*psps%useylm)
2582 : : real(dp),intent(out) :: d2bbb(2,3,3,mpert,mband,mband*prtbbb)
2583 : : real(dp),intent(inout) :: d2lo(2,3,mpert,3,mpert)
2584 : : real(dp),intent(inout) :: d2nl(2,3,mpert,3,mpert)
2585 : :
2586 : : !Local variables-------------------------------
2587 : : !scalars
2588 : : integer :: ban2tot,bantot,bd2tot_index,bdtot_index,g0term
2589 : : integer :: icg,icg1,idir1,ifft,ii,ikg,ikg1,ikpt,comm
2590 : : integer :: ilm,ipert1,ispden,isppol,istr1,istwf_k
2591 : : integer :: mbd2kpsp,mbdkpsp,me,n1,n2,n3,n3xccc,n4,n5,n6
2592 : : integer :: nband_k,nfftot,npw1_k,npw_k,option,rfstrs_ref_
2593 : : logical :: nmxc=.false.
2594 : : real(dp) :: doti,dotr
2595 : : real(dp) :: wtk_k
2596 : : character(len=500) :: msg
2597 : 96 : type(gs_hamiltonian_type) :: gs_hamk
2598 : : !arrays
2599 : : integer :: ikpt_fbz(3)
2600 : 96 : integer,allocatable :: kg1_k(:,:),kg_k(:,:)
2601 : : real(dp) :: kpoint(3),restr(6),dummy(0,0)
2602 : 96 : real(dp),allocatable :: d2bbb_k(:,:,:,:),d2nl_k(:,:,:)
2603 : 96 : real(dp),allocatable :: occ_k(:)
2604 : 96 : real(dp),allocatable :: vhartr01(:),vpsp1(:),vxc1(:,:),xccc3d1(:),ylm1_k(:,:)
2605 : 96 : real(dp),allocatable :: ylm_k(:,:),ylmgr1_k(:,:,:),ylmgr_k(:,:,:)
2606 : 96 : type(pawtab_type) :: pawtab_dum(0)
2607 : : ! *********************************************************************
2608 : :
2609 : : ABI_NVTX_START_RANGE(NVTX_DFPT_NSELT)
2610 : : !Init me
2611 : 96 : comm = mpi_enreg%comm_cell
2612 : 96 : me = mpi_enreg%me_kpt
2613 : :
2614 : : !Zero only portion of nonlocal matrix to be computed here
2615 [ + + + + : 2016 : d2nl(:,:,natom+3:natom+4,idir,ipert)=zero
+ + ]
2616 : 96 : bdtot_index=0
2617 : 96 : bd2tot_index=0
2618 : 96 : icg=0
2619 : 96 : icg1=0
2620 : 96 : mbdkpsp=mband*nkpt_rbz*nsppol
2621 : 96 : mbd2kpsp=2*mband**2*nkpt_rbz*nsppol
2622 : :
2623 : : !Update list of computed matrix elements
2624 [ + + + - ]: 96 : if((ipert==natom+3) .or. (ipert==natom+4)) then
2625 : : ! Eventually expand when strain coupling to other perturbations is implemented
2626 [ + + ]: 288 : do ipert1=natom+3,natom+4
2627 [ + + ]: 864 : do idir1=1,3
2628 : 768 : blkflg(idir1,ipert1,idir,ipert)=1
2629 : : end do
2630 : : end do
2631 : : end if
2632 : :
2633 [ - + + - : 384 : ABI_MALLOC(d2bbb_k,(2,3,mband,mband*prtbbb))
+ - - - +
- - + - +
- + ]
2634 [ - + + - : 288 : ABI_MALLOC(d2nl_k,(2,3,mpert))
+ - + - -
+ - + ]
2635 : :
2636 [ - + + - : 288 : ABI_MALLOC(kg_k,(3,mpw))
+ - + - -
+ - + ]
2637 [ - + + - : 288 : ABI_MALLOC(kg1_k,(3,mpw1))
+ - + - -
+ - + ]
2638 : :
2639 : 96 : n1=ngfft(1) ; n2=ngfft(2) ; n3=ngfft(3)
2640 : 96 : n4=ngfft(4) ; n5=ngfft(5) ; n6=ngfft(6)
2641 : 96 : nfftot=n1*n2*n3
2642 : :
2643 : : !Initialize Hamiltonian (k-independent terms) - NCPP only
2644 : : call gs_hamk%init(psps,pawtab_dum,nspinor,nsppol,nspden,natom,&
2645 : 96 : & typat,xred,nfft,mgfft,ngfft,rprimd,nloalg,ph1d=ph1d)
2646 : :
2647 : 96 : bantot = 0
2648 : 96 : ban2tot = 0
2649 : :
2650 : : !LOOP OVER SPINS
2651 [ + + ]: 195 : do isppol=1,nsppol
2652 : :
2653 [ + + ]: 99 : if (nsppol/=1) then
2654 : 6 : write(msg,*)' **** In dfpt_nselt for isppol=',isppol
2655 : 6 : call wrtout(std_out,msg,'COLL')
2656 : : end if
2657 : :
2658 : 99 : ikg=0
2659 : 99 : ikg1=0
2660 : :
2661 : : ikpt_fbz(1:3)=0
2662 : :
2663 : : ! BIG FAT k POINT LOOP
2664 [ + + ]: 10307 : do ikpt=1,nkpt_rbz
2665 : :
2666 : 10112 : nband_k=nband_rbz(ikpt+(isppol-1)*nkpt_rbz)
2667 : 10112 : istwf_k=istwfk_rbz(ikpt)
2668 : 10112 : npw_k=npwarr(ikpt)
2669 : 10112 : npw1_k=npwar1(ikpt)
2670 [ + + ]: 40448 : kpoint(:)=kpt_rbz(:,ikpt)
2671 : :
2672 : 10112 : bantot = bantot + nband_k
2673 : 10112 : ban2tot = ban2tot + 2*nband_k**2
2674 : :
2675 : : ! asserts at least 1 band of the current k and spin is on present processor
2676 [ + - ]: 10112 : if(proc_distrb_cycle(mpi_enreg%proc_distrb,ikpt,1,nband_k,isppol,me)) then
2677 : : bdtot_index=bdtot_index+nband_k
2678 : : bd2tot_index=bd2tot_index+2*nband_k**2
2679 : : ! Skip the rest of the k-point loop
2680 : : cycle
2681 : : end if
2682 : :
2683 [ - + + - : 30336 : ABI_MALLOC(occ_k,(nband_k))
+ - + - -
+ - + ]
2684 : :
2685 [ - + + - : 40448 : ABI_MALLOC(ylm_k,(npw_k,mpsang*mpsang))
- + + - +
- + - - +
- + ]
2686 [ - + + - : 40448 : ABI_MALLOC(ylm1_k,(npw1_k,mpsang*mpsang))
- + + - +
- + - - +
- + ]
2687 [ + + + - ]: 10112 : if (ipert==natom+3.or.ipert==natom+4) then
2688 [ - + + - : 40448 : ABI_MALLOC(ylmgr_k,(npw_k,3,mpsang*mpsang))
- + + - +
- + - - +
- + - + ]
2689 [ - + + - : 40448 : ABI_MALLOC(ylmgr1_k,(npw1_k,3,mpsang*mpsang))
- + + - +
- + - - +
- + - + ]
2690 : : end if
2691 : :
2692 : : ! enl1_k(:)=zero
2693 [ + + + + : 908022 : d2nl_k(:,:,:)=zero
+ + ]
2694 [ - + - - : 10112 : if(prtbbb==1)d2bbb_k(:,:,:,:)=zero
- - - - -
- ]
2695 [ + + ]: 51218 : occ_k(:)=occ_rbz(1+bdtot_index:nband_k+bdtot_index)
2696 : :
2697 [ + + + + ]: 3546832 : kg_k(:,1:npw_k)=kg(:,1+ikg:npw_k+ikg)
2698 [ + + ]: 10112 : if (psps%useylm==1) then
2699 [ + + ]: 23040 : do ilm=1,mpsang*mpsang
2700 [ + + ]: 2071368 : ylm_k(1:npw_k,ilm)=ylm(1+ikg:npw_k+ikg,ilm)
2701 : : end do
2702 [ + + + - ]: 2304 : if (ipert==natom+3.or.ipert==natom+4) then
2703 [ + + ]: 23040 : do ilm=1,mpsang*mpsang
2704 [ + + ]: 85248 : do ii=1,3
2705 [ + + ]: 6227928 : ylmgr_k(1:npw_k,ii,ilm)=ylmgr(1+ikg:npw_k+ikg,ii,ilm)
2706 : : end do
2707 : : end do
2708 : : end if
2709 : : end if
2710 : :
2711 : 10112 : wtk_k=wtk_rbz(ikpt)
2712 : :
2713 [ + + + + ]: 3738856 : kg1_k(:,:) = 0
2714 : :
2715 [ + + + + ]: 3546832 : kg1_k(:,1:npw1_k)=kg1(:,1+ikg1:npw1_k+ikg1)
2716 [ + + ]: 10112 : if (psps%useylm==1) then
2717 [ + + ]: 23040 : do ilm=1,mpsang*mpsang
2718 [ + + ]: 2071368 : ylm1_k(1:npw1_k,ilm)=ylm1(1+ikg1:npw1_k+ikg1,ilm)
2719 : : end do
2720 [ + + + - ]: 2304 : if (ipert==natom+3.or.ipert==natom+4) then
2721 [ + + ]: 23040 : do ilm=1,mpsang*mpsang
2722 [ + + ]: 85248 : do ii=1,3
2723 [ + + ]: 6227928 : ylmgr1_k(1:npw1_k,ii,ilm)=ylmgr1(1+ikg1:npw1_k+ikg1,ii,ilm)
2724 : : end do
2725 : : end do
2726 : : end if
2727 : : end if
2728 : :
2729 : : ! Compute the eigenvalues, wavefunction,
2730 : : ! contributions to kinetic energy, nonlocal energy, forces,
2731 : : ! and update of rhor1 to this k-point and this spin polarization.
2732 : :
2733 : : ! Note that dfpt_nsteltwf is called with kpoint, while kpt is used inside dfpt_vtowfk
2734 : : call dfpt_nsteltwf(cg,cg1,d2nl_k,ecut,ecutsm,effmass_free,gs_hamk,icg,icg1,ikpt,isppol,&
2735 : : & istwf_k,kg_k,kg1_k,kpoint,mband,mband_mem,mkmem,mk1mem,mpert,mpi_enreg,mpw,mpw1,natom,nband_k,&
2736 : 10112 : & npw_k,npw1_k,nspinor,nsppol,ntypat,occ_k,psps,rmet,wtk_k,ylm_k,ylmgr_k)
2737 [ + + + + : 908022 : d2nl(:,:,:,idir,ipert)=d2nl(:,:,:,idir,ipert)+d2nl_k(:,:,:)
+ + ]
2738 [ - + ]: 10112 : if(prtbbb==1)then
2739 : : d2bbb(:,:,idir,ipert,:,:) = d2bbb(:,:,idir,ipert,:,:) + &
2740 [ # # # # : 0 : & d2bbb_k(:,:,:,:)
# # # # ]
2741 : : end if
2742 : :
2743 [ - + ]: 10112 : ABI_FREE(occ_k)
2744 : :
2745 : : ! Keep track of total number of bands (all k points so far, even for
2746 : : ! k points not treated by me)
2747 : 10112 : bdtot_index=bdtot_index+nband_k
2748 : 10112 : bd2tot_index=bd2tot_index+2*nband_k**2
2749 : :
2750 : : ! Shift array memory
2751 [ + - ]: 10112 : if (mkmem/=0) then
2752 : 10112 : icg=icg+npw_k*nspinor*proc_distrb_nband(mpi_enreg%proc_distrb,ikpt,nband_k,isppol,me)
2753 : 10112 : ikg=ikg+npw_k
2754 : : end if
2755 [ + - ]: 10112 : if (mk1mem/=0) then
2756 : 10112 : icg1=icg1+npw1_k*nspinor*proc_distrb_nband(mpi_enreg%proc_distrb,ikpt,nband_k,isppol,me)
2757 : 10112 : ikg1=ikg1+npw1_k
2758 : : end if
2759 [ - + ]: 10112 : ABI_FREE(ylm_k)
2760 [ - + ]: 10112 : ABI_FREE(ylm1_k)
2761 [ + + + - ]: 10211 : if (ipert==natom+3.or.ipert==natom+4) then
2762 [ - + ]: 10112 : ABI_FREE(ylmgr_k)
2763 [ - + ]: 10112 : ABI_FREE(ylmgr1_k)
2764 : : end if
2765 : :
2766 : : end do ! End big k point loop
2767 : : end do ! End loop over spins
2768 : :
2769 : : if(xmpi_paral==1)then
2770 : 96 : call xmpi_barrier(comm)
2771 : 96 : call wrtout(std_out,' dfpt_nselt: loop on k-points and spins done in parallel','COLL')
2772 : : end if
2773 : :
2774 : : !Treat now varying occupation numbers
2775 : : !if(occopt>=3 .and. occopt <=8) then
2776 : : !SUPPRESSED metallic coding of vtorho
2777 : :
2778 : : !Treat fixed occupation numbers
2779 : : !else
2780 : :
2781 : : !Accumulation over parallel processed now carried out for all terms
2782 : : !in dfpt_nstdy.f
2783 : :
2784 : : !End of test on varying or fixed occupation numbers
2785 : : !end if
2786 : :
2787 : : !The imaginary part of d2nl will be must be set to zero here since
2788 : : !time-reversal symmetry will always be true for the strain peturbation.
2789 : : !The symmetry-reduced kpt set will leave a non-zero imaginary part.
2790 : :
2791 [ + + + + ]: 864 : d2nl(2,:,natom+3:natom+4,idir,ipert)=zero
2792 : :
2793 : : !Symmetrize the non-local contributions,
2794 : : !as was needed for the stresses in a ground-state calculation
2795 : :
2796 [ + + ]: 96 : if (nsym1>1) then
2797 : : ! Pack like symmetric-storage cartesian stress tensor
2798 : 62 : ii=0
2799 [ + + ]: 186 : do ipert1=natom+3,natom+4
2800 [ + + ]: 558 : do idir1=1,3
2801 : 372 : ii=ii+1
2802 : 496 : restr(ii)=d2nl(1,idir1,ipert1,idir,ipert)
2803 : : end do
2804 : : end do
2805 : : ! Do the symmetrization using the ground state routine
2806 : 62 : call stresssym(gprimd,nsym1,restr,symrc1)
2807 : : ! Unpack symmetrized stress tensor
2808 : 62 : ii=0
2809 [ + + ]: 186 : do ipert1=natom+3,natom+4
2810 [ + + ]: 558 : do idir1=1,3
2811 : 372 : ii=ii+1
2812 : 496 : d2nl(1,idir1,ipert1,idir,ipert)=restr(ii)
2813 : : end do
2814 : : end do
2815 : : end if !nsym>1
2816 : :
2817 : : !----------------------------------------------------------------------------
2818 : : !Now, treat the local contribution
2819 : :
2820 [ - + + - : 288 : ABI_MALLOC(vpsp1,(cplex*nfft))
+ - + - -
+ - + ]
2821 : 96 : n3xccc=0
2822 [ + + ]: 96 : if(psps%n1xccc/=0)n3xccc=nfft
2823 [ + + + - : 288 : ABI_MALLOC(xccc3d1,(cplex*n3xccc))
+ - + + -
+ - + ]
2824 [ - + + - : 384 : ABI_MALLOC(vxc1,(cplex*nfft,nspden))
- + + - +
- + - - +
- + ]
2825 [ - + + - : 288 : ABI_MALLOC(vhartr01,(nfft))
+ - + - -
+ - + ]
2826 [ + + ]: 234066 : xccc3d1(:)=zero
2827 : :
2828 : : !To compute Absolute Deformation Potentials toghether with FxE tensor
2829 : : !the reference has to be the same as in the FxE routines
2830 [ - + ]: 96 : rfstrs_ref_=0; if (present(rfstrs_ref)) rfstrs_ref_=rfstrs_ref
2831 [ + + ]: 96 : g0term=0; if (rfstrs_ref_==1) g0term=1
2832 : :
2833 : : !Double loop over strain perturbations
2834 [ + + ]: 288 : do ipert1=natom+3,natom+4
2835 [ + + ]: 864 : do idir1=1,3
2836 [ + + ]: 576 : if(ipert1==natom+3) then
2837 : 288 : istr1=idir1
2838 : : else
2839 : 288 : istr1=idir1+3
2840 : : end if
2841 : :
2842 : : ! Get first-order local potential.
2843 : : call vlocalstr(gmet,gprimd,gsqcut,istr1,mgfft,mpi_enreg,&
2844 : : & psps%mqgrid_vl,natom,gs_hamk%nattyp,nfft,ngfft,ntypat,ph1d,psps%qgrid_vl,&
2845 : 576 : & ucvol,psps%vlspl,vpsp1,g0term=g0term)
2846 : :
2847 : : ! Get first-order hartree potential.
2848 : : call hartrestr(gsqcut,idir1,ipert1,mpi_enreg,natom,nfft,ngfft,&
2849 : 576 : & rhog,rprimd,vhartr01)
2850 : :
2851 : : ! Get first-order exchange-correlation potential
2852 [ + + ]: 576 : if(psps%n1xccc/=0)then
2853 : : call dfpt_mkcore(cplex,idir1,ipert1,natom,ntypat,n1,psps%n1xccc,&
2854 : 348 : & n2,n3,qphon,rprimd,typat,ucvol,psps%xcccrc,psps%xccc1d,xccc3d1,xred)
2855 : : end if ! psps%n1xccc/=0
2856 : :
2857 : 576 : option=0
2858 : : call dfpt_mkvxcstr(cplex,idir1,ipert1,kxc,mpi_enreg,natom,nfft,ngfft,&
2859 : : & dummy,dummy,nkxc,nmxc,nspden,n3xccc,option,qphon,rhor,rhor1,rprimd,&
2860 : 576 : & 0,0,vxc1,xccc3d1)
2861 : :
2862 : : ! Combines density j2 with local potential j1
2863 [ + + ]: 1170 : do ispden=1,min(nspden,2)
2864 [ + + ]: 2412978 : do ifft=1,cplex*nfft
2865 : 2412402 : vxc1(ifft,ispden)=vxc1(ifft,ispden)+vpsp1(ifft)+vhartr01(ifft)
2866 : : end do
2867 : : end do
2868 : 576 : call dotprod_vn(cplex,rhor1,dotr,doti,nfft,nfftot,nspden,2,vxc1,ucvol)
2869 : 576 : write(std_out,*)
2870 : 576 : d2lo(1,idir1,ipert1,idir,ipert)=dotr
2871 : 768 : d2lo(2,idir1,ipert1,idir,ipert)=doti
2872 : : end do ! istr1
2873 : : end do ! ipert1
2874 : :
2875 : 96 : call gs_hamk%free()
2876 : :
2877 [ - + ]: 96 : ABI_FREE(vxc1)
2878 [ - + ]: 96 : ABI_FREE(xccc3d1)
2879 [ - + ]: 96 : ABI_FREE(vhartr01)
2880 : :
2881 [ - + ]: 96 : ABI_FREE(d2bbb_k)
2882 [ - + ]: 96 : ABI_FREE(d2nl_k)
2883 [ - + ]: 96 : ABI_FREE(kg_k)
2884 [ - + ]: 96 : ABI_FREE(kg1_k)
2885 [ - + ]: 96 : ABI_FREE(vpsp1)
2886 : : ABI_NVTX_END_RANGE()
2887 : :
2888 [ - + - + : 96 : end subroutine dfpt_nselt
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + ]
2889 : : !!***
2890 : :
2891 : : !!****f* ABINIT/dfpt_nsteltwf
2892 : : !! NAME
2893 : : !! dfpt_nsteltwf
2894 : : !!
2895 : : !! FUNCTION
2896 : : !! This routine computes the non-local and kinetic contribution to the
2897 : : !! 2DTE matrix elements, in the non-stationary formulation
2898 : : !!
2899 : : !! INPUTS
2900 : : !! cg(2,mpw*nspinor*mband_mem*mkmem*nsppol)=planewave coefficients of wavefunctions
2901 : : !! cg1(2,mpw1*nspinor*mband_mem*mk1mem*nsppol)=pw coefficients of RF
2902 : : !! wavefunctions at k,q.
2903 : : !! ecut=cut-off energy for plane wave basis sphere (Ha)
2904 : : !! ecutsm=smearing energy for plane wave kinetic energy (Ha) (NOT NEEDED !)
2905 : : !! effmass_free=effective mass for electrons (1. in common case)
2906 : : !! gs_hamk <type(gs_hamiltonian_type)>=all data for the Hamiltonian at k
2907 : : !! icg=shift to be applied on the location of data in the array cg
2908 : : !! icg1=shift to be applied on the location of data in the array cg1
2909 : : !! ikpt=number of the k-point
2910 : : !! isppol=1 for unpolarized, 2 for spin-polarized
2911 : : !! istwf_k=flag controlling the storage of WFs
2912 : : !! kg_k(3,npw_k)=reduced planewave coordinates.
2913 : : !! kg1_k(3,npw1_k)=reduced planewave coordinates at k+q, with RF k points
2914 : : !! kpoint(3)=k-point in reduced coordinates
2915 : : !! mband=maximum number of bands
2916 : : !! mband_mem=maximum number of bands on this cpu
2917 : : !! mkmem =number of k points treated by this node.
2918 : : !! mk1mem =number of k points treated by this node (RF data).
2919 : : !! mpert =maximum number of ipert
2920 : : !! mpi_enreg=information about MPI parallelization
2921 : : !! mpw=maximum dimensioned size of npw or wfs at k
2922 : : !! mpw1=maximum dimensioned size of npw for wfs at k+q (also for 1-order wfs).
2923 : : !! natom=number of atoms in cell.
2924 : : !! nband_k=number of bands at this k point for that spin polarization
2925 : : !! npw_k=number of plane waves at this k point
2926 : : !! npw1_k=number of plane waves at this k+q point
2927 : : !! nspinor=number of spinorial components of the wavefunctions
2928 : : !! nsppol=1 for unpolarized, 2 for spin-polarized
2929 : : !! ntypat=number of types of atoms in unit cell.
2930 : : !! occ_k(nband_k)=occupation number for each band (usually 2) for each k.
2931 : : !! psps <type(pseudopotential_type)>=variables related to pseudopotentials
2932 : : !! rmet(3,3)=real space metric (bohr**2)
2933 : : !! wtk_k=weight assigned to the k point.
2934 : : !! ylm(npw_k,mpsang*mpsang)= real spherical harmonics for each G and k point
2935 : : !! ylmgr(npw_k,3,mpsang*mpsang*useylm)= gradients of real spherical for each G and k point
2936 : : !!
2937 : : !! OUTPUT
2938 : : !! d2nl_k(2,3,mpert)=non-local contributions to
2939 : : !! non-stationary 2DTE, for the present k point, and perturbation idir, ipert
2940 : : !!
2941 : : !! SOURCE
2942 : :
2943 : 10112 : subroutine dfpt_nsteltwf(cg,cg1,d2nl_k,ecut,ecutsm,effmass_free,gs_hamk,icg,icg1,ikpt,isppol,&
2944 : 10112 : & istwf_k,kg_k,kg1_k,kpoint,mband,mband_mem,mkmem,mk1mem,mpert,mpi_enreg,mpw,mpw1,natom,nband_k,&
2945 : 10112 : & npw_k,npw1_k,nspinor,nsppol,ntypat,occ_k,psps,rmet,wtk_k,ylm,ylmgr)
2946 : :
2947 : :
2948 : :
2949 : : !Arguments ------------------------------------
2950 : : !scalars
2951 : : integer,intent(in) :: icg,icg1,ikpt,isppol,istwf_k,mband,mk1mem,mkmem,mpert,mpw,mpw1,natom
2952 : : integer,intent(in) :: mband_mem
2953 : : integer,intent(in) :: nspinor,nsppol,ntypat
2954 : : integer,intent(inout) :: nband_k,npw1_k,npw_k
2955 : : real(dp),intent(in) :: ecut,ecutsm,effmass_free,wtk_k
2956 : : type(MPI_type),intent(in) :: mpi_enreg
2957 : : type(pseudopotential_type),intent(in) :: psps
2958 : : !arrays
2959 : : integer,intent(in) :: kg1_k(3,npw1_k),kg_k(3,npw_k)
2960 : : real(dp),intent(in) :: kpoint(3)
2961 : : real(dp),intent(in) :: cg(2,mpw*nspinor*mband_mem*mkmem*nsppol)
2962 : : real(dp),intent(in) :: cg1(2,mpw1*nspinor*mband_mem*mk1mem*nsppol)
2963 : : real(dp),intent(in) :: occ_k(nband_k),rmet(3,3)
2964 : : real(dp),intent(in) :: ylm(npw_k,psps%mpsang*psps%mpsang)
2965 : : real(dp),intent(in) :: ylmgr(npw_k,3,psps%mpsang*psps%mpsang)
2966 : : real(dp),intent(inout) :: d2nl_k(2,3,mpert)
2967 : :
2968 : : !Local variables-------------------------------
2969 : : !scalars
2970 : : integer :: choice,cpopt,dimffnl,dimffnl2,iband
2971 : : integer :: iband_me
2972 : : integer :: ider,idir0,idir1,ilmn,ipert1,ipw,ipws,ispinor,istr1,itypat
2973 : : integer :: nkpg,nnlout,paw_opt,signs,tim_nonlop
2974 : : real(dp) :: doti,dotr
2975 : : type(gs_hamiltonian_type) :: gs_hamk
2976 : : !arrays
2977 : : real(dp) :: enlout(6),dum_svectout(1,1),dum(1),kpg_dum(0,0)
2978 : 10112 : real(dp),allocatable :: cwave0(:,:),cwavef(:,:),dkinpw(:),eig2_k(:)
2979 : 10112 : real(dp),allocatable :: ffnl(:,:,:,:),ffnl_ylm(:,:,:,:),ghc(:,:)
2980 : 10112 : real(dp),allocatable :: gvnlx1(:,:),gvnlxc(:,:),kinpw1(:),ph3d(:,:,:)
2981 : 10112 : type(pawcprj_type) :: cprj_dum(0,0)
2982 : : ! *********************************************************************
2983 : :
2984 : : !Init me
2985 [ - + + - : 30336 : ABI_MALLOC(ghc,(2,npw1_k*nspinor))
+ - + - -
+ - + ]
2986 [ - + + - : 20224 : ABI_MALLOC(gvnlxc,(2,npw1_k*nspinor))
- + - + ]
2987 [ - + + - : 20224 : ABI_MALLOC(gvnlx1,(2,npw1_k*nspinor))
- + - + ]
2988 [ + - - + : 30336 : ABI_MALLOC(eig2_k,(2*nsppol*mband**2))
+ - + - +
- - + -
+ ]
2989 [ - + + - : 30336 : ABI_MALLOC(kinpw1,(npw1_k))
+ - + - -
+ - + ]
2990 [ - + + - : 30336 : ABI_MALLOC(dkinpw,(npw_k))
+ - + - -
+ - + ]
2991 : 10112 : nkpg=0
2992 : :
2993 : : !Compute nonlocal form factors ffnl at (k+G), for all atoms
2994 : 10112 : dimffnl=2
2995 [ - + + - : 60672 : ABI_MALLOC(ffnl,(npw_k,dimffnl,psps%lmnmax,ntypat))
+ - - + +
- - + + -
+ - + - -
+ - + ]
2996 [ + + ]: 10112 : if (psps%useylm==0) then
2997 : 7808 : ider=1;idir0=0
2998 : : call mkffnl(psps%dimekb,dimffnl,psps%ekb,ffnl,psps%ffspl,gs_hamk%gmet,gs_hamk%gprimd,ider,idir0,&
2999 : : & psps%indlmn,kg_k,kpg_dum,kpoint,psps%lmnmax,psps%lnmax,psps%mpsang,psps%mqgrid_ff,nkpg,&
3000 : 7808 : & npw_k,ntypat,psps%pspso,psps%qgrid_ff,rmet,psps%usepaw,psps%useylm,ylm,ylmgr)
3001 : : else
3002 : 2304 : ider=1;idir0=-7;dimffnl2=7
3003 [ - + + - : 13824 : ABI_MALLOC(ffnl_ylm,(npw_k,dimffnl2,psps%lmnmax,ntypat))
+ - - + +
- - + + -
+ - + - -
+ - + ]
3004 : : call mkffnl(psps%dimekb,dimffnl2,psps%ekb,ffnl_ylm,psps%ffspl,gs_hamk%gmet,gs_hamk%gprimd,&
3005 : : & ider,idir0,psps%indlmn,kg_k,kpg_dum,kpoint,psps%lmnmax,psps%lnmax,psps%mpsang,psps%mqgrid_ff,&
3006 : 2304 : & nkpg,npw_k,ntypat,psps%pspso,psps%qgrid_ff,rmet,psps%usepaw,psps%useylm,ylm,ylmgr)
3007 [ + + ]: 4608 : do itypat=1,ntypat
3008 [ + + ]: 32256 : do ilmn=1,psps%lmnmax
3009 [ + + ]: 2761056 : ffnl(:,1,ilmn,itypat)=ffnl_ylm(:,1,ilmn,itypat)
3010 : : end do
3011 : : end do
3012 : : end if
3013 : :
3014 : : !Compute kinetic contributions (1/2) (2 Pi)**2 (k+G)**2:
3015 : 10112 : call mkkin(ecut,ecutsm,effmass_free,gs_hamk%gmet,kg1_k,kinpw1,kpoint,npw1_k,0,0)
3016 : :
3017 : : !Load k/k+q-dependent part in the Hamiltonian datastructure
3018 [ - + + - : 40448 : ABI_MALLOC(ph3d,(2,npw_k,gs_hamk%matblk))
- + + - +
- + - - +
- + - + ]
3019 : : call gs_hamk%load_k(kpt_k=kpoint,npw_k=npw_k,istwf_k=istwf_k,kg_k=kg_k,ffnl_k=ffnl,&
3020 : 10112 : ph3d_k=ph3d,compute_ph3d=.true.)
3021 : :
3022 [ - + + - : 30336 : ABI_MALLOC(cwave0,(2,npw_k*nspinor))
+ - + - -
+ - + -
+ ]
3023 [ - + + - : 30336 : ABI_MALLOC(cwavef,(2,npw1_k*nspinor))
+ - + - -
+ - + ]
3024 : :
3025 : : !Loop over bands
3026 : 10112 : iband_me = 0
3027 [ + + ]: 51218 : do iband=1,nband_k
3028 : :
3029 [ + - ]: 41106 : if(mpi_enreg%proc_distrb(ikpt, iband, isppol) /= mpi_enreg%me_kpt) then
3030 : : ! Skip the eigenvalue and the gvnl records of this band
3031 : : cycle
3032 : : end if
3033 : 41106 : iband_me = iband_me + 1
3034 : :
3035 : : ! Get ground-state and first-order wavefunctions
3036 [ + + + + ]: 11303586 : cwave0(:,:)=cg(:,1+(iband_me-1)*npw_k*nspinor+icg:iband_me*npw_k*nspinor+icg)
3037 [ + + + + ]: 11303586 : cwavef(:,:)=cg1(:,1+(iband_me-1)*npw1_k*nspinor+icg1:iband_me*npw1_k*nspinor+icg1)
3038 : :
3039 : : ! Double loop over strain perturbations
3040 [ + + ]: 133430 : do ipert1=natom+3,natom+4
3041 [ + + ]: 369954 : do idir1=1,3
3042 [ + + ]: 246636 : if (ipert1==natom+3) istr1=idir1
3043 [ + + ]: 246636 : if (ipert1==natom+4) istr1=idir1+3
3044 : :
3045 : : ! Compute the derivative of the kinetic operator vs strain in dkinpw
3046 : : call kpgstr(dkinpw,ecut,ecutsm,effmass_free,gs_hamk%gmet,gs_hamk%gprimd,istr1,&
3047 : 246636 : & kg1_k,kpoint,npw1_k)
3048 : :
3049 : : ! Get |vnon-locj1|u0> :
3050 : : ! first-order non-local, applied to zero-order wavefunction
3051 : : ! (??) this routine gives MINUS the non-local contribution
3052 : :
3053 : : ! When using Ylms, load the correct ffnl derivative
3054 [ + + ]: 246636 : if (psps%useylm==1) then
3055 [ + + ]: 110592 : do itypat=1,ntypat
3056 [ + + ]: 774144 : do ilmn=1,psps%lmnmax
3057 [ + + ]: 66265344 : ffnl(:,2,ilmn,itypat)=ffnl_ylm(:,1+istr1,ilmn,itypat)
3058 : : end do
3059 : : end do
3060 : : end if
3061 : :
3062 : 246636 : signs=2 ; choice=3 ; nnlout=6 ; paw_opt=0 ; cpopt=-1 ; tim_nonlop=5
3063 : : call nonlop(choice,cpopt,cprj_dum,enlout,gs_hamk,istr1,dum,mpi_enreg,1,nnlout,paw_opt,&
3064 : 246636 : & signs,dum_svectout,tim_nonlop,cwave0,gvnlx1)
3065 : : ! <G|Vnl1|Cnk> is contained in gvnlx1
3066 : :
3067 : : ! Kinetic contribution
3068 [ + + ]: 493272 : do ispinor=1,nspinor
3069 [ + + ]: 23018232 : do ipw=1,npw1_k
3070 : 22524960 : ipws=ipw+npw1_k*(ispinor-1)
3071 [ + - ]: 22771596 : if(kinpw1(ipw)<huge(zero)*1.d-11)then
3072 : 22524960 : gvnlx1(1,ipws)=gvnlx1(1,ipws)+dkinpw(ipw)*cwave0(1,ipws)
3073 : 22524960 : gvnlx1(2,ipws)=gvnlx1(2,ipws)+dkinpw(ipw)*cwave0(2,ipws)
3074 : : else
3075 : 0 : gvnlx1(1,ipws)=0.0_dp
3076 : 0 : gvnlx1(2,ipws)=0.0_dp
3077 : : end if
3078 : : end do
3079 : : end do
3080 : :
3081 : : ! construct the matrix element (<uj2|vj1|u0>)complex conjug.
3082 : : ! and add it to the 2nd-order matrix
3083 : : ! imaginary term should be zero for strain-strain 2nd derivatives,
3084 : : ! but keep it as a test for now
3085 : : call dotprod_g(dotr,doti,gs_hamk%istwf_k,npw1_k*nspinor,2,cwavef,gvnlx1,&
3086 : 246636 : & mpi_enreg%me_g0,mpi_enreg%comm_spinorfft)
3087 : :
3088 : 246636 : d2nl_k(1,idir1,ipert1)= d2nl_k(1,idir1,ipert1)+wtk_k*occ_k(iband)*2.0_dp*dotr
3089 : 328848 : d2nl_k(2,idir1,ipert1)= d2nl_k(2,idir1,ipert1)-wtk_k*occ_k(iband)*2.0_dp*doti
3090 : :
3091 : : end do !idir1
3092 : : end do !ipert1
3093 : :
3094 : : ! UNTIL NOW, DO NOT TAKE INTO ACCOUNT istwf_k
3095 : : end do ! End loop over bands
3096 : :
3097 [ - + ]: 10112 : ABI_FREE(cwave0)
3098 [ - + ]: 10112 : ABI_FREE(cwavef)
3099 : :
3100 : : !###################################################################
3101 : :
3102 [ - + ]: 10112 : ABI_FREE(eig2_k)
3103 [ - + ]: 10112 : ABI_FREE(ghc)
3104 [ - + ]: 10112 : ABI_FREE(gvnlxc)
3105 [ - + ]: 10112 : ABI_FREE(gvnlx1)
3106 [ - + ]: 10112 : ABI_FREE(kinpw1)
3107 [ - + ]: 10112 : ABI_FREE(dkinpw)
3108 [ - + ]: 10112 : ABI_FREE(ffnl)
3109 [ - + ]: 10112 : ABI_FREE(ph3d)
3110 [ + + ]: 10112 : ABI_SFREE(ffnl_ylm)
3111 : :
3112 [ - + - + : 10112 : end subroutine dfpt_nsteltwf
- + ]
3113 : : !!***
3114 : :
3115 : : !!****f* ABINIT/dfpt_nstdy
3116 : : !! NAME
3117 : : !! dfpt_nstdy
3118 : : !!
3119 : : !! FUNCTION
3120 : : !! This routine compute the non-stationary expression for the
3121 : : !! second derivative of the total energy, for a whole row of
3122 : : !! mixed derivatives.
3123 : : !! Only for norm-conserving pseudopotentials (no PAW)
3124 : : !!
3125 : : !! INPUTS
3126 : : !! atindx(natom)=index table for atoms (see gstate.f)
3127 : : !! cg(2,mpw*nspinor*mband_mem*mkmem*nsppol)=planewave coefficients of wavefunctions at k
3128 : : !! cg1(2,mpw1*nspinor*mband_mem*mk1mem*nsppol)=pw coefficients of RF wavefunctions at k,q.
3129 : : !! cplex: if 1, real space 1-order functions on FFT grid are REAL, if 2, COMPLEX
3130 : : !! dtfil <type(datafiles_type)>=variables related to files
3131 : : !! dtset <type(dataset_type)>=all input variables for this dataset
3132 : : !! eigen0(mband*nkpt_rbz*nsppol)=GS eigenvalues at k (hartree)
3133 : : !! eigen1(2*mband*mband*nkpt_rbz*nsppol)=array for holding eigenvalues
3134 : : !! gmet(3,3)=reciprocal space metric tensor in bohr**-2.
3135 : : !! gsqcut=cutoff on (k+G)^2 (bohr^-2)
3136 : : !! idir=direction of the perturbation
3137 : : !! indkpt1(nkpt_rbz)=non-symmetrized indices of the k-points
3138 : : !! indsy1(4,nsym1,natom)=indirect indexing array for atom labels
3139 : : !! ipert=type of the perturbation
3140 : : !! istwfk_rbz(nkpt_rbz)=input option parameter that describes the storage of wfs
3141 : : !! kg(3,mpw*mkmem)=reduced planewave coordinates.
3142 : : !! kg1(3,mpw1*mk1mem)=reduced planewave coordinates at k+q, with RF k points
3143 : : !! kpt_rbz(3,nkpt_rbz)=reduced coordinates of k points in the reduced BZ
3144 : : !! kxc(nfft,nkxc)=exchange and correlation kernel
3145 : : !! mkmem =number of k points treated by this node (GS data)
3146 : : !! mk1mem =number of k points treated by this node (RF data)
3147 : : !! mpert =maximum number of ipert
3148 : : !! mpi_enreg=information about MPI parallelization
3149 : : !! mpw=maximum dimensioned size of npw or wfs at k
3150 : : !! mpw1=maximum dimensioned size of npw for wfs at k+q (also for 1-order wfs).
3151 : : !! nattyp(ntypat)= # atoms of each type.
3152 : : !! nband_rbz(nkpt_rbz*nsppol)=number of bands at each RF k point for each spin
3153 : : !! nfft=(effective) number of FFT grid points (for this proc)
3154 : : !! ngfft(1:18)=integer array with FFT box dimensions and other
3155 : : !! nkpt=number of k points in the full BZ
3156 : : !! nkpt_rbz=number of k points in the reduced BZ for this perturbation
3157 : : !! nkxc=second dimension of the kxc array. If /=0, the XC kernel must be computed.
3158 : : !! npwarr(nkpt_rbz)=number of planewaves in basis at this GS k point
3159 : : !! npwar1(nkpt_rbz)=number of planewaves in basis at this RF k+q point
3160 : : !! nspden=number of spin-density components
3161 : : !! nsppol=1 for unpolarized, 2 for spin-polarized
3162 : : !! nsym1=number of symmetry elements in space group consistent with i perturbation
3163 : : !! occ_rbz(mband*nkpt_rbz*nsppol)=occupation number for each band
3164 : : !! and k in the reduced Brillouin zone (usually =2)
3165 : : !! ph1d(2,3*(2*mgfft+1)*natom)=one-dimensional structure factor information
3166 : : !! psps <type(pseudopotential_type)>=variables related to pseudopotentials
3167 : : !! qphon(3)=reduced coordinates for the phonon wavelength
3168 : : !! rhor1(cplex*nfft,nspden)=RF electron density in electrons/bohr**3.
3169 : : !! rmet(3,3)=real space metric (bohr**2)
3170 : : !! rprimd(3,3)=dimensional primitive translations in real space (bohr)
3171 : : !! symrc1(3,3,nsym1)=symmetry operations in reciprocal space
3172 : : !! ucvol=unit cell volume in bohr**3.
3173 : : !! wtk_rbz(nkpt_rbz)=weight assigned to each k point in the reduced BZ
3174 : : !! xred(3,natom)=reduced dimensionless atomic coordinates
3175 : : !! ylm(mpw*mkmem,mpsang*mpsang*useylm)= real spherical harmonics for each G and k point
3176 : : !! ylm1(mpw1*mk1mem,mpsang*mpsang*useylm)= real spherical harmonics for each G and k+q point
3177 : : !!
3178 : : !! OUTPUT
3179 : : !! blkflg(3,mpert,3,mpert)=flags for each element of the 2DTE (=1 if computed)
3180 : : !! d2bbb(2,3,3,mpert,mband,mband*prtbbb)=band by band decomposition of some
3181 : : !! second order derivatives
3182 : : !! d2lo(2,3,mpert,3,mpert)=local contributions to the 2DTEs
3183 : : !! d2nl(2,3,mpert,3,mpert)=non-local contributions to the 2DTEs
3184 : : !!
3185 : : !! NOTES
3186 : : !! Note that the ddk perturbation should not be treated here.
3187 : : !!
3188 : : !! SOURCE
3189 : :
3190 : 1827 : subroutine dfpt_nstdy(atindx,blkflg,cg,cg1,cplex,dtfil,dtset,d2bbb,d2lo,d2nl,eigen0,eigen1,&
3191 : 1827 : & gmet,gsqcut,idir,indkpt1,indsy1,ipert,istwfk_rbz,kg,kg1,kpt_rbz,kxc,mband_mem_rbz,mkmem,mk1mem,&
3192 : 1827 : & mpert,mpi_enreg,mpw,mpw1,nattyp,nband_rbz,nfft,ngfft,nkpt,nkpt_rbz,nkxc,&
3193 : 1827 : & npwarr,npwar1,nspden,nsppol,nsym1,occ_rbz,ph1d,psps,qphon,rhor1,rmet,rprimd,&
3194 : 1827 : & symrc1,ucvol,wtk_rbz,xred,ylm,ylm1,rhor,vxc,ixcrot)
3195 : :
3196 : : !Arguments -------------------------------
3197 : : !scalars
3198 : : integer,intent(in) :: cplex,idir,ipert,mk1mem,mkmem,mpert,mpw,mpw1,nfft,nkpt,nkpt_rbz,nkxc,nspden,nsppol,nsym1
3199 : : integer,intent(in) :: mband_mem_rbz
3200 : : real(dp),intent(in) :: gsqcut,ucvol
3201 : : type(MPI_type),intent(in) :: mpi_enreg
3202 : : type(datafiles_type),intent(in) :: dtfil
3203 : : type(dataset_type),intent(in) :: dtset
3204 : : type(pseudopotential_type),intent(in) :: psps
3205 : : !optional
3206 : : integer,optional,intent(in) :: ixcrot
3207 : : !arrays
3208 : : integer,intent(in) :: atindx(dtset%natom),indkpt1(nkpt_rbz),indsy1(4,nsym1,dtset%natom)
3209 : : integer,intent(in) :: istwfk_rbz(nkpt_rbz),kg(3,mpw*mkmem),kg1(3,mpw1*mk1mem)
3210 : : integer,intent(in) :: nattyp(dtset%ntypat),nband_rbz(nkpt_rbz*nsppol),ngfft(18)
3211 : : integer,intent(in) :: npwar1(nkpt_rbz),npwarr(nkpt_rbz),symrc1(3,3,nsym1)
3212 : : integer,intent(inout) :: blkflg(3,mpert,3,mpert) !vz_i
3213 : : real(dp),intent(in) :: cg(2,mpw*dtset%nspinor*mband_mem_rbz*mkmem*nsppol)
3214 : : real(dp),intent(in) :: cg1(2,mpw1*dtset%nspinor*mband_mem_rbz*mk1mem*nsppol)
3215 : : real(dp),intent(in) :: eigen0(dtset%mband*nkpt_rbz*nsppol)
3216 : : real(dp),intent(in) :: eigen1(2*dtset%mband*dtset%mband*nkpt_rbz*nsppol)
3217 : : real(dp),intent(in) :: gmet(3,3),kpt_rbz(3,nkpt_rbz)
3218 : : real(dp),intent(in) :: kxc(nfft,nkxc),occ_rbz(dtset%mband*nkpt_rbz*nsppol)
3219 : : real(dp),intent(in) :: ph1d(2,3*(2*dtset%mgfft+1)*dtset%natom),qphon(3)
3220 : : real(dp),intent(in) :: rhor1(cplex*nfft,nspden),rmet(3,3),rprimd(3,3)
3221 : : real(dp),intent(in) :: wtk_rbz(nkpt_rbz),xred(3,dtset%natom)
3222 : : real(dp),intent(in) :: ylm(mpw*mkmem,psps%mpsang*psps%mpsang*psps%useylm)
3223 : : real(dp),intent(in) :: ylm1(mpw1*mk1mem,psps%mpsang*psps%mpsang*psps%useylm)
3224 : : real(dp),intent(inout) :: d2bbb(2,3,3,mpert,dtset%mband,dtset%mband*dtset%prtbbb)!vz_i
3225 : : real(dp),intent(inout) :: d2lo(2,3,mpert,3,mpert),d2nl(2,3,mpert,3,mpert) !vz_i
3226 : : ! optional
3227 : : real(dp),optional,intent(in) :: rhor(nfft,nspden)
3228 : : real(dp),optional,intent(in) :: vxc(nfft,nspden)
3229 : :
3230 : : !Local variables-------------------------------
3231 : : !scalars
3232 : : integer,parameter :: formeig1=1
3233 : : integer :: ban2tot,bantot,bdtot_index,ddkcase,iband,icg,icg1,idir1
3234 : : integer :: ierr,ifft,ii,ikg,ikg1,ikpt,ilm,ipert1,ispden,isppol
3235 : : integer :: istwf_k,isym,jj,master,me,n1,n2,n3,n3xccc,n4,n5,n6
3236 : : integer :: nband_k,nfftot,npw1_k,npw_k,nspinor_,option,spaceworld,optnc
3237 : : real(dp) :: doti,dotr,wtk_k
3238 : : logical :: nmxc=.false.,t_exist
3239 : : character(len=500) :: msg
3240 : : character(len=fnlen) :: fiwfddk
3241 : 1827 : type(gs_hamiltonian_type) :: gs_hamkq
3242 : : !arrays
3243 : : integer :: ddkfil(3)
3244 : 3654 : integer,allocatable :: kg1_k(:,:),kg_k(:,:),symrl1(:,:,:)
3245 : : real(dp) :: d2nl_elfd(2,3),d2nl_mgfd(2,3),kpoint(3),kpq(3),sumelfd(2),summgfd(2),tsec(2)
3246 : 1827 : real(dp),allocatable :: buffer1(:),buffer2(:),d2bbb_k(:,:,:,:),d2nl_k(:,:,:)
3247 : 1827 : real(dp),allocatable :: eig1_k(:),eig_k(:),occ_k(:)
3248 : : real(dp) :: rhodummy(0,0)
3249 : 1827 : real(dp),allocatable :: vpsp1(:),vxc1(:,:),work1(:,:,:),xccc3d1(:),ylm1_k(:,:),ylm_k(:,:)
3250 [ - + - + : 3654 : type(pawtab_type) :: pawtab(dtset%ntypat*psps%usepaw)
- + - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - ]
3251 [ + + + + : 179046 : type(wfk_t) :: ddks(3)
+ + + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - -
- - - - -
- - - - -
- - - + -
+ - + - ]
3252 : : ! *********************************************************************
3253 : :
3254 : : ABI_UNUSED(nkpt)
3255 : :
3256 : : DBG_ENTER("COLL")
3257 : :
3258 : : ABI_NVTX_START_RANGE(NVTX_DFPT_NSTDY)
3259 : :
3260 : : !Not valid for PAW
3261 [ - + ]: 1827 : if (psps%usepaw==1) then
3262 : 0 : ABI_BUG('This routine cannot be used for PAW (use dfpt_nstpaw instead) !')
3263 : : end if
3264 : :
3265 : : !Keep track of total time spent in dfpt_nstdy
3266 : 1827 : call timab(111,1,tsec)
3267 : :
3268 : : !Init parallelism
3269 : 1827 : spaceworld=mpi_enreg%comm_cell
3270 : 1827 : me=mpi_enreg%me_kpt
3271 : :
3272 : 1827 : master =0
3273 : :
3274 : : !Zero only portion of nonlocal matrix to be computed here
3275 [ + + + + : 77787 : d2nl(:,:,1:dtset%natom+2,idir,ipert)=zero
+ + ]
3276 : :
3277 [ - + + - : 7308 : ABI_MALLOC(d2bbb_k,(2,3,dtset%mband,dtset%mband*dtset%prtbbb))
+ + + - +
- + + - +
- + ]
3278 [ - + + - : 5481 : ABI_MALLOC(d2nl_k,(2,3,mpert))
+ - + - -
+ - + ]
3279 [ - + + - : 5481 : ABI_MALLOC(eig_k,(nsppol*dtset%mband))
+ - + - -
+ - + ]
3280 [ + - - + : 5481 : ABI_MALLOC(eig1_k,(2*nsppol*dtset%mband**2))
+ - + - +
- - + -
+ ]
3281 [ - + + - : 5481 : ABI_MALLOC(kg_k,(3,mpw))
+ - + - -
+ - + ]
3282 [ - + + - : 5481 : ABI_MALLOC(kg1_k,(3,mpw1))
+ - + - -
+ - + ]
3283 : :
3284 : : !Do not try to open electric field file
3285 : 1827 : ddkfil(:)=0
3286 : : !The treatment of homogeneous electric field potential need the existence of d/dk files.
3287 [ + + ]: 7308 : do idir1=1,3
3288 : 5481 : ddkcase=idir1+dtset%natom*3
3289 : 5481 : call appdig(ddkcase,dtfil%fnamewffddk,fiwfddk)
3290 : :
3291 : : ! Check that ddk file exists
3292 : 5481 : t_exist = file_exists(fiwfddk)
3293 [ + - ]: 5481 : if (.not. t_exist) then
3294 : : ! Try netcdf file.
3295 : 5481 : t_exist = file_exists(nctk_ncify(fiwfddk))
3296 [ + + ]: 5481 : if (t_exist) then
3297 : 1195 : fiwfddk = nctk_ncify(fiwfddk)
3298 : 1195 : write(msg,"(3a)")"- File: ",trim(fiwfddk)," does not exist but found netcdf file with similar name."
3299 : 1195 : call wrtout(std_out,msg,'COLL')
3300 : : end if
3301 : : end if
3302 : :
3303 : 1827 : if (t_exist) then
3304 : : ! Note the use of unit numbers 21, 22 and 23
3305 : : ! Open files in sequential mode
3306 : 1195 : ddkfil(idir1)=20+idir1
3307 : 1195 : write(msg, '(a,a)') '-open ddk wf file :',trim(fiwfddk)
3308 [ + + ]: 3585 : call wrtout([std_out, ab_out], msg)
3309 : 1195 : call ddks(idir1)%open_read(fiwfddk, formeig1, dtset%iomode, ddkfil(idir1), xmpi_comm_self)
3310 : : end if
3311 : : end do
3312 : :
3313 : : !Update list of computed matrix elements
3314 [ + + ]: 1827 : if (ipert /= dtset%natom + 1) then
3315 [ + + ]: 15644 : do ipert1=1,mpert
3316 [ + + ]: 58016 : do idir1=1,3
3317 [ + + + + : 56496 : if(ipert1 <= dtset%natom .or. ipert1==dtset%natom+2 .and. ddkfil(idir1)/=0) then
+ + ]
3318 : 11038 : blkflg(idir1,ipert1,idir,ipert)=1
3319 : : end if
3320 : : end do
3321 : : end do
3322 : : else
3323 : 307 : ipert1 = dtset%natom + 1
3324 [ + + ]: 1228 : do idir1=1,3
3325 : : ! If was already computed in another run or dataset, or if is to be computed in the present one
3326 [ + + + + : 1228 : if ((ddkfil(idir1) /= 0).or. (dtset%rfdir(idir1)/=0.and. idir1<=idir) ) then
+ + ]
3327 : : ! if ((ddkfil(idir1) /= 0).or. (idir1==idir) ) then
3328 : 544 : blkflg(idir1,ipert1,idir,ipert)=1
3329 : : end if
3330 : : end do
3331 : : end if
3332 : :
3333 : 1827 : n1=dtset%ngfft(1) ; n2=dtset%ngfft(2) ; n3=dtset%ngfft(3)
3334 : 1827 : n4=dtset%ngfft(4) ; n5=dtset%ngfft(5) ; n6=dtset%ngfft(6)
3335 : 1827 : nspinor_=dtset%nspinor
3336 : :
3337 : 1827 : bantot = 0
3338 : 1827 : ban2tot = 0
3339 : :
3340 : : !==== Initialize most of the Hamiltonian ====
3341 : : !1) Allocate all arrays and initialize quantities that do not depend on k and spin.
3342 : : !2) Perform the setup needed for the non-local factors:
3343 : : !3) Constant kleimann-Bylander energies are copied from psps to gs_hamk.
3344 : : call gs_hamkq%init(psps,pawtab,dtset%nspinor,nsppol,nspden,dtset%natom,&
3345 : : & dtset%typat,xred,nfft,dtset%mgfft,ngfft,rprimd,dtset%nloalg,ph1d=ph1d,&
3346 : 1827 : & gpu_option=dtset%gpu_option)
3347 : :
3348 : : !LOOP OVER SPINS
3349 : 1827 : bdtot_index=0
3350 : 1827 : icg=0;icg1=0
3351 [ + + ]: 3738 : do isppol=1,nsppol
3352 : :
3353 : 1911 : ikg=0;ikg1=0
3354 : :
3355 : : ! Continue to initialize the Hamiltonian
3356 : 1911 : call gs_hamkq%load_spin(isppol,with_nonlocal=.true.)
3357 : :
3358 : : ! BIG FAT k POINT LOOP
3359 [ + + ]: 123933 : do ikpt=1,nkpt_rbz
3360 : :
3361 : 120195 : nband_k=nband_rbz(ikpt+(isppol-1)*nkpt_rbz)
3362 : 120195 : istwf_k=istwfk_rbz(ikpt)
3363 : 120195 : npw_k=npwarr(ikpt)
3364 : 120195 : npw1_k=npwar1(ikpt)
3365 : :
3366 [ + + ]: 810651 : eig_k(1:nband_k) = eigen0(1+bantot:nband_k+bantot)
3367 [ + + ]: 11213507 : eig1_k(1:2*nband_k**2) = eigen1(1+ban2tot:2*nband_k**2+ban2tot)
3368 : 120195 : bantot = bantot + nband_k
3369 : 120195 : ban2tot = ban2tot + 2*nband_k**2
3370 : :
3371 : :
3372 [ + + ]: 120195 : if(proc_distrb_cycle(mpi_enreg%proc_distrb,ikpt,1,nband_k,isppol,me)) then
3373 : 20872 : bdtot_index=bdtot_index+nband_k
3374 : : ! The wavefunction blocks for ddk file is skipped elsewhere in the loop
3375 : : ! Skip the rest of the k-point loop
3376 : 20872 : cycle
3377 : : end if
3378 : :
3379 [ - + + - : 397292 : ABI_MALLOC(ylm_k,(npw_k,psps%mpsang*psps%mpsang*psps%useylm))
+ + + - +
- + + - +
- + ]
3380 [ - + + - : 397292 : ABI_MALLOC(ylm1_k,(npw1_k,psps%mpsang*psps%mpsang*psps%useylm))
+ + + - +
- + + - +
- + ]
3381 : :
3382 : : ! In case of electric field pert1, read ddk wfs file
3383 : : ! Note that the symmetries are not used for ddk, so read each k point
3384 : : ! Also take into account implicitly the parallelism over k points
3385 : :
3386 [ + + ]: 397292 : do idir1=1,3
3387 [ + + ]: 397292 : if (ddkfil(idir1)/=0) then
3388 : 75546 : ii = ddks(idir1)%findk(kpt_rbz(:, ikpt))
3389 [ - + ]: 75546 : ABI_CHECK(ii == indkpt1(ikpt), "ii != indkpt1")
3390 : : end if
3391 : : end do
3392 : :
3393 [ - + + - : 297969 : ABI_MALLOC(occ_k,(nband_k))
+ - + - -
+ - + ]
3394 [ + + ]: 678003 : occ_k(:)=occ_rbz(1+bdtot_index:nband_k+bdtot_index)
3395 [ + + ]: 397292 : kpoint(:)=kpt_rbz(:,ikpt)
3396 [ + + ]: 397292 : kpq(:)=kpoint(:)+qphon(:)
3397 : 99323 : wtk_k=wtk_rbz(ikpt)
3398 [ + + + + : 8858203 : d2nl_k(:,:,:)=zero
+ + ]
3399 [ + + + + : 197819 : if(dtset%prtbbb==1)d2bbb_k(:,:,:,:)=zero
+ + + + +
+ ]
3400 : :
3401 : : ! Get plane-wave vectors and related data at k
3402 [ + + + + ]: 59775719 : kg_k(:,1:npw_k)=kg(:,1+ikg:npw_k+ikg)
3403 [ + + ]: 99323 : if (psps%useylm==1) then
3404 [ + + ]: 224358 : do ilm=1,psps%mpsang*psps%mpsang
3405 [ + + ]: 28397291 : ylm_k(1:npw_k,ilm)=ylm(1+ikg:npw_k+ikg,ilm)
3406 : : end do
3407 : : end if
3408 : :
3409 : : ! Get plane-wave vectors and related data at k+q
3410 [ + + + + ]: 59766471 : kg1_k(:,1:npw1_k)=kg1(:,1+ikg1:npw1_k+ikg1)
3411 [ + + ]: 99323 : if (psps%useylm==1) then
3412 [ + + ]: 224358 : do ilm=1,psps%mpsang*psps%mpsang
3413 [ + + ]: 28397291 : ylm1_k(1:npw1_k,ilm)=ylm1(1+ikg1:npw1_k+ikg1,ilm)
3414 : : end do
3415 : : end if
3416 : :
3417 : : ! Compute the eigenvalues, wavefunction,
3418 : : ! contributions to kinetic energy, nonlocal energy, forces,
3419 : : ! and update of rhor1 to this k-point and this spin polarization.
3420 : : ! Note that dfpt_nstwf is called with kpoint, while kpt is used inside dfpt_vtowfk
3421 : : call dfpt_nstwf(cg,cg1,ddkfil,dtset,d2bbb_k,d2nl_k,eig_k,eig1_k,gs_hamkq,&
3422 : : & icg,icg1,idir,ikpt,ipert,isppol,istwf_k,kg_k,kg1_k,kpoint,kpq,mband_mem_rbz,mkmem,mk1mem,mpert,&
3423 : : & mpi_enreg,mpw,mpw1,nband_k,npw_k,npw1_k,nsppol,&
3424 : 99323 : & occ_k,psps,rmet,ddks,wtk_k,ylm_k,ylm1_k)
3425 : :
3426 [ + + + + : 8858203 : d2nl(:,:,:,idir,ipert)=d2nl(:,:,:,idir,ipert)+d2nl_k(:,:,:)
+ + ]
3427 [ + + + + : 197819 : if(dtset%prtbbb==1)d2bbb(:,:,idir,ipert,:,:)=d2bbb(:,:,idir,ipert,:,:)+d2bbb_k(:,:,:,:)
+ + + + +
+ ]
3428 : :
3429 : : ! Keep track of total number of bands
3430 : 99323 : bdtot_index=bdtot_index+nband_k
3431 : :
3432 : : ! Shift arrays memory
3433 [ + - ]: 99323 : if (mkmem/=0) then
3434 : 99323 : icg=icg+npw_k*dtset%nspinor*proc_distrb_nband(mpi_enreg%proc_distrb,ikpt,nband_k,isppol,me)
3435 : 99323 : ikg=ikg+npw_k
3436 : : end if
3437 [ + - ]: 99323 : if (mk1mem/=0) then
3438 : 99323 : icg1=icg1+npw1_k*dtset%nspinor*proc_distrb_nband(mpi_enreg%proc_distrb,ikpt,nband_k,isppol,me)
3439 : 99323 : ikg1=ikg1+npw1_k
3440 : : end if
3441 : :
3442 [ - + ]: 99323 : ABI_FREE(occ_k)
3443 [ - + ]: 99323 : ABI_FREE(ylm_k)
3444 [ - + ]: 101234 : ABI_FREE(ylm1_k)
3445 : : end do ! End big k point loop
3446 : : end do ! End loop over spins
3447 : :
3448 : 1827 : call gs_hamkq%free()
3449 : :
3450 : : !Treat fixed occupation numbers (as in vtorho)
3451 : : if(xmpi_paral==1)then
3452 [ + - - + : 7308 : ABI_MALLOC(buffer1,(2*3*mpert))
+ - + - +
- - + -
+ ]
3453 [ - + + - : 3654 : ABI_MALLOC(buffer2,(2*3*mpert))
- + - + ]
3454 : : ! Pack d2nl
3455 [ + + ]: 3654 : buffer1(1:2*3*mpert)=reshape(d2nl(:,:,:,idir,ipert),(/2*3*mpert/))
3456 : : ! Build sum of everything
3457 : 1827 : call timab(48,1,tsec)
3458 : 1827 : call xmpi_sum(buffer1,buffer2,2*3*mpert,spaceworld,ierr)
3459 : 1827 : call timab(48,2,tsec)
3460 : : ! Unpack the final result
3461 [ + + ]: 7308 : d2nl(:,:,:,idir,ipert)=reshape(buffer2(:),(/2,3,mpert/))
3462 [ - + ]: 1827 : ABI_FREE(buffer1)
3463 [ - + ]: 1827 : ABI_FREE(buffer2)
3464 : :
3465 [ + + ]: 1827 : if(dtset%prtbbb==1)then
3466 [ + - - + : 36 : ABI_MALLOC(buffer1,(2*3*dtset%mband*dtset%mband))
+ - + - +
- - + -
+ ]
3467 [ - + + - : 24 : ABI_MALLOC(buffer2,(2*3*dtset%mband*dtset%mband))
- + - + ]
3468 : : ! Pack d2bbb
3469 [ + + ]: 24 : buffer1(1:2*3*dtset%mband*dtset%mband)=reshape(d2bbb(:,:,idir,ipert,:,:),(/2*3*dtset%mband*dtset%mband/))
3470 : : ! Build sum of everything
3471 : 12 : call timab(48,1,tsec)
3472 : 12 : call xmpi_sum(buffer1,buffer2,2*3*dtset%mband*dtset%mband,spaceworld,ierr)
3473 : 12 : call timab(48,2,tsec)
3474 : : ! Unpack the final result
3475 [ + + + + : 7836 : d2bbb(:,:,idir,ipert,:,:)=reshape(buffer2(:),(/2,3,dtset%mband,dtset%mband/))
+ + + + +
+ ]
3476 [ - + ]: 12 : ABI_FREE(buffer1)
3477 [ - + ]: 12 : ABI_FREE(buffer2)
3478 : : end if
3479 : : end if ! xmpi_paral==1
3480 : :
3481 : : !In the case of the strain perturbation time-reversal symmetry will always
3482 : : !be true so imaginary part of d2nl will be must be set to zero here since
3483 : : !the symmetry-reduced kpt set will leave a non-zero imaginary part.
3484 [ + + + + : 5359 : if(ipert==dtset%natom+3 .or. ipert==dtset%natom+4) d2nl(2,:,:,idir,ipert)=zero
+ + + + ]
3485 : :
3486 : : !In case of electric field ipert1, close the ddk wf files
3487 [ + + ]: 7308 : do idir1=1,3
3488 [ + + ]: 7308 : if (ddkfil(idir1)/=0) call ddks(idir1)%close()
3489 : : end do
3490 : :
3491 : : !Symmetrize the non-local contributions,
3492 : : !as was needed for the forces in a ground-state calculation
3493 : : !However, here the quantity is complex, and there are phases !
3494 : :
3495 : : !Do the transform
3496 [ - + + - : 5481 : ABI_MALLOC(work1,(2,3,dtset%natom))
+ - + - -
+ - + ]
3497 [ + + ]: 5769 : do ipert1=1,dtset%natom
3498 [ + + ]: 17595 : do idir1=1,3
3499 : 11826 : work1(1,idir1,ipert1)=d2nl(1,idir1,ipert1,idir,ipert)
3500 : 15768 : work1(2,idir1,ipert1)=d2nl(2,idir1,ipert1,idir,ipert)
3501 : : end do
3502 : : end do
3503 : 1827 : call dfpt_sygra(dtset%natom,d2nl(:,:,:,idir,ipert),work1,indsy1,ipert,nsym1,qphon,symrc1)
3504 [ - + ]: 1827 : ABI_FREE(work1)
3505 : :
3506 : : !Must also symmetrize the electric/magnetic field perturbation response !
3507 : : !(XG 000803 This was not implemented until now)
3508 [ + + + + ]: 7308 : if(sum(ddkfil(:))/=0)then
3509 : : ! Get the symmetry matrices in terms of real space basis
3510 [ - + + - : 1386 : ABI_MALLOC(symrl1,(3,3,nsym1))
+ - + - -
+ - + ]
3511 [ + + ]: 1233 : do isym=1,nsym1
3512 : 1233 : call mati3inv(symrc1(:,:,isym),symrl1(:,:,isym))
3513 : : end do
3514 : : ! There should not be any imaginary part, but stay general (for debugging)
3515 [ + + + + ]: 4620 : d2nl_elfd(:,:)=d2nl(:,:,dtset%natom+2,idir,ipert)
3516 [ + + ]: 1848 : do ii=1,3
3517 : 1386 : sumelfd(:)=zero
3518 : : summgfd(:)=zero
3519 [ + + ]: 3699 : do isym=1,nsym1
3520 [ + + ]: 9252 : do jj=1,3
3521 [ + + ]: 9252 : if(symrl1(ii,jj,isym)/=0)then
3522 [ + + ]: 2570 : if(ddkfil(jj)==0)then
3523 : 347 : blkflg(ii,dtset%natom+2,idir,ipert)=0
3524 : : end if
3525 : : end if
3526 : : end do
3527 : : sumelfd(:)=sumelfd(:)+dble(symrl1(ii,1,isym))*d2nl_elfd(:,1)+&
3528 : : & dble(symrl1(ii,2,isym))*d2nl_elfd(:,2)+&
3529 [ + + ]: 6939 : & dble(symrl1(ii,3,isym))*d2nl_elfd(:,3)
3530 : : summgfd(:)=summgfd(:)+dble(symrl1(ii,1,isym))*d2nl_mgfd(:,1)+&
3531 : : & dble(symrl1(ii,2,isym))*d2nl_mgfd(:,2)+&
3532 : 1386 : & dble(symrl1(ii,3,isym))*d2nl_mgfd(:,3)
3533 : : end do
3534 [ + + ]: 4620 : d2nl(:,ii,dtset%natom+2,idir,ipert)=sumelfd(:)/dble(nsym1)
3535 : : end do
3536 : :
3537 [ + + + + ]: 462 : if ((dtset%prtbbb==1).and.(ipert<=dtset%natom)) then
3538 [ + + ]: 36 : do iband = 1,dtset%mband
3539 [ + + + + ]: 320 : d2nl_elfd(:,:)=d2bbb(:,:,idir,ipert,iband,iband)
3540 [ + + ]: 132 : do ii=1,3
3541 : 96 : sumelfd(:)=zero
3542 [ + + ]: 480 : do isym=1,nsym1
3543 : : sumelfd(:)=sumelfd(:)+dble(symrl1(ii,1,isym))*d2nl_elfd(:,1)+&
3544 : : & dble(symrl1(ii,2,isym))*d2nl_elfd(:,2)+&
3545 [ + + ]: 1248 : & dble(symrl1(ii,3,isym))*d2nl_elfd(:,3)
3546 : : end do
3547 [ + + ]: 320 : d2bbb(:,ii,idir,ipert,iband,iband)=sumelfd(:)/dble(nsym1)
3548 : : end do
3549 : : end do !iband
3550 : : end if
3551 : :
3552 [ - + ]: 462 : ABI_FREE(symrl1)
3553 : : end if
3554 : :
3555 : : !----------------------------------------------------------------------------
3556 : : !Now, treat the local contribution
3557 : :
3558 : 1827 : nfftot=ngfft(1)*ngfft(2)*ngfft(3)
3559 [ - + + - : 5481 : ABI_MALLOC(vpsp1,(cplex*nfft))
+ - + - -
+ - + ]
3560 [ + + ]: 1827 : if (ipert /= dtset%natom + 1) then
3561 [ + + ]: 1520 : n3xccc=0;if(psps%n1xccc/=0) n3xccc=nfft
3562 [ + + + - : 4560 : ABI_MALLOC(xccc3d1,(cplex*n3xccc))
+ - + + -
+ - + ]
3563 [ - + + - : 6080 : ABI_MALLOC(vxc1,(cplex*nfft,nspden))
- + + - +
- + - - +
- + ]
3564 : :
3565 [ + + ]: 15644 : do ipert1=1,mpert
3566 [ + + ]: 58016 : do idir1=1,3
3567 [ + + ]: 56496 : if(ipert1 <= dtset%natom)then
3568 : :
3569 : : ! Get first-order local potential and first-order pseudo core density
3570 : : call dfpt_vlocal(atindx,cplex,gmet,gsqcut,dtset%icutcoul,idir1,ipert1,mpi_enreg,psps%mqgrid_ff,dtset%natom,&
3571 : : & nattyp,nfft,ngfft,dtset%nkpt,dtset%ntypat,n1,n2,n3,ph1d,psps%qgrid_ff,&
3572 : : & qphon,dtset%rcut,rprimd,ucvol,dtset%vcutgeo,psps%vlspl,vpsp1,xred,&
3573 : 9852 : & zion=dtset%ziontypat)
3574 [ + + ]: 9852 : if(psps%n1xccc/=0)then
3575 : : call dfpt_mkcore(cplex,idir1,ipert1,dtset%natom,dtset%ntypat,n1,psps%n1xccc,&
3576 : 6459 : & n2,n3,qphon,rprimd,dtset%typat,ucvol,psps%xcccrc,psps%xccc1d,xccc3d1,xred)
3577 : : end if
3578 : :
3579 : : ! Get first-order exchange-correlation potential (core-correction contribution only !)
3580 [ + + ]: 9852 : if(psps%n1xccc/=0)then
3581 : 6459 : option=0
3582 : : !FR SPr EB non-collinear magnetism
3583 [ + + + - : 6459 : if (nspden==4.and.present(rhor).and.present(vxc).and.present(ixcrot)) then
+ - ]
3584 : 450 : optnc=1
3585 : : call dfpt_mkvxc_noncoll(cplex,dtset%ixc,kxc,mpi_enreg,nfft,ngfft,rhodummy,0,rhodummy,0,rhodummy,0,&
3586 : : & nkxc,nmxc,nspden,n3xccc,optnc,option,qphon,rhor,rhor1,&
3587 : 450 : & rprimd,0,vxc,vxc1,xccc3d1,ixcrot=ixcrot)
3588 : : else
3589 : : call dfpt_mkvxc(cplex,dtset%ixc,kxc,mpi_enreg,nfft,ngfft,rhodummy,0,rhodummy,0,&
3590 : : & nkxc,nmxc,nspden,n3xccc,option,qphon,rhodummy,&
3591 : 6009 : & rprimd,0,vxc1,xccc3d1)
3592 : : end if
3593 : : else
3594 [ + + + + ]: 28747548 : vxc1(:,:)=zero
3595 : : end if
3596 : :
3597 : : ! Norm-conserving pseudpopotential case:
3598 : : ! Combines density j2 with local potential j1 (vpsp1 and vxc1)
3599 : : ! XG030514 : this is a first possible coding, however, each dotprod contains
3600 : : ! a parallel section (reduction), so it is better to use only one dotprod ...
3601 : : ! call dotprod_vn(cplex,rhor1,dr_psp1,di_psp1,mpi_enreg,nfft,nfftot,1,2,vpsp1,ucvol)
3602 : : ! call dotprod_vn(cplex,rhor1,dr_xc1,di_xc1,mpi_enreg,nfft,nfftot,nspden,2,vxc1,ucvol)
3603 : : ! dotr=dr_psp1+dr_xc1;doti=di_psp1+di_xc1... but then, one needs to overload vxc1
3604 [ + + ]: 20499 : do ispden=1,min(nspden,2)
3605 [ + + ]: 140922459 : do ifft=1,cplex*nfft
3606 : 140912607 : vxc1(ifft,ispden)=vxc1(ifft,ispden)+vpsp1(ifft)
3607 : : end do
3608 : : end do
3609 : 9852 : call dotprod_vn(cplex,rhor1,dotr,doti,nfft,nfftot,nspden,2,vxc1,ucvol)
3610 : :
3611 : : ! MVeithen 021212 : in case ipert = 2, these lines compute the local part
3612 : : ! of the Born effective charges from phonon and electric
3613 : : ! field type perturbations, see eq. 43 of
3614 : : ! X. Gonze and C. Lee, PRB 55, 10355 (1997) [[cite:Gonze1997a]]
3615 : : ! The minus sign is due to the fact that the effective charges
3616 : : ! are minus the second derivatives of the energy
3617 : :
3618 [ + + ]: 9852 : if (ipert == dtset%natom+2) then
3619 : 1140 : d2lo(1,idir1,ipert1,idir,ipert)=-dotr
3620 : 1140 : d2lo(2,idir1,ipert1,idir,ipert)=-doti
3621 : : else
3622 : 8712 : d2lo(1,idir1,ipert1,idir,ipert)=dotr
3623 : 8712 : d2lo(2,idir1,ipert1,idir,ipert)=doti
3624 : : end if
3625 : : ! Endif ipert1<=natom
3626 : : end if
3627 : : end do
3628 : : end do
3629 : :
3630 [ - + ]: 1520 : ABI_FREE(vxc1)
3631 [ - + ]: 1520 : ABI_FREE(xccc3d1)
3632 : :
3633 : : end if ! ipert /= natom +1
3634 : :
3635 [ - + ]: 1827 : ABI_FREE(d2bbb_k)
3636 [ - + ]: 1827 : ABI_FREE(d2nl_k)
3637 [ - + ]: 1827 : ABI_FREE(kg_k)
3638 [ - + ]: 1827 : ABI_FREE(kg1_k)
3639 [ - + ]: 1827 : ABI_FREE(vpsp1)
3640 [ - + ]: 1827 : ABI_FREE(eig_k)
3641 [ - + ]: 1827 : ABI_FREE(eig1_k)
3642 : :
3643 : 1827 : call timab(111,2,tsec)
3644 : :
3645 : : ABI_NVTX_END_RANGE()
3646 : :
3647 : : DBG_EXIT("COLL")
3648 : :
3649 [ - + - + : 168084 : end subroutine dfpt_nstdy
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + ]
3650 : : !!***
3651 : :
3652 : : !!****f* ABINIT/dfpt_rhofermi
3653 : : !! NAME
3654 : : !! dfpt_rhofermi
3655 : : !!
3656 : : !! FUNCTION
3657 : : !! This routine computes the fixed contribution to the first-order
3658 : : !! Fermi energy for metallic occupation and Q=0, as well as the
3659 : : !! Fermi level charge density needed to compute the remainder of the
3660 : : !! first-order Fermi energy from the self-consistent local potential
3661 : : !! at each step in the iteration process.
3662 : : !!
3663 : : !! INPUTS
3664 : : !! atindx(natom)=index table for atoms (see gstate.f)
3665 : : !! cg(2,mpw*nspinor*mband_mem*mkmem*nsppol)=planewave coefficients of wavefunctions.
3666 : : !! cgq(2,mpw1*nspinor*mband_mem*mkqmem*nsppol)=pw coefficients of GS wavefunctions at k+q.
3667 : : !! cplex: if 1, real space 1-order functions on FFT grid are REAL; if 2, COMPLEX
3668 : : !! cprj(natom,nspinor*mband_mem*mkmem*nsppol*usecprj)= wave functions at k
3669 : : !! projected with non-local projectors: cprj=<p_i|Cnk>
3670 : : !! cprjq(natom,nspinor*mband_mem*mkqmem*nsppol*usecprj)= wave functions at k+q
3671 : : !! projected with non-local projectors: cprjq=<p_i|Cnk+q>
3672 : : !! doccde_rbz(mband*nkpt_rbz*nsppol)=derivative of occ_rbz wrt the energy
3673 : : !! docckqde(mband*nkpt_rbz*nsppol)=derivative of occkq wrt the energy
3674 : : !! dtfil <type(datafiles_type)>=variables related to files
3675 : : !! dtset <type(dataset_type)>=all input variables for this dataset
3676 : : !! eigenq(mband*nkpt_rbz*nsppol)=GS eigenvalues at k+q (hartree)
3677 : : !! eigen0(mband*nkpt_rbz*nsppol)=GS eigenvalues at k (hartree)
3678 : : !! gmet(3,3)=reciprocal space metric tensor in bohr**-2.
3679 : : !! gprimd(3,3)=dimensional reciprocal space primitive translations
3680 : : !! idir=direction of the perturbation
3681 : : !! indsy1(4,nsym1,natom)=indirect indexing array for atom labels
3682 : : !! ipert=type of the perturbation
3683 : : !! irrzon1(nfft**(1-1/nsym1),2,(nspden/nsppol)-3*(nspden/4))=irreducible zone data
3684 : : !! istwfk_rbz(nkpt_rbz)=input option parameter that describes the storage of wfs
3685 : : !! kg(3,mpw*mkmem)=reduced planewave coordinates.
3686 : : !! kg1(3,mpw1*mk1mem)=reduced planewave coordinates at k+q, with RF k points
3687 : : !! kpt_rbz(3,nkpt_rbz)=reduced coordinates of k points.
3688 : : !! mband=maximum number of bands
3689 : : !! mband_mem=maximum number of bands on this cpu
3690 : : !! mkmem =number of k points treated by this node (GS data)
3691 : : !! mkqmem =number of k+q points treatede by this node (GS data)
3692 : : !! mk1mem =number of k points treated by this node.
3693 : : !! mpw=maximum dimensioned size of npw or wfs at k
3694 : : !! mpw1=maximum dimensioned size of npw for wfs at k+q (also for 1-order wfs).
3695 : : !! maximum dimension for q points in grids for nonlocal form factors
3696 : : !! natom=number of atoms in cell.
3697 : : !! nband_rbz(nkpt_rbz*nsppol)=number of bands at each RF k point for each spin
3698 : : !! ncpgr=number of gradients stored in cprj array (cprj=<p_i|Cnk>)
3699 : : !! nfftf= -PAW ONLY- number of FFT grid points for the fine grid
3700 : : !! (nfftf=nfft for norm-conserving potential runs - see comment in respfn.F90)
3701 : : !! ngfftf(1:18)=integer array with FFT box dimensions and other for the "fine" grid
3702 : : !! nhatfermi(nfft,nspden)=array for fermi-level compensation charge density (PAW only)
3703 : : !! nkpt_rbz=number of k points in the IBZ for this perturbation
3704 : : !! mpi_enreg=information about MPI parallelization
3705 : : !! my_natom=number of atoms treated by current processor
3706 : : !! npwarr(nkpt_rbz)=number of planewaves in basis at this GS k point
3707 : : !! npwar1(nkpt_rbz)=number of planewaves in basis at this RF k+q point
3708 : : !! nspden=number of spin-density components
3709 : : !! nsppol=1 for unpolarized, 2 for spin-polarized
3710 : : !! nsym1=number of symmetry elements in space group consistent with
3711 : : !! perturbation
3712 : : !! occkq(mband*nkpt_rbz*nsppol)=occupation number for each band (often 2)
3713 : : !! at each k+q point of the reduced Brillouin zone.
3714 : : !! occ_rbz(mband*nkpt_rbz*nsppol)=occupation number for each band and k (usually 2)
3715 : : !! paw_ij(natom*usepaw) <type(paw_ij_type)>=paw arrays given on (i,j) channels for the GS
3716 : : !! pawang <type(pawang_type)>=paw angular mesh and related data
3717 : : !! pawang1 <type(pawang_type)>=pawang datastr. containing only symmetries preserving the perturbation
3718 : : !! pawfgr <type(pawfgr_type)>=fine grid parameters and related data
3719 : : !! pawfgrtab(natom*usepaw) <type(pawfgrtab_type)>=atomic data given on fine rectangular grid for the GS
3720 : : !! pawrad(ntypat*usepaw) <type(pawrad_type)>=paw radial mesh and related data
3721 : : !! pawtab(ntypat*usepaw) <type(pawtab_type)>=paw tabulated starting data
3722 : : !! phnons1(2,nfft**(1-1/nsym1),(nspden/nsppol)-3*(nspden/4))=nonsymmorphic translation phases
3723 : : !! ph1d(2,3*(2*mgfft+1)*natom)=one-dimensional structure factor information
3724 : : !! prtvol=control print volume and debugging output
3725 : : !! psps <type(pseudopotential_type)>=variables related to pseudopotentials
3726 : : !! rmet(3,3)=real space metric (bohr**2)
3727 : : !! rprimd(3,3)=dimensional real space primitive translations
3728 : : !! symaf1(nsym1)=(anti)ferromagnetic part of symmetry operations
3729 : : !! symrc1(3,3,nsym1)=symmetry operations in reciprocal space
3730 : : !! symrl1(3,3,nsym1)=3x3 matrices of the group symmetries
3731 : : !! tnons1(3,nsym1)=non-symmorphic translations
3732 : : !! ucvol=volume of the unit cell
3733 : : !! usecprj= 1 if cprj, cprjq, cprj1 arrays are stored in memory
3734 : : !! useylmgr1= 1 if ylmgr1 array is allocated
3735 : : !! vtrial(nfftf,nspden)=GS potential (Hartree).
3736 : : !! vxc(nfftf,nspden)=XC potential (Hartree).
3737 : : !! wtk_rbz(nkpt_rbz)=weight assigned to each k point.
3738 : : !! xred(3,natom)=reduced dimensionless atomic coordinates
3739 : : !! ylm(mpw*mkmem,mpsang*mpsang*useylm)= real spherical harmonics for each G and k point
3740 : : !! ylm1(mpw1*mk1mem,mpsang*mpsang*useylm)= spherical harmonics for each G and k+g point
3741 : : !! ylmgr1(mpw*mkmem,3,mpsang*mpsang*useylm)= gradients of real spherical harmonics at k+q
3742 : : !!
3743 : : !! OUTPUT
3744 : : !! eigen1(2*mband*mband*nkpt_rbz*nsppol)=array for holding eigenvalues
3745 : : !! (hartree) - only digonal elements computed here
3746 : : !! fe1fixed=fixed contribution to the first-order Fermi energy
3747 : : !! (nonlocal and kinetic in the case of strain)
3748 : : !! nhatfermi(cplex*nfftf,nspden)=fermi-level compensation charge density (PAW only)
3749 : : !! rhorfermi(cplex*nfftf,nspden)=fermi-level electronic density
3750 : : !!
3751 : : !! NOTES
3752 : : !! This routine will NOT work with nspden==4:
3753 : : !! at least the use of fftpac should be modified.
3754 : : !!
3755 : : !! SOURCE
3756 : :
3757 : 192 : subroutine dfpt_rhofermi(cg,cgq,cplex,cprj,cprjq,&
3758 : 192 : & doccde_rbz,docckqde,dtfil,dtset,eigenq,eigen0,eigen1,fe1fixed,gmet,gprimd,idir,&
3759 : 384 : & indsy1,ipert,irrzon1,istwfk_rbz,kg,kg1,kpt_rbz,mband,mband_mem,mkmem,mkqmem,mk1mem,mpi_enreg,&
3760 : 384 : & mpw,mpw1,my_natom,natom,nband_rbz,ncpgr,nfftf,ngfftf,nhatfermi,nkpt_rbz,npwarr,npwar1,nspden,&
3761 : 192 : & nsppol,nsym1,occkq,occ_rbz,paw_ij,pawang,pawang1,pawfgr,pawfgrtab,pawrad,pawrhoijfermi,pawtab,&
3762 : 384 : & phnons1,ph1d,prtvol,psps,rhorfermi,rmet,rprimd,symaf1,symrc1,symrl1,tnons1,&
3763 [ - + ]: 192 : & ucvol,usecprj,useylmgr1,vtrial,vxc,wtk_rbz,xred,ylm,ylm1,ylmgr1, &
3764 : : & eta,omega) !Optional
3765 : :
3766 : : !Arguments -------------------------------
3767 : : !scalars
3768 : : integer,intent(in) :: cplex,idir,ipert,mband,mk1mem,mkmem,mkqmem
3769 : : integer,intent(in) :: mband_mem
3770 : : integer,intent(in) :: mpw,mpw1,my_natom,natom,ncpgr,nfftf,nkpt_rbz,nspden,nsppol,nsym1
3771 : : integer,intent(in) :: prtvol,usecprj,useylmgr1
3772 : : real(dp),intent(in) :: ucvol
3773 : : real(dp),intent(out) :: fe1fixed
3774 : : real(dp),intent(in),optional :: eta,omega
3775 : : type(MPI_type),intent(in) :: mpi_enreg
3776 : : type(datafiles_type),intent(in) :: dtfil
3777 : : type(dataset_type),intent(in) :: dtset
3778 : : type(pawang_type),intent(in) :: pawang,pawang1
3779 : : type(pawfgr_type),intent(in) :: pawfgr
3780 : : type(pseudopotential_type),intent(in) :: psps
3781 : : !arrays
3782 : : integer,intent(in) :: indsy1(4,nsym1,natom)
3783 : : integer,intent(in) :: irrzon1(dtset%nfft**(1-1/nsym1),2,(nspden/nsppol)-3*(nspden/4))
3784 : : integer,intent(in) :: istwfk_rbz(nkpt_rbz),kg(3,mpw*mkmem),kg1(3,mpw1*mk1mem)
3785 : : integer,intent(in) :: nband_rbz(nkpt_rbz*nsppol),ngfftf(18)
3786 : : integer,intent(in) :: npwar1(nkpt_rbz),npwarr(nkpt_rbz),symaf1(nsym1)
3787 : : integer,intent(in) :: symrc1(3,3,nsym1),symrl1(3,3,nsym1)
3788 : : real(dp),intent(in) :: cg(2,mpw*dtset%nspinor*mband_mem*mkmem*nsppol)
3789 : : real(dp),intent(in) :: cgq(2,mpw1*dtset%nspinor*mband_mem*mkqmem*nsppol)
3790 : : real(dp),intent(in) :: doccde_rbz(mband*nkpt_rbz*nsppol)
3791 : : real(dp),intent(in) :: docckqde(mband*nkpt_rbz*nsppol)
3792 : : real(dp),intent(in) :: eigen0(mband*nkpt_rbz*nsppol)
3793 : : real(dp),intent(in) :: eigenq(mband*nkpt_rbz*nsppol),gmet(3,3),gprimd(3,3)
3794 : : real(dp),intent(in) :: kpt_rbz(3,nkpt_rbz)
3795 : : real(dp),intent(in) :: occ_rbz(mband*nkpt_rbz*nsppol),occkq(mband*nkpt_rbz*nsppol)
3796 : : real(dp),intent(in) :: ph1d(2,3*(2*dtset%mgfft+1)*natom)
3797 : : real(dp),intent(in) :: phnons1(2,dtset%nfft**(1-1/nsym1),(nspden/nsppol)-3*(nspden/4))
3798 : : real(dp),intent(in) :: rmet(3,3),rprimd(3,3),tnons1(3,nsym1)
3799 : : real(dp),intent(in) :: vtrial(nfftf,nspden),vxc(nfftf,nspden),wtk_rbz(nkpt_rbz)
3800 : : real(dp),intent(in) :: xred(3,natom),ylm(mpw*mkmem,psps%mpsang*psps%mpsang*psps%useylm)
3801 : : real(dp),intent(in) :: ylm1(mpw1*mk1mem,psps%mpsang*psps%mpsang*psps%useylm)
3802 : : real(dp),intent(in) :: ylmgr1(mpw1*mk1mem,3,psps%mpsang*psps%mpsang*psps%useylm*useylmgr1)
3803 : : real(dp),intent(out) :: eigen1(2*mband*mband*nkpt_rbz*nsppol)
3804 : : real(dp),intent(out) :: nhatfermi(:,:)
3805 : : real(dp),intent(out) :: rhorfermi(cplex*nfftf,nspden)
3806 : : type(pawcprj_type),intent(in) :: cprj (natom,dtset%nspinor*mband_mem*mkmem *nsppol*usecprj)
3807 : : type(pawcprj_type),intent(in) :: cprjq(natom,dtset%nspinor*mband_mem*mkqmem*nsppol*usecprj)
3808 : : type(paw_ij_type),intent(in) :: paw_ij(my_natom*psps%usepaw)
3809 : : type(pawfgrtab_type),intent(inout) :: pawfgrtab(my_natom*psps%usepaw)
3810 : : type(pawrad_type),intent(in) :: pawrad(dtset%ntypat*psps%usepaw)
3811 : : type(pawrhoij_type),target,intent(inout)::pawrhoijfermi(my_natom*psps%usepaw)!vz_i
3812 : : type(pawtab_type), intent(in) :: pawtab(dtset%ntypat*psps%usepaw)
3813 : :
3814 : : !Local variables-------------------------------
3815 : : !scalars
3816 : : integer,parameter :: level=17
3817 : : integer :: bd2tot_index,bdtot_index,buffer_size,cplex_rhoij
3818 : : integer :: dimffnl1,dimffnlk,iatom,iband,ibg,ibgq
3819 : : integer :: icg,icgq,ider,idir0,ierr,ii,ikg,ikg1,ikpt,ilm,ilmn,indx
3820 : : integer :: ispden,isppol,istr,istwf_k
3821 : : integer :: mbd2kpsp,mcgq,mcgq_disk,mcprjq,mcprjq_disk
3822 : : integer :: me,n1,n2,n3,n4,n5,n6,nband_k,nkpg,nkpg1,npw1_k,npw_k,nspden_rhoij
3823 : : integer :: optfr,qphase_rhoij,spaceworld
3824 : : integer :: nband_me
3825 : : logical :: paral_atom,qne0
3826 : : real(dp) :: arg,eta_,fe1norm,invfe1norm,omega_,wtk_k
3827 : 192 : type(gs_hamiltonian_type) :: gs_hamkq
3828 : 192 : type(rf_hamiltonian_type) :: rf_hamkq
3829 : : !arrays
3830 : 192 : integer,allocatable :: kg1_k(:,:),kg_k(:,:)
3831 : : real(dp) :: kpoint(3),kpq(3),tsec(2)
3832 : : real(dp) :: ylmgr_dum(1,1,1)
3833 : 192 : real(dp),allocatable :: buffer1(:),dkinpw(:),doccde_k(:)
3834 : 192 : real(dp),allocatable :: doccde_kq(:),eig0_k(:),eig0_kq(:),eig1_k(:)
3835 : 192 : real(dp),allocatable :: fe1fixed_k(:),fe1norm_k(:)
3836 : 192 : real(dp),allocatable :: ffnl1(:,:,:,:),ffnlk(:,:,:,:)
3837 : 192 : real(dp),allocatable :: kinpw1(:),kpg1_k(:,:),kpg_k(:,:)
3838 : 192 : real(dp),allocatable :: occ_k(:),occ_kq(:),ph3d(:,:,:),ph3d1(:,:,:)
3839 : 192 : real(dp),allocatable :: rhoaug(:,:,:),rhogfermi(:,:),rhowfr(:,:)
3840 : 192 : real(dp),allocatable :: rhoaug4(:,:,:,:)
3841 : 192 : real(dp),allocatable :: rocceig(:,:),ylm1_k(:,:),ylm_k(:,:),ylmgr1_k(:,:,:)
3842 : 192 : type(paw_ij_type),allocatable :: paw_ij1fr(:)
3843 : 192 : type(pawrhoij_type),pointer :: pawrhoijfermi_unsym(:)
3844 : : ! real(dp),allocatable :: vlocal1(:,:,:,:),vlocal_tmp(:,:,:,:)
3845 : : ! real(dp),allocatable :: v1hspinfield(:,:),vtrial_tmp(:,:)
3846 : : ! *********************************************************************
3847 : :
3848 : : DBG_ENTER('COLL')
3849 : : ABI_NVTX_START_RANGE(NVTX_DFPT_RHOFERMI)
3850 : :
3851 : : !Check arguments validity
3852 : : if (ipert>natom.and.ipert/=natom+3.and.ipert/=natom+4.and.ipert/=natom+5.and. &
3853 [ + + + + : 85 : & ipert/=natom+6.and.(ipert>natom+11.and.ipert<2*natom+11)) then
- + - - -
- - - ]
3854 : 0 : ABI_BUG('wrong ipert argument!')
3855 : : end if
3856 [ - + ]: 192 : if (cplex/=1) then
3857 : 0 : ABI_BUG('wrong cplex/=1 argument !')
3858 : : end if
3859 : :
3860 : : !Treat optional arguments
3861 : 192 : eta_=zero; if (present(eta)) eta_=eta
3862 : 192 : omega_=zero; if (present(omega)) omega_=omega
3863 : :
3864 : : !Keep track of total time spent in this routine
3865 : 192 : call timab(121,1,tsec)
3866 : 192 : call timab(124,1,tsec)
3867 : :
3868 : : !Retrieve parallelism data
3869 : 192 : spaceworld=mpi_enreg%comm_cell
3870 : 192 : me=mpi_enreg%me_kpt
3871 : 192 : paral_atom=(my_natom/=dtset%natom)
3872 : :
3873 : : !Initialize output variables
3874 : 192 : fe1fixed=zero
3875 [ + + + + : 331943 : if (psps%usepaw==0) rhorfermi(:,:)=zero
+ + ]
3876 : :
3877 : : !Initialisations/allocation of temporary variables
3878 : 192 : n1=dtset%ngfft(1) ; n2=dtset%ngfft(2) ; n3=dtset%ngfft(3)
3879 : 192 : n4=dtset%ngfft(4) ; n5=dtset%ngfft(5) ; n6=dtset%ngfft(6)
3880 : 192 : bdtot_index=0 ; bd2tot_index=0 ; ibg=0 ; ibgq=0 ; icg=0 ; icgq=0
3881 : 192 : qne0=(dtset%qptn(1)**2+dtset%qptn(2)**2+dtset%qptn(3)**2>=tol14)
3882 : 192 : mbd2kpsp=2*mband**2*nkpt_rbz*nsppol
3883 : 192 : fe1norm=zero
3884 [ + - ]: 192 : if (nspden/=4) then
3885 [ - + + - : 960 : ABI_MALLOC(rhoaug,(cplex*n4,n5,n6))
- + + - -
+ + - + -
+ - - + -
+ ]
3886 : : else
3887 [ # # # # : 0 : ABI_MALLOC(rhoaug4,(cplex*n4,n5,n6,nspden))
# # # # #
# # # # #
# # # # #
# # # #
# ]
3888 : : end if
3889 [ - + + - : 576 : ABI_MALLOC(kg_k,(3,mpw))
+ - + - -
+ - + -
+ ]
3890 [ - + + - : 576 : ABI_MALLOC(kg1_k,(3,mpw1))
+ - + - -
+ - + -
+ ]
3891 [ + + ]: 192 : if (psps%usepaw==1) then
3892 [ - + + - : 460 : ABI_MALLOC(rhowfr,(cplex*dtset%nfft,dtset%nspden))
- + + - +
- + - - +
- + ]
3893 [ + + + + ]: 1046854 : rhowfr(:,:)=zero
3894 : : end if
3895 : :
3896 : 192 : mcgq=mpw1*dtset%nspinor*mband_mem*mkqmem*nsppol;mcgq_disk=0
3897 : :
3898 : : !Prepare RF PAW files for reading and writing if mkmem, mkqmem or mk1mem==0
3899 [ + + ]: 192 : if (psps%usepaw==1) then
3900 : 115 : mcprjq=dtset%nspinor*mband_mem*mkqmem*nsppol*usecprj;mcprjq_disk=0
3901 : : else
3902 : 77 : mcprjq=0;mcprjq_disk=0
3903 : : end if
3904 : :
3905 : : !PAW:has to compute frozen part of Dij^(1) (without Vpsp(1) contribution)
3906 [ + + ]: 192 : if (psps%usepaw==1) then
3907 [ - + + - : 601 : ABI_MALLOC(paw_ij1fr,(my_natom))
+ - + - -
+ - + + +
+ - ]
3908 : 115 : call paw_ij_nullify(paw_ij1fr)
3909 : : call paw_ij_init(paw_ij1fr,cplex,dtset%nspinor,dtset%nsppol,dtset%nspden,0,&
3910 : : & dtset%natom,dtset%ntypat,dtset%typat,pawtab,has_dijfr=1,&
3911 : 115 : & mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom )
3912 : 115 : optfr=1
3913 [ - + ]: 115 : ABI_MALLOC(buffer1,(0))
3914 : : call pawdijfr(gprimd,idir,ipert,my_natom,natom,nfftf,ngfftf,dtset%nspden,dtset%nsppol,&
3915 : : & dtset%ntypat,optfr,paw_ij1fr,pawang,pawfgrtab,pawrad,pawtab,&
3916 : : & cplex,dtset%qptn,rprimd,ucvol,buffer1,vtrial,vxc,xred,&
3917 : 115 : & mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom)
3918 [ - + ]: 115 : ABI_FREE(buffer1)
3919 : : end if
3920 : :
3921 : : !PAW:allocate memory for non-symetrized occupancies matrix at EFermi (pawrhoijfermi)
3922 : 192 : pawrhoijfermi_unsym => pawrhoijfermi
3923 [ + + ]: 192 : if (psps%usepaw==1) then
3924 [ + + ]: 115 : if (paral_atom) then
3925 [ - + + - : 420 : ABI_MALLOC(pawrhoijfermi_unsym,(natom))
+ - + - -
+ - + +
+ ]
3926 : : !Q phase should be 1 because Q=0
3927 : : call pawrhoij_inquire_dim(cplex_rhoij=cplex_rhoij,qphase_rhoij=qphase_rhoij,nspden_rhoij=nspden_rhoij,&
3928 : 60 : & nspden=dtset%nspden,spnorb=dtset%pawspnorb,cplex=cplex,cpxocc=dtset%pawcpxocc)
3929 : : call pawrhoij_alloc(pawrhoijfermi_unsym,cplex_rhoij,nspden_rhoij,dtset%nspinor,&
3930 : 60 : & dtset%nsppol,dtset%typat,qphase=qphase_rhoij,pawtab=pawtab,use_rhoijp=0,use_rhoij_=1)
3931 : : else
3932 : 55 : call pawrhoij_init_unpacked(pawrhoijfermi_unsym)
3933 : : end if
3934 : : end if
3935 : :
3936 : : !Initialize most of the Hamiltonian (arrays and quantities that do not depend on k + nl form factors)
3937 : : call gs_hamkq%init(psps,pawtab,dtset%nspinor,nsppol,nspden,natom,&
3938 : : & dtset%typat,xred,dtset%nfft,dtset%mgfft,dtset%ngfft,rprimd,dtset%nloalg,&
3939 : : & paw_ij=paw_ij,usecprj=usecprj,ph1d=ph1d,gpu_option=dtset%gpu_option,&
3940 : 192 : & mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom,mpi_spintab=mpi_enreg%my_isppoltab)
3941 : : call rf_hamkq%init(cplex,gs_hamkq,ipert,paw_ij1=paw_ij1fr,&
3942 : 192 : & mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom,mpi_spintab=mpi_enreg%my_isppoltab)
3943 : :
3944 : :
3945 : : !LOOP OVER SPINS
3946 [ + + ]: 400 : do isppol=1,nsppol
3947 : 208 : ikg=0;ikg1=0
3948 : : ! Continue to initialize the Hamiltonian at k+q
3949 : 208 : call gs_hamkq%load_spin(isppol,with_nonlocal=.true.)
3950 : 208 : call rf_hamkq%load_spin(isppol,with_nonlocal=.true.)
3951 : :
3952 : : ! Nullify contribution to density at EFermi from this k-point
3953 [ + - ]: 208 : if (nspden/=4) then
3954 [ + + + + : 1626104 : rhoaug(:,:,:)=zero
+ + ]
3955 : : else
3956 [ # # # # : 0 : rhoaug4(:,:,:,:)=zero
# # # # ]
3957 : : end if
3958 : 208 : call timab(125,1,tsec)
3959 : :
3960 : : ! BIG FAT k POINT LOOP
3961 [ + + ]: 4964 : do ikpt=1,nkpt_rbz
3962 : 4756 : nband_k=nband_rbz(ikpt+(isppol-1)*nkpt_rbz)
3963 : 4756 : istwf_k=istwfk_rbz(ikpt)
3964 : 4756 : npw_k=npwarr(ikpt)
3965 : 4756 : npw1_k=npwar1(ikpt)
3966 : 4756 : wtk_k=wtk_rbz(ikpt)
3967 : :
3968 [ + + ]: 4756 : if(proc_distrb_cycle(mpi_enreg%proc_distrb,ikpt,1,nband_k,isppol,me)) then
3969 [ + + ]: 62112 : eigen1(1+bd2tot_index : 2*nband_k**2+bd2tot_index) = zero
3970 : 288 : bdtot_index=bdtot_index+nband_k
3971 : 288 : bd2tot_index=bd2tot_index+2*nband_k**2
3972 : : ! Skip the rest of the k-point loop
3973 : 288 : cycle
3974 : : end if
3975 : :
3976 [ - + + - : 17872 : ABI_MALLOC(ylm_k,(npw_k,psps%mpsang*psps%mpsang*psps%useylm))
+ + + - +
- + + - +
- + - + ]
3977 [ - + + - : 17872 : ABI_MALLOC(ylm1_k,(npw1_k,psps%mpsang*psps%mpsang*psps%useylm))
+ + + - +
- + + - +
- + - + ]
3978 [ - + + - : 17872 : ABI_MALLOC(ylmgr1_k,(npw1_k,3,psps%mpsang*psps%mpsang*psps%useylm*useylmgr1))
+ + + - +
- + + - +
- + - + ]
3979 : :
3980 : : ! Continue to initialize the Hamiltonian at k+q
3981 [ + + ]: 17872 : kpoint(:)=kpt_rbz(:,ikpt)
3982 [ + + ]: 17872 : kpq(:)=kpoint(:)+dtset%qptn(1:3)
3983 : :
3984 [ - + + - : 13404 : ABI_MALLOC(doccde_k,(nband_k))
+ - + - -
+ - + ]
3985 [ - + + - : 8936 : ABI_MALLOC(doccde_kq,(nband_k))
- + - + ]
3986 [ - + + - : 8936 : ABI_MALLOC(eig0_k,(nband_k))
- + - + ]
3987 [ - + + - : 8936 : ABI_MALLOC(eig0_kq,(nband_k))
- + - + ]
3988 [ + - - + : 13404 : ABI_MALLOC(eig1_k,(2*nband_k**2))
+ - + - +
- - + -
+ ]
3989 [ - + + - : 8936 : ABI_MALLOC(fe1fixed_k,(nband_k))
- + - + ]
3990 [ - + + - : 8936 : ABI_MALLOC(fe1norm_k,(nband_k))
- + - + ]
3991 [ - + + - : 8936 : ABI_MALLOC(occ_k,(nband_k))
- + - + ]
3992 [ - + + - : 8936 : ABI_MALLOC(occ_kq,(nband_k))
- + - + ]
3993 [ - + + - : 17872 : ABI_MALLOC(rocceig,(nband_k,nband_k))
- + + - +
- + - - +
- + ]
3994 : :
3995 [ + + ]: 623524 : eig1_k(:)=zero
3996 [ + + ]: 38762 : eig0_k(:)=eigen0(1+bdtot_index:nband_k+bdtot_index)
3997 [ + + ]: 38762 : eig0_kq(:)=eigenq(1+bdtot_index:nband_k+bdtot_index)
3998 [ + + ]: 38762 : occ_k(:)=occ_rbz(1+bdtot_index:nband_k+bdtot_index)
3999 [ + + ]: 38762 : occ_kq(:)=occkq(1+bdtot_index:nband_k+bdtot_index)
4000 [ + + ]: 38762 : doccde_k(:)=doccde_rbz(1+bdtot_index:nband_k+bdtot_index)
4001 [ + + ]: 38762 : doccde_kq(:)=docckqde(1+bdtot_index:nband_k+bdtot_index)
4002 : :
4003 : : ! For each pair of active bands (m,n), generates the ratios
4004 : : ! rocceig(m,n)=(occ_kq(m)-occ_k(n))/(eig0_kq(m)-eig0_k(n))
4005 : : ! and decide to which band to attribute it.
4006 : : call occeig(doccde_k,doccde_kq,eig0_k,eig0_kq,nband_k,&
4007 : 4468 : & dtset%occopt,occ_k,occ_kq,rocceig)
4008 : :
4009 : : ! Get plane-wave coeffs and related data at k
4010 [ + + + + ]: 2068404 : kg_k(:,1:npw_k)=kg(:,1+ikg:npw_k+ikg)
4011 [ + + ]: 4468 : if (psps%useylm==1) then
4012 [ + + ]: 2175 : do ilm=1,psps%mpsang*psps%mpsang
4013 [ + + ]: 651707 : ylm_k(1:npw_k,ilm)=ylm(1+ikg:npw_k+ikg,ilm)
4014 : : end do
4015 : : end if
4016 : :
4017 : : ! Get plane-wave coeffs and related data at k+q
4018 [ + + + + ]: 2068404 : kg1_k(:,1:npw1_k)=kg1(:,1+ikg1:npw1_k+ikg1)
4019 [ + + ]: 4468 : if (psps%useylm==1) then
4020 [ + + ]: 2175 : do ilm=1,psps%mpsang*psps%mpsang
4021 [ + + ]: 651707 : ylm1_k(1:npw1_k,ilm)=ylm1(1+ikg1:npw1_k+ikg1,ilm)
4022 : : end do
4023 [ + + ]: 435 : if (useylmgr1==1) then
4024 [ + + ]: 1350 : do ilm=1,psps%mpsang*psps%mpsang
4025 [ + + ]: 4590 : do ii=1,3
4026 [ + + ]: 1181952 : ylmgr1_k(1:npw1_k,ii,ilm)=ylmgr1(1+ikg1:npw1_k+ikg1,ii,ilm)
4027 : : end do
4028 : : end do
4029 : : end if
4030 : : end if
4031 : :
4032 : : ! Set up the ground-state Hamiltonian, and some parts of the 1st-order Hamiltonian
4033 : :
4034 : : ! Compute (k+G) vectors
4035 [ + - + + ]: 4468 : nkpg=0;if(ipert>=1.and.ipert<=natom) nkpg=3*dtset%nloalg(3)
4036 [ - + + - : 17872 : ABI_MALLOC(kpg_k,(npw_k,nkpg))
+ + + - +
- + + - +
- + - + ]
4037 [ + + ]: 4468 : if (nkpg>0) then
4038 : 165 : call mkkpg(kg_k,kpg_k,kpoint,nkpg,npw_k)
4039 : : end if
4040 : :
4041 : : ! Compute (k+q+G) vectors
4042 [ + - + + ]: 4468 : nkpg1=0;if(ipert>=1.and.ipert<=natom) nkpg1=3*dtset%nloalg(3)
4043 [ - + + - : 17872 : ABI_MALLOC(kpg1_k,(npw1_k,nkpg1))
+ + + - +
- + + - +
- + - + ]
4044 [ + + ]: 4468 : if (nkpg1>0) then
4045 : 165 : call mkkpg(kg1_k,kpg1_k,kpq,nkpg1,npw1_k)
4046 : : end if
4047 : :
4048 : : ! ===== Preparation of non-local contributions
4049 : :
4050 [ + + ]: 4468 : dimffnlk=0;if (ipert<=natom) dimffnlk=1
4051 [ - + + - : 26808 : ABI_MALLOC(ffnlk,(npw_k,dimffnlk,psps%lmnmax,dtset%ntypat))
+ + + - -
+ + - - +
+ - + - +
+ - + - +
- + ]
4052 : :
4053 : : ! Compute nonlocal form factors ffnlk at (k+G)
4054 [ + + ]: 4468 : if (ipert<=natom ) then
4055 : 2693 : ider=0;idir0=0
4056 : : call mkffnl(psps%dimekb,dimffnlk,psps%ekb,ffnlk,psps%ffspl,&
4057 : : & gmet,gprimd,ider,idir0,psps%indlmn,kg_k,kpg_k,kpoint,psps%lmnmax,&
4058 : : & psps%lnmax,psps%mpsang,psps%mqgrid_ff,nkpg,npw_k,dtset%ntypat,&
4059 : 2693 : & psps%pspso,psps%qgrid_ff,rmet,psps%usepaw,psps%useylm,ylm_k,ylmgr_dum)
4060 : : end if
4061 : :
4062 : : ! Compute nonlocal form factors ffnl1 at (k+q+G)
4063 : : !-- Atomic displacement perturbation
4064 [ + + ]: 4468 : if (ipert<=natom) then
4065 : 2693 : ider=0;idir0=0
4066 : : !-- Strain perturbation
4067 [ + + + + ]: 1775 : else if (ipert==natom+3.or.ipert==natom+4) then
4068 [ + + ]: 1743 : if (ipert==natom+3) istr=idir
4069 [ + + ]: 1743 : if (ipert==natom+4) istr=idir+3
4070 : 1743 : ider=1;idir0=-istr
4071 [ - + - - : 32 : else if (ipert==natom+5.or.ipert==natom+6.or.(ipert>natom+11.and.ipert<=2*natom+11)) then !SPr deb rfmagn
- - - - ]
4072 : 32 : ider=0;idir0=0
4073 : : end if
4074 [ + + - + ]: 4468 : dimffnl1=1+ider;if (ider==1.and.idir0==0) dimffnl1=dimffnl1+2*psps%useylm
4075 [ - + + - : 26808 : ABI_MALLOC(ffnl1,(npw1_k,dimffnl1,psps%lmnmax,dtset%ntypat))
- + + - -
+ + - - +
+ - + - +
- - + - +
- + ]
4076 : : call mkffnl(psps%dimekb,dimffnl1,psps%ekb,ffnl1,psps%ffspl,gmet,gprimd,ider,idir0,&
4077 : : & psps%indlmn,kg1_k,kpg1_k,kpq,psps%lmnmax,psps%lnmax,psps%mpsang,psps%mqgrid_ff,nkpg1,&
4078 : 4468 : & npw1_k,dtset%ntypat,psps%pspso,psps%qgrid_ff,rmet,psps%usepaw,psps%useylm,ylm1_k,ylmgr1_k)
4079 : :
4080 : : ! ===== Preparation of kinetic contributions
4081 : :
4082 [ - + + - : 13404 : ABI_MALLOC(dkinpw,(npw_k))
+ - + - -
+ - + -
+ ]
4083 [ - + + - : 13404 : ABI_MALLOC(kinpw1,(npw1_k))
+ - + - -
+ - + -
+ ]
4084 : :
4085 : : ! Compute the derivative of the kinetic operator vs strain in dkinpw
4086 [ + + + + ]: 4468 : if (ipert==natom+3.or.ipert==natom+4) then
4087 [ + + ]: 1743 : if (ipert==natom+3) istr=idir
4088 [ + + ]: 1743 : if (ipert==natom+4) istr=idir+3
4089 : : call kpgstr(dkinpw,dtset%ecut,dtset%ecutsm,dtset%effmass_free,gmet,gprimd,istr,&
4090 : 1743 : & kg_k,kpoint,npw_k)
4091 : : end if
4092 : :
4093 : : ! Compute (1/2) (2 Pi)**2 (k+q+G)**2:
4094 : : ! call mkkin(dtset%ecut,dtset%ecutsm,dtset%effmass_free,gmet,kg1_k,kinpw1,kpq,npw1_k)
4095 : 4468 : call mkkin(dtset%ecut,dtset%ecutsm,dtset%effmass_free,gmet,kg1_k,kinpw1,kpq,npw1_k,0,0)
4096 : :
4097 : : ! ===== Load the k/k+q dependent parts of the Hamiltonian
4098 : :
4099 : : ! Load k-dependent part in the Hamiltonian datastructure
4100 [ - + + - : 17872 : ABI_MALLOC(ph3d,(2,npw_k,gs_hamkq%matblk))
- + + - +
- + - - +
- + - + ]
4101 : : call gs_hamkq%load_k(kpt_k=kpoint,npw_k=npw_k,istwf_k=istwf_k,kg_k=kg_k,kpg_k=kpg_k,&
4102 : 4468 : & ph3d_k=ph3d,compute_ph3d=.true.,compute_gbound=.true.)
4103 [ + + + + ]: 22340 : if (size(ffnlk)>0) then
4104 : 2693 : call gs_hamkq%load_k(ffnl_k=ffnlk)
4105 : : else
4106 : 1775 : call gs_hamkq%load_k(ffnl_k=ffnl1)
4107 : : end if
4108 : :
4109 : : ! Load k+q-dependent part in the Hamiltonian datastructure
4110 : : ! Note: istwf_k is imposed to 1 for RF calculations (should use istwf_kq instead)
4111 : : call gs_hamkq%load_kprime(kpt_kp=kpq,npw_kp=npw1_k,istwf_kp=istwf_k,&
4112 : : & kinpw_kp=kinpw1,kg_kp=kg1_k,kpg_kp=kpg1_k,ffnl_kp=ffnl1,&
4113 : 4468 : & compute_gbound=.true.)
4114 [ - + ]: 4468 : if (qne0) then
4115 [ # # # # : 0 : ABI_MALLOC(ph3d1,(2,npw1_k,gs_hamkq%matblk))
# # # # #
# # # # #
# # # # ]
4116 : 0 : call gs_hamkq%load_kprime(ph3d_kp=ph3d1,compute_ph3d=.true.)
4117 : : end if
4118 : :
4119 : : ! Load k-dependent part in the 1st-order Hamiltonian datastructure
4120 : 4468 : call rf_hamkq%load_k(npw_k=npw_k,dkinpw_k=dkinpw)
4121 : :
4122 : : ! Compute fixed contributions to 1st-order Fermi energy
4123 : : ! and Fermi level charge density
4124 [ + + + + ]: 73056 : fe1fixed_k(:)=zero ; fe1norm_k(:)=zero
4125 : :
4126 : : ! Note that dfpt_wfkfermi is called with kpoint, while kpt is used inside dfpt_wfkfermi
4127 [ + - ]: 4468 : if (nspden/=4) then
4128 : : call dfpt_wfkfermi(cg,cgq,cplex,cprj,cprjq,dtfil,eig0_k,eig1_k,fe1fixed_k,&
4129 : : & fe1norm_k,gs_hamkq,ibg,ibgq,icg,icgq,idir,ikpt,ipert,isppol,dtset%kptopt,mband_mem,&
4130 : : & mcgq,mcprjq,mkmem,mpi_enreg,mpw,nband_k,ncpgr,npw_k,npw1_k,dtset%nspinor,nsppol,occ_k,&
4131 [ - + ]: 4468 : & pawrhoijfermi_unsym,prtvol,rf_hamkq,rhoaug,rocceig,wtk_k)
4132 : : else
4133 : : call dfpt_wfkfermi(cg,cgq,cplex,cprj,cprjq,dtfil,eig0_k,eig1_k,fe1fixed_k,&
4134 : : & fe1norm_k,gs_hamkq,ibg,ibgq,icg,icgq,idir,ikpt,ipert,isppol,dtset%kptopt,mband_mem,&
4135 : : & mcgq,mcprjq,mkmem,mpi_enreg,mpw,nband_k,ncpgr,npw_k,npw1_k,dtset%nspinor,nsppol,occ_k,&
4136 [ # # ]: 0 : & pawrhoijfermi_unsym,prtvol,rf_hamkq,rhoaug4,rocceig,wtk_k)
4137 : : end if
4138 : : ! Free temporary storage
4139 [ - + ]: 4468 : ABI_FREE(kpg_k)
4140 [ - + ]: 4468 : ABI_FREE(kpg1_k)
4141 [ - + ]: 4468 : ABI_FREE(dkinpw)
4142 [ - + ]: 4468 : ABI_FREE(ffnlk)
4143 [ - + ]: 4468 : ABI_FREE(ffnl1)
4144 [ - + ]: 4468 : ABI_FREE(kinpw1)
4145 [ - + ]: 4468 : ABI_FREE(doccde_k)
4146 [ - + ]: 4468 : ABI_FREE(doccde_kq)
4147 [ - + ]: 4468 : ABI_FREE(eig0_k)
4148 [ - + ]: 4468 : ABI_FREE(eig0_kq)
4149 [ - + ]: 4468 : ABI_FREE(occ_kq)
4150 [ - + ]: 4468 : ABI_FREE(rocceig)
4151 [ - + ]: 4468 : ABI_FREE(ylm_k)
4152 [ - + ]: 4468 : ABI_FREE(ylm1_k)
4153 [ - + ]: 4468 : ABI_FREE(ylmgr1_k)
4154 [ - + ]: 4468 : ABI_FREE(ph3d)
4155 [ - + ]: 4468 : ABI_SFREE(ph3d1)
4156 : :
4157 : : ! Save eigenvalues (hartree)
4158 [ + + ]: 623524 : eigen1 (1+bd2tot_index : 2*nband_k**2+bd2tot_index) = eig1_k(:)
4159 : :
4160 : : ! Accumulate sum over k points for 1st-order Fermi energy components
4161 [ + + ]: 38762 : do iband=1,nband_k
4162 : 34294 : fe1fixed=fe1fixed+wtk_k*occ_k(iband)*fe1fixed_k(iband)
4163 : 38762 : fe1norm=fe1norm+wtk_k*occ_k(iband)*fe1norm_k(iband)
4164 : : end do
4165 : :
4166 [ - + ]: 4468 : ABI_FREE(eig1_k)
4167 [ - + ]: 4468 : ABI_FREE(occ_k)
4168 [ - + ]: 4468 : ABI_FREE(fe1fixed_k)
4169 [ - + ]: 4468 : ABI_FREE(fe1norm_k)
4170 : :
4171 : : ! Keep track of total number of bands
4172 : : ! (all k points so far, even for k points not treated by me)
4173 : 4468 : bdtot_index=bdtot_index+nband_k
4174 : 4468 : bd2tot_index=bd2tot_index+2*nband_k**2
4175 : :
4176 : 4468 : nband_me = proc_distrb_nband(mpi_enreg%proc_distrb,ikpt,nband_k,isppol,me)
4177 : : ! Shift array memory
4178 [ + - ]: 4468 : if (mkmem/=0) then
4179 : 4468 : ibg=ibg+nband_me
4180 : 4468 : icg=icg+npw_k*dtset%nspinor*nband_me
4181 : 4468 : ikg=ikg+npw_k
4182 : : end if
4183 [ + - ]: 4468 : if (mkqmem/=0) then
4184 : 4468 : ibgq=ibgq+dtset%nspinor*nband_me
4185 : 4468 : icgq=icgq+npw1_k*dtset%nspinor*nband_me
4186 : : end if
4187 [ + - ]: 4676 : if (mk1mem/=0) then
4188 : 4468 : ikg1=ikg1+npw1_k
4189 : : end if
4190 : :
4191 : : ! End big k point loop
4192 : : end do
4193 : :
4194 : 208 : call timab(125,2,tsec)
4195 : :
4196 : : ! Transfer density on augmented fft grid to normal fft grid in real space
4197 : : ! Also take into account the spin.
4198 [ + - ]: 400 : if (nspden/=4) then
4199 [ + + ]: 208 : if (psps%usepaw==0) then
4200 : 93 : call fftpac(isppol,mpi_enreg,nspden,cplex*n1,n2,n3,cplex*n4,n5,n6,dtset%ngfft,rhorfermi,rhoaug,1)
4201 : : else
4202 : 115 : call fftpac(isppol,mpi_enreg,nspden,cplex*n1,n2,n3,cplex*n4,n5,n6,dtset%ngfft,rhowfr ,rhoaug,1)
4203 : : end if
4204 : : else
4205 [ # # ]: 0 : if (psps%usepaw==0) then
4206 [ # # ]: 0 : do ispden=1,4
4207 : 0 : call fftpac(ispden,mpi_enreg,nspden,cplex*n1,n2,n3,cplex*n4,n5,n6,dtset%ngfft,rhorfermi,rhoaug4(:,:,:,ispden),1)
4208 : : end do
4209 : : end if
4210 : : end if
4211 : :
4212 : : end do ! End loop over spins
4213 : :
4214 : : !More memory cleaning
4215 : 192 : call gs_hamkq%free()
4216 : 192 : call rf_hamkq%free()
4217 [ + + ]: 192 : if(psps%usepaw==1) then
4218 : 115 : call paw_ij_free(paw_ij1fr)
4219 [ + - + + : 371 : ABI_FREE(paw_ij1fr)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + ]
4220 : : end if
4221 [ + - ]: 192 : if (nspden/=4) then
4222 [ - + ]: 192 : ABI_FREE(rhoaug)
4223 : : else
4224 [ # # ]: 0 : ABI_FREE(rhoaug4)
4225 : : end if
4226 [ - + ]: 192 : ABI_FREE(kg_k)
4227 [ - + ]: 192 : ABI_FREE(kg1_k)
4228 : :
4229 : 192 : call timab(124,2,tsec)
4230 : :
4231 : : !=== MPI communications ==================
4232 : : if(xmpi_paral==1)then
4233 : 192 : call timab(129,1,tsec)
4234 : :
4235 : : ! Identify MPI buffer size
4236 : 192 : buffer_size=2
4237 [ - + - + ]: 192 : ABI_MALLOC(buffer1,(buffer_size))
4238 : :
4239 : : ! Pack fe1fixed, fe1norm
4240 : 192 : indx = 0
4241 : 192 : buffer1(indx+1)=fe1fixed
4242 : 192 : buffer1(indx+2)=fe1norm
4243 : 192 : indx=indx+2
4244 : : if(indx<buffer_size)buffer1(indx+1:buffer_size)=zero
4245 : :
4246 : : ! Build sum of everything
4247 : 192 : call timab(48,1,tsec)
4248 : 192 : call xmpi_sum(buffer1,buffer_size,spaceworld,ierr)
4249 : 192 : call timab(48,2,tsec)
4250 : :
4251 : : ! Unpack the final result
4252 : 192 : indx=0
4253 : 192 : fe1fixed=buffer1(indx+1) ; fe1norm =buffer1(indx+2)
4254 : 192 : ABI_FREE(buffer1)
4255 : :
4256 : 192 : call timab(48,1,tsec)
4257 : 192 : buffer_size=mbd2kpsp
4258 : 192 : call xmpi_sum(eigen1,buffer_size,spaceworld,ierr)
4259 : 192 : call timab(48,2,tsec)
4260 : :
4261 [ + + ]: 192 : if (psps%usepaw==0) then
4262 : 77 : call timab(48,1,tsec)
4263 : 77 : buffer_size = cplex*nfftf
4264 : : ! TODO: there should be a primitive for a 2d array here, but the compiler does not seem to find it.
4265 : : ! would simplify the call to xmpi_sum
4266 [ + + ]: 170 : do isppol=1, nspden
4267 : 170 : call xmpi_sum(rhorfermi(:,isppol),buffer_size,spaceworld,ierr)
4268 : : end do
4269 : 77 : call timab(48,2,tsec)
4270 : : else
4271 : 115 : call timab(48,1,tsec)
4272 : 115 : buffer_size = cplex*dtset%nfft
4273 [ + + ]: 230 : do isppol=1, nspden
4274 : 230 : call xmpi_sum(rhowfr(:,isppol),buffer_size,spaceworld,ierr)
4275 : : end do
4276 : 115 : call timab(48,2,tsec)
4277 : : end if
4278 : :
4279 : : ! Accumulate PAW occupancies
4280 [ + + ]: 192 : if (psps%usepaw==1) then
4281 : 115 : call pawrhoij_mpisum_unpacked(pawrhoijfermi_unsym,spaceworld)
4282 : : end if
4283 : :
4284 : 384 : call timab(129,2,tsec)
4285 : : end if ! if kpt parallel
4286 : : !=== End communications ==================
4287 : :
4288 : 192 : call timab(127,1,tsec)
4289 : :
4290 : : !Normalize the fixed part of fermie1
4291 [ + + ]: 192 : invfe1norm = zero ; if (abs(fe1norm) > tol10) invfe1norm=one/fe1norm
4292 : 192 : fe1fixed=fe1fixed*invfe1norm
4293 : :
4294 : :
4295 [ - + ]: 192 : if(nspden==4) then
4296 : : ! FR SPr symrhg will manage correctly this rearrangement
4297 [ # # ]: 0 : rhorfermi(:,2)=rhorfermi(:,2)+(rhorfermi(:,1)+rhorfermi(:,4)) !(n+mx)
4298 [ # # ]: 0 : rhorfermi(:,3)=rhorfermi(:,3)+(rhorfermi(:,1)+rhorfermi(:,4)) !(n+my)
4299 : 0 : call timab(17,2,tsec)
4300 : : end if
4301 : :
4302 : : !Symmetrize the density
4303 : : !In order to have the symrhg working in parallel on FFT coefficients, the size
4304 : : !of irzzon1 and phnons1 should be set to nfftot. Therefore, nsym\=1 does not work.
4305 : : !We also have the spin-up density, symmetrized, in rhorfermi(:,2).
4306 [ - + + - : 576 : ABI_MALLOC(rhogfermi,(2,dtset%nfft))
+ - + - -
+ - + ]
4307 [ + + ]: 192 : if (psps%usepaw==0) then
4308 : : call symrhg(cplex,gprimd,irrzon1,mpi_enreg,dtset%nfft,dtset%nfft,dtset%ngfft,nspden,&
4309 : 77 : & nsppol,nsym1,phnons1,rhogfermi,rhorfermi,rprimd,symaf1,symrl1,tnons1)
4310 : : else
4311 : : call symrhg(cplex,gprimd,irrzon1,mpi_enreg,dtset%nfft,dtset%nfft,dtset%ngfft,nspden,&
4312 : 115 : & nsppol,nsym1,phnons1,rhogfermi,rhowfr,rprimd,symaf1,symrl1,tnons1)
4313 : : end if
4314 : :
4315 : : !PAW: Build new rhoij quantities then symetrize them
4316 : : !Compute and add the compensation density to rhowfr to get the total density
4317 [ + + ]: 192 : if (psps%usepaw == 1) then
4318 [ + + + + ]: 345 : if (size(nhatfermi)>0) then
4319 : : call pawmkrho(1,arg,cplex,gprimd,0,indsy1,0,mpi_enreg,&
4320 : : & my_natom,natom,nspden,nsym1,dtset%ntypat,dtset%paral_kgb,pawang,pawfgr,&
4321 : : & pawfgrtab,-10001,pawrhoijfermi,pawrhoijfermi_unsym,pawtab,dtset%qptn,&
4322 : : & rhogfermi,rhowfr,rhorfermi,rprimd,symaf1,symrc1,dtset%typat,ucvol,&
4323 [ - + - - : 17 : & dtset%usewvl,xred,pawang_sym=pawang1,pawnhat=nhatfermi)
- - - - -
+ - - -
- ]
4324 : : else
4325 : : call pawmkrho(1,arg,cplex,gprimd,0,indsy1,0,mpi_enreg,&
4326 : : & my_natom,natom,nspden,nsym1,dtset%ntypat,dtset%paral_kgb,pawang,pawfgr,&
4327 : : & pawfgrtab,-10001,pawrhoijfermi,pawrhoijfermi_unsym,pawtab,dtset%qptn,&
4328 : : & rhogfermi,rhowfr,rhorfermi,rprimd,symaf1,symrc1,dtset%typat,ucvol,&
4329 : 98 : & dtset%usewvl,xred,pawang_sym=pawang1)
4330 : : end if
4331 [ - + ]: 115 : ABI_FREE(rhowfr)
4332 : 115 : call pawrhoij_free_unpacked(pawrhoijfermi_unsym)
4333 [ + + ]: 115 : if (paral_atom) then
4334 : 60 : call pawrhoij_free(pawrhoijfermi_unsym)
4335 [ - + ]: 60 : ABI_FREE(pawrhoijfermi_unsym)
4336 : : end if
4337 : : end if
4338 [ - + ]: 192 : ABI_FREE(rhogfermi)
4339 : :
4340 : : !Normalize the Fermi level charge density (and associated PAW occupancies)
4341 [ + + + + ]: 1447914 : rhorfermi(:,:)=invfe1norm*rhorfermi(:,:)
4342 [ + + ]: 192 : if (psps%usepaw==1) then
4343 [ + + + + : 138386 : if (size(nhatfermi)>0) nhatfermi(:,:)=invfe1norm*nhatfermi(:,:)
+ + + + ]
4344 [ + + ]: 371 : do iatom=1,my_natom
4345 [ + + ]: 627 : do ispden=1,nspden
4346 [ + + ]: 692 : do ilmn=1,pawrhoijfermi(iatom)%nrhoijsel
4347 : : pawrhoijfermi(iatom)%rhoijp(ilmn,ispden)=&
4348 : 436 : & pawrhoijfermi(iatom)%rhoijp(ilmn,ispden)*invfe1norm
4349 : : end do
4350 : : end do
4351 : : end do
4352 : : end if
4353 : :
4354 : 192 : call timab(127,2,tsec)
4355 : 192 : call timab(121,2,tsec)
4356 : :
4357 : : ABI_NVTX_END_RANGE()
4358 : : DBG_EXIT('COLL')
4359 : :
4360 [ + + - + : 384 : end subroutine dfpt_rhofermi
- + - + -
+ - + - +
- + - + -
+ - + - +
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + ]
4361 : : !!***
4362 : :
4363 : : !!****f* ABINIT/dfpt_wfkfermi
4364 : : !! NAME
4365 : : !! dfpt_wfkfermi
4366 : : !!
4367 : : !! FUNCTION
4368 : : !! This routine computes the partial Fermi-level density at a given k-point,
4369 : : !! and the fixed contribution to the 1st-order Fermi energy (nonlocal and kinetic)
4370 : : !!
4371 : : !! INPUTS
4372 : : !! cg(2,mpw*nspinor*mband_mem*mkmem*nsppol)=planewave coefficients of wavefunctions
4373 : : !! cgq(2,mcgq)=array for planewave coefficients of wavefunctions.
4374 : : !! cplex=1 if rhoaug is real, 2 if rhoaug is complex
4375 : : !! cprj(natom,nspinor*mband_mem*mkmem*nsppol*usecprj)= wave functions at k
4376 : : !! projected with non-local projectors: cprj=<p_i|Cnk>
4377 : : !! cprjq(natom,nspinor*mband_mem*mkqmem*nsppol*usecprj)= wave functions at k+q
4378 : : !! projected with non-local projectors: cprjq=<p_i|Cnk+q>
4379 : : !! dtfil <type(datafiles_type)>=variables related to files
4380 : : !! eig0_k(nband_k)=GS eigenvalues at k (hartree)
4381 : : !! gs_hamkq <type(gs_hamiltonian_type)>=all data for the Hamiltonian at k+q
4382 : : !! ibg=shift to be applied on the location of data in the array cprj
4383 : : !! ibgq=shift to be applied on the location of data in the array cprjq
4384 : : !! icg=shift to be applied on the location of data in the array cg
4385 : : !! icgq=shift to be applied on the location of data in the array cgq
4386 : : !! idir=direction of the current perturbation
4387 : : !! ikpt=number of the k-point
4388 : : !! ipert=type of the perturbation
4389 : : !! isppol=1 for unpolarized, 2 for spin-polarized
4390 : : !! kptopt=option for the generation of k points
4391 : : !! mband_mem=maximum number of bands on this cpu
4392 : : !! mcgq=second dimension of the cgq array
4393 : : !! mcprjq=second dimension of the cprjq array
4394 : : !! mkmem =number of k points treated by this node.
4395 : : !! mpi_enreg=information about MPI parallelization
4396 : : !! mpw=maximum dimensioned size of npw or wfs at k
4397 : : !! nband_k=number of bands at this k point for that spin polarization
4398 : : !! ncpgr=number of gradients stored in cprj array (cprj=<p_i|Cnk>)
4399 : : !! npw_k=number of plane waves at this k point
4400 : : !! npw1_k=number of plane waves at this k+q point
4401 : : !! nspinor=number of spinorial components of the wavefunctions
4402 : : !! nsppol=1 for unpolarized, 2 for spin-polarized
4403 : : !! occ_k(nband_k)=occupation number for each band (usually 2) for each k.
4404 : : !! prtvol=control print volume and debugging output
4405 : : !! rf_hamkq <type(gs_hamiltonian_type)>=all data for the 1st-order Hamiltonian at k,q
4406 : : !! rhoaug(cplex*n4,n5,n6)= density in electrons/bohr**3,
4407 : : !! on the augmented fft grid. (cumulative, so input as well as output)
4408 : : !! rocceig(nband_k,nband_k)= (occ_kq(m)-occ_k(n))/(eig0_kq(m)-eig0_k(n)),
4409 : : !! if this ratio has been attributed to the band n (second argument), zero otherwise
4410 : : !! wtk_k=weight assigned to the k point.
4411 : : !!
4412 : : !! OUTPUT
4413 : : !! eig1_k(2*nband_k**2)=first-order eigenvalues (hartree)
4414 : : !! fe1fixed_k(nband_k)=contribution to 1st-order Fermi energy
4415 : : !! from changes of occupation from all bands at this k point.
4416 : : !! fe1norm_k(nband_k)=contribution to normalization for above
4417 : : !! rhoaug(cplex*n4,n5,n6)= Fermi-level density in electrons/bohr**3,
4418 : : !! on the augmented fft grid. (cumulative, so input as well as output).
4419 : : !! ==== if (gs_hamkq%usepaw==1) ====
4420 : : !! pawrhoijfermi(natom) <type(pawrhoij_type)>= paw rhoij occupancies
4421 : : !! at Fermi level (cumulative, so input as well as output)
4422 : : !!
4423 : : !! SOURCE
4424 : :
4425 : 4468 : subroutine dfpt_wfkfermi(cg,cgq,cplex,cprj,cprjq,&
4426 : 4468 : & dtfil,eig0_k,eig1_k,fe1fixed_k,fe1norm_k,gs_hamkq,&
4427 : : & ibg,ibgq,icg,icgq,idir,ikpt,ipert,isppol,&
4428 : : & kptopt,mband_mem,mcgq,mcprjq,mkmem,mpi_enreg,mpw,nband_k,ncpgr,&
4429 : 4468 : & npw_k,npw1_k,nspinor,nsppol,occ_k,pawrhoijfermi,prtvol,&
4430 : 4468 : & rf_hamkq,rhoaug,rocceig,wtk_k)
4431 : :
4432 : : !Arguments ------------------------------------
4433 : : !scalars
4434 : : integer,intent(in) :: cplex,ibg,ibgq,icg,icgq,idir,ikpt
4435 : : integer,intent(in) :: ipert,isppol,kptopt,mcgq,mcprjq,mkmem,mpw,ncpgr
4436 : : integer,intent(in) :: mband_mem
4437 : : integer,intent(in) :: npw1_k,nspinor,nsppol,prtvol
4438 : : integer,intent(inout) :: nband_k,npw_k
4439 : : real(dp),intent(in) :: wtk_k
4440 : : type(MPI_type),intent(in) :: mpi_enreg
4441 : : type(datafiles_type),intent(in) :: dtfil
4442 : : type(gs_hamiltonian_type),intent(inout) :: gs_hamkq
4443 : : type(rf_hamiltonian_type),intent(inout) :: rf_hamkq
4444 : : !arrays
4445 : : real(dp),intent(in) :: cg(2,mpw*nspinor*mband_mem*mkmem*nsppol),cgq(2,mcgq)
4446 : : real(dp),intent(in) :: eig0_k(nband_k),occ_k(nband_k),rocceig(nband_k,nband_k)
4447 : : real(dp),intent(inout) :: rhoaug(cplex*gs_hamkq%n4,gs_hamkq%n5,gs_hamkq%n6,gs_hamkq%nvloc)
4448 : : real(dp),intent(inout) :: eig1_k(2*nband_k**2)
4449 : : real(dp),intent(out) :: fe1fixed_k(nband_k)
4450 : : real(dp),intent(out) :: fe1norm_k(nband_k)
4451 : : !TODO distribute cprj over bands
4452 : : type(pawcprj_type),intent(in) :: cprj(gs_hamkq%natom,nspinor*mband_mem*mkmem*nsppol*gs_hamkq%usecprj)
4453 : : type(pawcprj_type),intent(in) :: cprjq(gs_hamkq%natom,mcprjq)
4454 : : type(pawrhoij_type),intent(inout) :: pawrhoijfermi(gs_hamkq%natom*gs_hamkq%usepaw)
4455 : :
4456 : : !Local variables-------------------------------
4457 : : !scalars
4458 : : integer,parameter :: level=18
4459 : : integer :: berryopt,iband,ii,indx,iorder_cprj
4460 : : integer :: iband_me, nband_me
4461 : : integer :: ipw,me,nkpt_max,optlocal,optnl,opt_accrho,opt_corr
4462 : : integer :: opt_gvnlx1,sij_opt,tim_fourwf,tim_getgh1c,usevnl
4463 : : real(dp) :: dotr(1),lambda,wtband
4464 : : character(len=500) :: msg
4465 : : !arrays
4466 : : real(dp) :: dum_grad_berry(1,1),dum_gvnlx1(1,1),dum_gs1(1,1),tsec(2)
4467 : 4468 : real(dp),allocatable :: cwave0(:,:),cwaveq(:,:),gh1(:,:)
4468 : 4468 : type(pawcprj_type),allocatable :: cwaveprj0(:,:),cwaveprjq(:,:),cwaveprj_tmp(:,:)
4469 : : ! *********************************************************************
4470 : :
4471 : : DBG_ENTER('COLL')
4472 : : ABI_NVTX_START_RANGE(NVTX_DFPT_WFKFERMI)
4473 : :
4474 : : !Check arguments validity
4475 : : if (ipert>gs_hamkq%natom.and.ipert/=gs_hamkq%natom+3.and.ipert/=gs_hamkq%natom+4 &
4476 [ + + + + : 4468 : & .and.ipert/=gs_hamkq%natom+5.and.ipert/=gs_hamkq%natom+6 .and. &
+ + - + -
- - - -
- ]
4477 : : & (ipert>gs_hamkq%natom+11.and.ipert<=2*gs_hamkq%natom+11)) then !SPr rfmagn deb
4478 : 0 : ABI_BUG('wrong ipert argument !')
4479 : : end if
4480 [ - + ]: 4468 : if (cplex/=1) then
4481 : 0 : ABI_BUG('wrong cplex/=1 argument !')
4482 : : end if
4483 : :
4484 : : !Debugging statements
4485 [ - + ]: 4468 : if(prtvol==-level)then
4486 [ # # # # ]: 0 : write(msg,'(80a,a,a)') ('=',ii=1,80),ch10,'dfpt_wfkfermi : enter'
4487 : 0 : call wrtout(std_out,msg,'PERS')
4488 : : end if
4489 : 4468 : nkpt_max=50;if(xmpi_paral==1)nkpt_max=-1
4490 : :
4491 [ + + - + ]: 4468 : if(prtvol>2 .or. ikpt<=nkpt_max)then
4492 : 443 : write(msg, '(a,a,i5,2x,a,3f9.5,2x,a)' ) ch10,&
4493 : 886 : & ' Non-SCF iterations; k pt #',ikpt,'k=',gs_hamkq%kpt_k(:),' band residuals:'
4494 : 443 : call wrtout(std_out,msg,'PERS')
4495 : : end if
4496 : :
4497 : : !Retrieve parallelism data
4498 : 4468 : me=mpi_enreg%me_kpt
4499 : : !Initializations and allocations
4500 : :
4501 [ - + + - : 13404 : ABI_MALLOC(gh1,(2,npw1_k*nspinor))
+ - + - -
+ - + ]
4502 [ - + + - : 13404 : ABI_MALLOC(cwave0,(2,npw_k*nspinor))
+ - + - -
+ - + ]
4503 [ - + + - : 8936 : ABI_MALLOC(cwaveq,(2,npw1_k*nspinor))
- + - + ]
4504 [ + + ]: 623524 : iorder_cprj=0 ; eig1_k(:)=zero
4505 [ + + ]: 4468 : if (gs_hamkq%usepaw==1.and.gs_hamkq%usecprj==1) then
4506 [ - + + - : 3691 : ABI_MALLOC(cwaveprj0,(gs_hamkq%natom,nspinor))
- + + - +
- + - - +
- + - + +
+ + + ]
4507 [ - + + - : 3691 : ABI_MALLOC(cwaveprjq,(gs_hamkq%natom,nspinor))
- + + - +
- + - - +
- + + + +
+ ]
4508 : 435 : call pawcprj_alloc(cwaveprj0,1,gs_hamkq%dimcprj)
4509 : 435 : call pawcprj_alloc(cwaveprjq,0,gs_hamkq%dimcprj)
4510 : : else
4511 [ - + - + ]: 4033 : ABI_MALLOC(cwaveprj0,(0,0))
4512 [ - + ]: 4033 : ABI_MALLOC(cwaveprjq,(0,0))
4513 : : end if
4514 : : !Arguments of getgh1c routine (want only (NL+kin) frozen H(1))
4515 : 4468 : berryopt=0;usevnl=0;sij_opt=-gs_hamkq%usepaw;tim_getgh1c=3
4516 : 4468 : optlocal=0;optnl=1;opt_gvnlx1=0
4517 [ + + ]: 4468 : if(ipert==gs_hamkq%natom+5) optnl=0; ! no 1st order NL in H(1), also no kin, but this will be taken into account later
4518 [ - + ]: 4468 : if(ipert==gs_hamkq%natom+6) optnl=0; ! no 1st order NL in H(1), also no kin, but this will be taken into account later
4519 [ - + - - ]: 4468 : if(ipert>gs_hamkq%natom+11.and.ipert<=2*gs_hamkq%natom+11) optnl=0;
4520 : : !if(ipert==gs_hamkq%natom+5) optlocal=0; ! 1st order LOCAL potential present
4521 : :
4522 : : !Arguments of the dfpt_accrho routine
4523 : 4468 : tim_fourwf=5 ; opt_accrho=1 ; opt_corr=0
4524 : : !Null potentially unassigned output variables
4525 [ + + + + ]: 73056 : fe1fixed_k(:)=zero; fe1norm_k(:)=zero
4526 : :
4527 : : !Read the npw and kg records of wf files
4528 : 4468 : call timab(139,1,tsec)
4529 : :
4530 : : !Loop over bands
4531 : 4468 : iband_me = 0
4532 : 4468 : nband_me = proc_distrb_nband(mpi_enreg%proc_distrb,ikpt,nband_k,isppol,me)
4533 [ + + ]: 38762 : do iband=1,nband_k
4534 : :
4535 : : ! Skip bands not treated by current proc
4536 [ + - ]: 34294 : if(mpi_enreg%proc_distrb(ikpt, iband,isppol)/=me) cycle
4537 : 34294 : iband_me = iband_me + 1
4538 : :
4539 : : ! Select occupied bands
4540 [ + + + + ]: 38762 : if(abs(occ_k(iband))>tol8.and.abs(rocceig(iband,iband))>tol8)then
4541 : :
4542 : 6938 : wtband=rocceig(iband,iband)/occ_k(iband)
4543 : : ! Get ground-state wavefunctions at k
4544 [ + + ]: 890755 : do ipw=1,npw_k*nspinor
4545 : 883817 : cwave0(1,ipw)=cg(1,ipw+(iband_me-1)*npw_k*nspinor+icg)
4546 : 890755 : cwave0(2,ipw)=cg(2,ipw+(iband_me-1)*npw_k*nspinor+icg)
4547 : : end do
4548 : :
4549 [ + + ]: 6938 : if (gs_hamkq%usepaw==1.and.gs_hamkq%usecprj==1) then
4550 : : ! Read PAW ground state projected WF (cprj)
4551 : : ! cprj is already distributed in band and k, just get the corresponding cprj in cwaveprj0
4552 : : call pawcprj_get(gs_hamkq%atindx1,cwaveprj0,cprj,gs_hamkq%natom,iband_me,ibg,ikpt,iorder_cprj,&
4553 : : & isppol,mband_mem,mkmem,gs_hamkq%natom,1,nband_me,nspinor,nsppol,dtfil%unpaw,&
4554 : : !& mpicomm=mpi_enreg%comm_kpt,proc_distrb=mpi_enreg%proc_distrb,&
4555 : 52 : & icpgr=idir,ncpgr=ncpgr)
4556 : : end if
4557 : :
4558 : : ! Read ground-state wavefunctions at k+q
4559 : 6938 : indx=npw1_k*nspinor*(iband_me-1)+icgq
4560 [ + + + + ]: 2658389 : cwaveq(:,1:npw_k*nspinor)=wtband*cgq(:,1+indx:npw_k*nspinor+indx)
4561 [ + + ]: 6938 : if (gs_hamkq%usepaw==1.and.gs_hamkq%usecprj==1) then
4562 : : ! Read PAW ground state projected WF (cprj)
4563 : 52 : indx=nspinor*(iband_me-1)+ibgq
4564 : : ! TODO: cprj distributed -> iband_me
4565 : : !indx=nspinor*(iband-1)+ibgq
4566 : 52 : call pawcprj_copy(cprjq(:,1+indx:nspinor+indx),cwaveprjq)
4567 : 52 : call pawcprj_axpby(zero,wtband,cwaveprj_tmp,cwaveprjq)
4568 : : end if
4569 : :
4570 : : ! Apply H^(1)-Esp.S^(1) to Psi^(0) (H(^1)=only (NL+kin) frozen part)
4571 : 6938 : lambda=eig0_k(iband)
4572 : : call getgh1c(berryopt,cwave0,cwaveprj0,gh1,dum_grad_berry,dum_gs1,gs_hamkq,dum_gvnlx1,&
4573 : : & idir,ipert,(/lambda/),mpi_enreg,1,optlocal,optnl,opt_gvnlx1,rf_hamkq,sij_opt,&
4574 [ + + ]: 13876 : & tim_getgh1c,usevnl)
4575 : : ! Compute Eig1=<Psi^(0)|H^(1)-Eps.S^(1)|Psi(0)>
4576 : : call dotprod_g(dotr(1),lambda,gs_hamkq%istwf_k,npw_k*nspinor,1,cwave0,gh1,mpi_enreg%me_g0, &
4577 : 6938 : & mpi_enreg%comm_spinorfft)
4578 : 6938 : indx=2*iband-1+(iband-1)*2*nband_k
4579 : 6938 : eig1_k(indx)=dotr(1)
4580 : : ! Compute the fixed contribution to the 1st-order Fermi energy
4581 : 6938 : fe1fixed_k(iband)=two*wtband*eig1_k(indx)
4582 : 6938 : fe1norm_k(iband) =two*wtband
4583 : :
4584 : : ! Accumulate contribution to density and PAW occupation matrix
4585 : :
4586 : : call dfpt_accrho(cplex,cwave0,cwaveq,cwaveq,cwaveprj0,cwaveprjq,dotr(1),&
4587 : : gs_hamkq,iband,0,0,isppol,kptopt,mpi_enreg,1,gs_hamkq%natom,nband_k,ncpgr,&
4588 : : npw_k,npw1_k,nspinor,occ_k,opt_accrho,pawrhoijfermi,rhoaug,tim_fourwf,&
4589 : 6938 : opt_corr,wtk_k)
4590 : : end if ! End of non-zero occupation and rocceig
4591 : :
4592 : : end do ! End loop over bands
4593 : :
4594 : 4468 : call timab(139,2,tsec)
4595 : 4468 : call timab(130,1,tsec)
4596 : :
4597 [ - + ]: 4468 : ABI_FREE(cwave0)
4598 [ - + ]: 4468 : ABI_FREE(cwaveq)
4599 [ - + ]: 4468 : ABI_FREE(gh1)
4600 [ + + ]: 4468 : if (gs_hamkq%usepaw==1.and.gs_hamkq%usecprj==1) then
4601 : 435 : call pawcprj_free(cwaveprj0)
4602 : 435 : call pawcprj_free(cwaveprjq)
4603 : : end if
4604 [ + - + + : 5984 : ABI_FREE(cwaveprj0)
- + - + -
+ ]
4605 [ + - + + : 5984 : ABI_FREE(cwaveprjq)
- + - + -
+ ]
4606 : :
4607 : : !Structured debugging : if prtvol=-level, stop here.
4608 [ - + ]: 4468 : if(prtvol==-level)then
4609 : 0 : write(msg,'(a,a1,a,i2,a)')' fermie3 : exit prtvol=-',level,', debugging mode => stop '
4610 : 0 : ABI_ERROR(msg)
4611 : : end if
4612 : :
4613 : 4468 : call timab(130,2,tsec)
4614 : :
4615 : : ABI_NVTX_END_RANGE()
4616 : : DBG_EXIT('COLL')
4617 : :
4618 [ - + - - : 4468 : end subroutine dfpt_wfkfermi
- - - - ]
4619 : : !!***
4620 : :
4621 : : !!****f* ABINIT/dfpt_vtrial1_mq
4622 : : !! NAME
4623 : : !! dfpt_vtrial1_mq
4624 : : !!
4625 : : !! FUNCTION
4626 : : !! This routine computes the self-consistent potential at (-q,-omega).
4627 : : !!
4628 : : !! INPUTS
4629 : : !!
4630 : : !! OUTPUT
4631 : : !!
4632 : : !! SOURCE
4633 : :
4634 : 91 : subroutine dfpt_vtrial1_mq(cplex,nfftf,nspden,nvresid1,nvresid1_mq,vtrial1,vtrial1_mq)
4635 : :
4636 : : !Arguments ------------------------------------
4637 : : !scalars
4638 : : integer,intent(in) :: cplex,nfftf,nspden
4639 : :
4640 : : !arrays
4641 : : real(dp),intent(in) :: nvresid1(cplex*nfftf,nspden),vtrial1(cplex*nfftf,nspden)
4642 : : real(dp),intent(out) :: nvresid1_mq(cplex*nfftf,nspden),vtrial1_mq(cplex*nfftf,nspden)
4643 : :
4644 : : !Local variables-------------------------------
4645 : : !scalars
4646 : : integer :: ifft
4647 : : !arrays
4648 : :
4649 : : ! *********************************************************************
4650 : :
4651 : : DBG_ENTER('COLL')
4652 : :
4653 : : !TODO: proper fft parallelization...
4654 [ + + ]: 655451 : do ifft=1,nfftf
4655 : 655360 : vtrial1_mq(2*ifft-1,1)=+vtrial1(2*ifft-1,1)
4656 : 655360 : vtrial1_mq(2*ifft ,1)=-vtrial1(2*ifft ,1)
4657 : 655360 : nvresid1_mq(2*ifft-1,1)=+nvresid1(2*ifft-1,1)
4658 : 655451 : nvresid1_mq(2*ifft ,1)=-nvresid1(2*ifft ,1)
4659 : : end do
4660 [ + - ]: 91 : if (nspden >= 2) then
4661 [ + + ]: 655451 : do ifft=1,nfftf
4662 : 655360 : vtrial1_mq(2*ifft-1,2)=+vtrial1(2*ifft-1,2)
4663 : 655360 : vtrial1_mq(2*ifft ,2)=-vtrial1(2*ifft ,2)
4664 : 655360 : nvresid1_mq(2*ifft-1,2)=+nvresid1(2*ifft-1,2)
4665 : 655451 : nvresid1_mq(2*ifft ,2)=-nvresid1(2*ifft ,2)
4666 : : end do
4667 : : end if
4668 [ + - ]: 91 : if (nspden > 2) then
4669 [ + + ]: 655451 : do ifft=1,nfftf
4670 : 655360 : vtrial1_mq(2*ifft-1,3)= vtrial1(2*ifft ,4) !Re[V^12]
4671 : 655360 : vtrial1_mq(2*ifft ,3)= vtrial1(2*ifft-1,4) !Im[V^12],see definition of v(:,4) cplex=2 case
4672 : 655360 : vtrial1_mq(2*ifft ,4)= vtrial1(2*ifft-1,3) !Re[V^21]=Re[V^12]
4673 : 655360 : vtrial1_mq(2*ifft-1,4)= vtrial1(2*ifft ,3) !Re[V^21]=Re[V^12]
4674 : 655360 : nvresid1_mq(2*ifft-1,3)= nvresid1(2*ifft ,4) !Re[V^12]
4675 : 655360 : nvresid1_mq(2*ifft ,3)= nvresid1(2*ifft-1,4) !Im[V^12],see definition of v(:,4) cplex=2 case
4676 : 655360 : nvresid1_mq(2*ifft ,4)= nvresid1(2*ifft-1,3) !Re[V^21]=Re[V^12]
4677 : 655451 : nvresid1_mq(2*ifft-1,4)= nvresid1(2*ifft ,3) !Re[V^21]=Re[V^12]
4678 : : end do
4679 : : end if
4680 : :
4681 : : DBG_EXIT('COLL')
4682 : :
4683 : 91 : end subroutine dfpt_vtrial1_mq
4684 : : !!***
4685 : :
4686 : : end module m_dfpt_scfcv
4687 : : !!***
|
