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 +q and -q densities, this might bug if fft parallelization is used, todo...
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 : : !Implicictly avoids double counting of SCF and local energies
1086 : 0 : etotal=half*(etotal+etotal_mq)
1087 : 0 : evar=half*(evar+evar_mq)
1088 : 0 : deltae=half*(deltae+deltae_mq)
1089 : : end if
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 : : !Implicictly avoids double counting of SCF and local energies
1174 : 80 : etotal=half*(etotal+etotal_mq)
1175 : 80 : evar=half*(evar+evar_mq)
1176 : 80 : deltae=half*(deltae+deltae_mq)
1177 : : end if
1178 : :
1179 : 18632 : call timab(152,1,tsec)
1180 : 18632 : choice=2
1181 : : ! To take into account new definition of hdr_update;
1182 : : ! test to avoid dfpt and occopt 9 was already done
1183 : : ! so we can just set fermih = fermie
1184 [ + + + + : 18632 : if((iscf_mod>0).and.(dtset%nsppol==2.or.dtset%nspden>1)) then
+ + ]
1185 [ + + + + : 22148 : intgden0=intgden
+ + ]
1186 : : call calcdenmagsph(mpi_enreg,dtset%natom,nfftf,ngfftf,nspden,&
1187 : : & dtset%ntypat,dtset%ratsm,dtset%ratsph,rhor1,rprimd,dtset%typat,xred,&
1188 : 1568 : & prtopt,cplex,dtset%qgbt,dtset%use_gbt,intgden=intgden,dentot=dentot,rhomag=rhomag)
1189 : 1568 : call calmaxdifmag(cplex,intgden,intgden0,dtset%natom,dtset%nspden,maxmag,difmag)
1190 : : endif
1191 : : call scprqt(choice,cpus,deltae,diffor,maxmag,difmag,dtset,eigen0,&
1192 : : & etotal,favg,fcart,fermie,fermie,dtfil%fnametmp_eig,dtfil%filnam_ds(1),&
1193 : : & 1,iscf_mod,istep,istep_fock_outer,istep_mix,kpt_rbz,maxfor,&
1194 : : & mvdum,mpi_enreg,nband_rbz,nkpt_rbz,&
1195 : : & nstep,occ_rbz,0,prtfor,0,&
1196 : : & quit,res2,resid,residm,response,&
1197 : 18632 : & tollist,psps%usepaw,vxcavg,wtk_rbz,xred,conv_retcode)
1198 : : ! endif
1199 : 18632 : call timab(152,2,tsec)
1200 : :
1201 : : ! If criteria in scprqt say to quit, then exit the loop over istep
1202 : 18632 : quit_sum=quit
1203 : 18632 : call xmpi_sum(quit_sum,spaceComm,ierr)
1204 [ + + ]: 18632 : if (quit_sum>0) exit
1205 : :
1206 : : ! TODO
1207 : : ! Better error handling is the SCF cycle goes bananas:
1208 : : ! Write a BIG warning in the output file and save the wavefunctions.
1209 : : ! so that we can restart.
1210 [ + + ]: 16582 : if(iscf_mod/=-3)then
1211 : : ! Note that nvresid1 and vtrial1 are called vresid and vtrial inside this routine
1212 : : call dfpt_newvtr(cplex,dbl_nnsclo,dielar,dtset,etotal,pawfgr%fintocoa,&
1213 : : & initialized,iscf_mod,ispmix,istep,mix,pawfgr%coatofin,&
1214 : : & mpi_enreg,my_natom,nfftf,nfftmix,ngfftf,ngfftmix,npawmix,pawrhoij1,&
1215 [ + - - - : 13541 : & qphon,rhor1,rprimd,psps%usepaw,nvresid1,vtrial1)
- - + - -
- - - - +
- + ]
1216 : 13541 : initialized=1
1217 : : end if
1218 : : end if
1219 : :
1220 : : ! ######################################################################
1221 : : ! END MINIMIZATION ITERATIONS
1222 : : ! Note that there are different "exit" instructions within the loop
1223 : : ! ######################################################################
1224 : : end do ! istep
1225 : : ABI_NVTX_END_RANGE()
1226 : :
1227 : : ! Avoid pending requests if itime == ntime.
1228 : 2354 : call xmpi_wait(quitsum_request,ierr)
1229 [ - + ]: 2354 : if (timelimit_exit == 1) istep = istep - 1
1230 : :
1231 : : !SP : Here read the _DDB file and extract the Born effective charge and
1232 : : ! dielectric constant.
1233 : : ! The idea is to supress the divergence due to a residual Born effective charge
1234 : : ! by renormalizing the v_hart1. For this, the difference between the ionic
1235 : : ! Z_kappa and the Born effective charge divided by the dielectric constant is used.
1236 : : ! ---------------------------------------------------------------------------------
1237 [ + + + + : 2354 : if ((dtset%getddb .ne. 0 .or. dtset%irdddb .ne.0) .and. qzero .ne. 1) then
+ - ]
1238 [ - + + - : 48 : ABI_MALLOC(rhor2,(cplex*nfftf,nspden))
- + + - +
- + - - +
- + ]
1239 [ - + + - : 36 : ABI_MALLOC(resid2,(dtset%mband*nkpt_rbz*nspden))
+ - + - -
+ - + ]
1240 [ - + + - : 36 : ABI_MALLOC(rhog2,(2,nfftf))
+ - + - -
+ - + ]
1241 [ - + + - : 36 : ABI_MALLOC(vtrial2,(cplex*nfftf,nspden))
- + + - -
+ - + ]
1242 : :
1243 : 12 : Z_kappa = nint(psps%ziontypat(dtset%typat(ipert))) ! Charge ionic from the psp
1244 [ + + + + ]: 156 : qred2cart = two_pi*gprimd
1245 [ + + + + ]: 156 : q_cart = MATMUL(qred2cart,qphon)
1246 [ + + + + ]: 84 : q_cart = q_cart/SQRT(dot_product(q_cart,q_cart))
1247 [ + + + + : 192 : diel_q = dot_product(MATMUL(dielt,q_cart),q_cart)
+ + ]
1248 [ + + + + : 372 : zeff_bar = SUM(zeff(:,:,:),DIM=3)/dtset%natom
+ + ]
1249 [ + + + + : 192 : zeff_red = MATMUL(zeff_bar(:,:),rprimd(:,idir))/two_pi
+ + ]
1250 : : qphon_norm = SQRT(dot_product(qphon,qphon))
1251 [ + + + + ]: 156 : q_cart = MATMUL(qred2cart,qphon)
1252 [ + + ]: 48 : born_bar = dot_product(q_cart,zeff_red(:))
1253 [ + + + + : 192 : zeff_red = MATMUL(zeff(:,:,ipert),rprimd(:,idir))/two_pi
+ + ]
1254 [ + + ]: 48 : born = dot_product(q_cart,zeff_red(:))
1255 : :
1256 : : ! To avoid problem of divergence (0/0) we add a small value to qphon
1257 [ + + ]: 48 : qphon2 = qphon + tol6
1258 : 12 : renorm = (1-(qphon2(idir)*Z_kappa-(born-born_bar)/diel_q)/(qphon2(idir)*Z_kappa-born/diel_q))
1259 : :
1260 [ + + ]: 81012 : vtrial2(:,1) = vtrial1(:,1) -renorm*vhartr1
1261 : :
1262 : : call dfpt_vtorho(cg,cgq,cg1,cg1_active,cplex,cprj,cprjq,cprj1,&
1263 : : & dbl_nnsclo,dim_eig2rf,doccde_rbz,docckqde,dtefield,dtfil,dtset,dtset%qptn,edocc,&
1264 : : & eeig0,eigenq,eigen0,eigen1,ek0,ek1,eloc0,end0,end1,enl0,enl1,evxctau0,evxctau1,&
1265 : : & fermie1,gh0c1_set,gh1c_set,&
1266 : : & gmet,gprimd,idir,indsy1,ipert,irrzon1,istwfk_rbz,kg,kg1,kpt_rbz,dtset%mband,mband_mem_rbz,&
1267 : : & mkmem,mkqmem,mk1mem,mpi_enreg,mpw,mpw1,my_natom,dtset%natom,nband_rbz,ncpgr,nfftf,&
1268 : : & nhat1,nkpt_rbz,npwarr,npwar1,res3,nspden,dtset%nsppol,nsym1,dtset%ntypat,nvresid2,&
1269 : : & occkq,occ_rbz,optres,paw_ij,paw_ij1,pawang,pawang1,pawfgr,pawfgrtab,pawrhoij,&
1270 : : & pawrhoij1,pawtab,phnons1,ph1d,dtset%prtvol,psps,pwindall,qmat,resid2,residm2,rhog2,&
1271 : : & rhor2,rmet,rprimd,symaf1,symrc1,symrl1,tnons1,ucvol,usecprj,useylmgr1,usevxctau,ddk_f,&
1272 : 12 : & vectornd,vtrial,vtrial2,vxctau,with_vectornd,wtk_rbz,xred,ylm,ylm1,ylmgr1,1)
1273 : :
1274 : : write(msg,'(a)') ' '//char(10)//&
1275 : 12 : ' ---------------------------------'
1276 : 12 : call wrtout(ab_out,msg,'COLL')
1277 : : write(msg,'(a,a)')' The charge sum rule is activated'//char(10)//&
1278 : 12 : ' ---------------------------------'
1279 : 12 : call wrtout(ab_out,msg,'COLL')
1280 : 12 : write(msg,'(a,i4)') ' Z_ion (psp):',Z_kappa
1281 : 12 : call wrtout(ab_out,msg,'COLL')
1282 : 12 : write(msg,'(a,f12.8)') ' Residual Born effective charge: ',born
1283 : 12 : call wrtout(ab_out,msg,'COLL')
1284 : 12 : write(msg,'(a,f12.8)') ' Renormalisation: ',renorm
1285 : 12 : call wrtout(ab_out,msg,'COLL')
1286 [ + + ]: 12 : if (renorm > 0.01 ) then
1287 : : write(msg,'(a,a)')' WARNING: The renormalisation seems large (> 0.01).'//char(10)//&
1288 : 4 : ' You might consider increasing the k-point grid.'
1289 : 4 : ABI_WARNING(msg)
1290 : 4 : call wrtout(ab_out,msg,'COLL')
1291 : : end if
1292 : 12 : write(msg,'(a)') ' '
1293 : 12 : call wrtout(ab_out,msg,'COLL')
1294 : :
1295 [ - + ]: 12 : ABI_FREE(nvresid2)
1296 [ - + ]: 12 : ABI_FREE(rhor2)
1297 [ - + ]: 12 : ABI_FREE(resid2)
1298 [ - + ]: 12 : ABI_FREE(rhog2)
1299 [ - + ]: 12 : ABI_FREE(vtrial2)
1300 : : end if
1301 : :
1302 [ + + ]: 2354 : if (iscf_mod>0.or.iscf_mod==-3) then
1303 [ - + ]: 2230 : ABI_FREE(nvresid1)
1304 [ + + ]: 2230 : if (.not.kramers_deg) then
1305 [ - + ]: 11 : ABI_FREE(nvresid1_mq)
1306 : : end if
1307 : : end if
1308 : :
1309 : : !######################################################################
1310 : : !Additional steps after SC iterations
1311 : : !----------------------------------------------------------------------
1312 : :
1313 : 2354 : call timab(160,1,tsec)
1314 : :
1315 : : !Compute Dynamic magnetic charges (dmc) in case of rfphon,
1316 : : !and magnetic susceptibility in case of rfmagn from first order density
1317 : : !(results to be comapred to dmc from d2e)
1318 : : !SPr deb
1319 : : !if (ipert<=dtset%natom.and.dtset%nspden>=2) then
1320 : : !
1321 : : ! mpi_comm_sphgrid=mpi_enreg%comm_fft
1322 : : ! call mean_fftr(rhor1(:,1),mean_rhor1,nfftf,nfftotf,1,mpi_comm_sphgrid)
1323 : : ! write(*,*) ' Mean 1st order density: ', mean_rhor1
1324 : : ! call mean_fftr(rhor1(:,2),mean_rhor1,nfftf,nfftotf,1,mpi_comm_sphgrid)
1325 : : ! if (dtset%nspden==2) then
1326 : : ! write(*,*) ' 1st order m_z : ', mean_rhor1
1327 : : ! else !nspden==4
1328 : : ! write(*,*) ' 1st order m_x : ', mean_rhor1
1329 : : ! call mean_fftr(rhor1(:,3),mean_rhor1,nfftf,nfftotf,1,mpi_comm_sphgrid)
1330 : : ! write(*,*) ' 1st order m_y : ', mean_rhor1
1331 : : ! call mean_fftr(rhor1(:,4),mean_rhor1,nfftf,nfftotf,1,mpi_comm_sphgrid)
1332 : : ! write(*,*) ' 1st order m_z : ', mean_rhor1
1333 : : ! endif
1334 : : !
1335 : : !endif
1336 : :
1337 : :
1338 : : !Eventually close the DDK file, before calling dfpt_nstdy
1339 : : if ((ipert==dtset%natom+2.and.sum((dtset%qptn(1:3))**2)<=1.0d-7.and.&
1340 : : & (dtset%berryopt/=4 .and.dtset%berryopt/= 6.and.dtset%berryopt/= 7.and.&
1341 : : & dtset%berryopt/=14.and.dtset%berryopt/=16.and.dtset%berryopt/=17)).or.&
1342 [ + + + + : 9416 : & ipert==dtset%natom+10.or.ipert==dtset%natom+11) then
+ - + + +
+ + + ]
1343 : 370 : call ddk_f(1)%close()
1344 : : end if
1345 [ + + + + : 2354 : if ((ipert==dtset%natom+10 .and. idir>3) .or. ipert==dtset%natom+11) then
+ + ]
1346 : 130 : call ddk_f(2)%close()
1347 : : end if
1348 [ + + ]: 2354 : if (ipert==dtset%natom+11) then
1349 : 48 : call ddk_f(3)%close()
1350 [ + + ]: 48 : if(idir>3) call ddk_f(4)%close()
1351 : : end if
1352 : :
1353 : : !Deallocate the no more needed arrays
1354 [ + + + - ]: 2354 : if (iscf_mod>0.and.nstep>0) then
1355 : 1600 : call abi_mixing_deallocate(mix)
1356 : : end if
1357 [ + - + + : 2354 : if( (nstep>0 .and. iscf_mod>0) .or. iscf_mod==-1 ) then
- + ]
1358 [ - + ]: 1600 : ABI_FREE(dielinv)
1359 [ - + ]: 1600 : ABI_FREE(susmat)
1360 : : end if
1361 [ + + ]: 2354 : ABI_SFREE(rhorfermi)
1362 [ - + ]: 2354 : ABI_SFREE(rhorfermi_mq)
1363 [ + + ]: 2354 : ABI_SFREE(nhatfermi)
1364 [ + + ]: 2354 : if(allocated(pawrhoijfermi)) then
1365 : 192 : call pawrhoij_free(pawrhoijfermi)
1366 [ + - + + : 448 : ABI_FREE(pawrhoijfermi)
- + - + -
+ - + - +
- + - + ]
1367 : : end if
1368 [ + + ]: 2354 : if(psps%usepaw==1) then
1369 [ + - + - ]: 409 : if (mk1mem/=0.and.usecprj==1) then
1370 : 409 : call pawcprj_free(cprj1)
1371 : : end if
1372 [ + + ]: 1193 : do iatom=1,my_natom
1373 [ + + ]: 784 : if (pawfgrtab(iatom)%nhatfr_allocated>0) then
1374 [ - + ]: 377 : ABI_FREE(pawfgrtab(iatom)%nhatfr)
1375 : : end if
1376 : 1193 : pawfgrtab(iatom)%nhatfr_allocated=0
1377 : : end do
1378 [ + - + + ]: 409 : if (nstep>0.and.iscf_mod>0) then
1379 [ + + ]: 653 : do iatom=1,my_natom
1380 : 435 : pawrhoij1(iatom)%lmnmix_sz=0
1381 : 435 : pawrhoij1(iatom)%use_rhoijres=0
1382 [ - + ]: 435 : ABI_FREE(pawrhoij1(iatom)%kpawmix)
1383 [ - + ]: 653 : ABI_FREE(pawrhoij1(iatom)%rhoijres)
1384 : : end do
1385 : : end if
1386 : : end if ! PAW
1387 [ + - + + : 161230 : ABI_FREE(cprj1)
- + - + -
+ ]
1388 [ - + ]: 2354 : ABI_FREE(nhat1gr)
1389 : :
1390 : 2354 : call timab(160,2,tsec)
1391 : 2354 : call timab(150,1,tsec)
1392 : :
1393 [ + + + - : 2354 : if (psps%usepaw==0.and.dtset%userie/=919.and. &
+ + + + ]
1394 : : & (ipert==dtset%natom+3.or.ipert==dtset%natom+4)) then
1395 [ - + - - ]: 96 : if (.not.kramers_deg.and.abs(omega)>tol7) then
1396 : 0 : ABI_ERROR('Finte-omega calculations not yet implemented for rfstrs')
1397 : : end if
1398 : : call dfpt_nselt(blkflg,cg,cg1,cplex,&
1399 : : & d2bbb,d2lo,d2nl,ecut,dtset%ecutsm,dtset%effmass_free,&
1400 : : & gmet,gprimd,gsqcut,idir,&
1401 : : & ipert,istwfk_rbz,kg,kg1,kpt_rbz,kxc,dtset%mband,mband_mem_rbz,mgfftf,&
1402 : : & mkmem,mk1mem,mpert,mpi_enreg,psps%mpsang,mpw,mpw1,&
1403 : : & dtset%natom,nband_rbz,nfftf,ngfftf,&
1404 : : & nkpt_rbz,nkxc,dtset%nloalg,&
1405 : : & npwarr,npwar1,nspden,dtset%nspinor,dtset%nsppol,&
1406 : : & nsym1,dtset%ntypat,occ_rbz,&
1407 : : & ph1d,dtset%prtbbb,psps,dtset%qptn,rhog,&
1408 : : & rhor,rhor1,rmet,rprimd,symrc1,dtset%typat,ucvol,&
1409 : : & wtk_rbz,xred,ylm,ylm1,ylmgr,ylmgr1,&
1410 : 96 : & rfstrs_ref=dtset%rfstrs_ref)
1411 : : end if
1412 : :
1413 : : !Use of NSTPAW3 for NCPP (instead of DFPT_NSELT/DFPT_NSTDY) can be forced with userie=919
1414 : : !!MT oct. 2015: this works perfectly on all automatic tests
1415 : : !MS jan. 2025: As dfpt_nstpaw has been ported and optimised on OpenMP GPU,
1416 : : ! use it when OpenMP GPU is requested (outside of rfstrs).
1417 : : ! if(ipert<=dtset%natom+4)then
1418 [ + + + + ]: 2354 : if (ipert<dtset%natom+10.or.ipert>dtset%natom+11) then
1419 [ + + + - : 2175 : if (psps%usepaw==1.or.dtset%userie==919.or.&
- + - - -
- ]
1420 : : & (dtset%gpu_option==ABI_GPU_OPENMP.and.(ipert/=dtset%natom+3.and.ipert/=dtset%natom+4))) then
1421 : : call dfpt_nstpaw(blkflg,cg,cgq,cg1,cplex,cprj,cprjq,docckqde,doccde_rbz,dtfil,dtset,d2lo,d2nl,d2ovl,&
1422 : : & eigenq,eigen0,eigen1,eovl1,gmet,gprimd,gsqcut,idir,indkpt1,indsy1,ipert,irrzon1,istwfk_rbz,&
1423 : : & kg,kg1,kpt_rbz,kxc,mgfftf,mkmem,mkqmem,mk1mem,mpert,mpi_enreg,mpw,mpw1,nattyp,nband_rbz,mband_mem_rbz,ncpgr,&
1424 : : & nfftf,ngfftf,nhat,nhat1,nkpt_rbz,nkxc,npwarr,npwar1,nspden,dtset%nspinor,dtset%nsppol,&
1425 : : & nsym1,n3xccc,occkq,occ_rbz,paw_an,paw_an1,paw_ij,paw_ij1,pawang,pawang1,pawfgr,pawfgrtab,pawrad,&
1426 : : & pawrhoij,pawrhoij1,pawtab,phnons1,ph1d,ph1df,psps,rhog,rhor,rhor1,rmet,rprimd,symaf1,symrc1,&
1427 : : & symrl1,tnons1,ucvol,usecprj,psps%usepaw,usevxctau,usexcnhat,useylmgr1,vectornd,vhartr1,vpsp1,vtrial,vtrial1,&
1428 : 359 : & vxc,vxctau,with_vectornd,wtk_rbz,xccc3d1,xred,ylm,ylm1,ylmgr1)
1429 : : else
1430 [ + + ]: 1816 : if(kramers_deg) then
1431 [ + + ]: 1805 : if (dtset%nspden==4) then
1432 : : call dfpt_nstdy(atindx,blkflg,cg,cg1,cplex,dtfil,dtset,d2bbb,d2lo,d2nl,eigen0,eigen1,gmet,&
1433 : : & gsqcut,idir,indkpt1,indsy1,ipert,istwfk_rbz,kg,kg1,kpt_rbz,kxc,mband_mem_rbz,mkmem,mk1mem,mpert,mpi_enreg,&
1434 : : & mpw,mpw1,nattyp,nband_rbz,nfftf,ngfftf,nkpt,nkpt_rbz,nkxc,npwarr,npwar1,nspden,&
1435 : : & dtset%nsppol,nsym1,occ_rbz,ph1d,psps,qphon,rhor1,rmet,rprimd,symrc1,ucvol,&
1436 : 16 : & wtk_rbz,xred,ylm,ylm1,rhor=rhor,vxc=vxc,ixcrot=dtset%ixcrot)
1437 : : else
1438 : : call dfpt_nstdy(atindx,blkflg,cg,cg1,cplex,dtfil,dtset,d2bbb,d2lo,d2nl,eigen0,eigen1,gmet,&
1439 : : & gsqcut,idir,indkpt1,indsy1,ipert,istwfk_rbz,kg,kg1,kpt_rbz,kxc,mband_mem_rbz,mkmem,mk1mem,mpert,mpi_enreg,&
1440 : : & mpw,mpw1,nattyp,nband_rbz,nfftf,ngfftf,nkpt,nkpt_rbz,nkxc,npwarr,npwar1,nspden,&
1441 : : & dtset%nsppol,nsym1,occ_rbz,ph1d,psps,qphon,rhor1,rmet,rprimd,symrc1,ucvol,&
1442 : 1789 : & wtk_rbz,xred,ylm,ylm1)
1443 : : end if
1444 : : else if(.not.kramers_deg) then
1445 [ + - ]: 11 : if (dtset%nspden==4) then
1446 : : call dfpt_nstdy(atindx,blkflg,cg,cg1,cplex,dtfil,dtset,d2bbb_pq,d2lo_pq,d2nl_pq,eigen0,eigen1,gmet,&
1447 : : & gsqcut,idir,indkpt1,indsy1,ipert,istwfk_rbz,kg,kg1,kpt_rbz,kxc,mband_mem_rbz,mkmem,mk1mem,mpert,mpi_enreg,&
1448 : : & mpw,mpw1,nattyp,nband_rbz,nfftf,ngfftf,nkpt,nkpt_rbz,nkxc,npwarr,npwar1,nspden,&
1449 : : & dtset%nsppol,nsym1,occ_rbz,ph1d,psps,qphon,rhor1_pq,rmet,rprimd,symrc1,ucvol,&
1450 : 11 : & wtk_rbz,xred,ylm,ylm1,rhor=rhor,vxc=vxc,ixcrot=dtset%ixcrot)
1451 : : else
1452 : : call dfpt_nstdy(atindx,blkflg,cg,cg1,cplex,dtfil,dtset,d2bbb_pq,d2lo_pq,d2nl_pq,eigen0,eigen1,gmet,&
1453 : : & gsqcut,idir,indkpt1,indsy1,ipert,istwfk_rbz,kg,kg1,kpt_rbz,kxc,mband_mem_rbz,mkmem,mk1mem,mpert,mpi_enreg,&
1454 : : & mpw,mpw1,nattyp,nband_rbz,nfftf,ngfftf,nkpt,nkpt_rbz,nkxc,npwarr,npwar1,nspden,&
1455 : : & dtset%nsppol,nsym1,occ_rbz,ph1d,psps,qphon,rhor1_pq,rmet,rprimd,symrc1,ucvol,&
1456 : 0 : & wtk_rbz,xred,ylm,ylm1)
1457 : : end if
1458 [ + - ]: 11 : if (dtset%nspden==4) then
1459 : : call dfpt_nstdy(atindx,blkflg,cg,cg1_mq,cplex,dtfil,dtset,d2bbb_mq,d2lo_mq,d2nl_mq,eigen0,eigen1_mq,gmet,&
1460 : : & gsqcut,idir,indkpt1,indsy1,ipert,istwfk_rbz,kg,kg1_mq,kpt_rbz,kxc,mband_mem_rbz,mkmem,mk1mem,mpert,mpi_enreg,&
1461 : : & mpw,mpw1_mq,nattyp,nband_rbz,nfftf,ngfftf,nkpt,nkpt_rbz,nkxc,npwarr,npwar1_mq,nspden,&
1462 : : & dtset%nsppol,nsym1,occ_rbz,ph1d,psps,qphon_mq,rhor1_mq,rmet,rprimd,symrc1,ucvol,&
1463 : 11 : & wtk_rbz,xred,ylm,ylm1_mq,rhor=rhor,vxc=vxc,ixcrot=dtset%ixcrot)
1464 : : else
1465 : : call dfpt_nstdy(atindx,blkflg,cg,cg1_mq,cplex,dtfil,dtset,d2bbb_mq,d2lo_mq,d2nl_mq,eigen0,eigen1_mq,gmet,&
1466 : : & gsqcut,idir,indkpt1,indsy1,ipert,istwfk_rbz,kg,kg1_mq,kpt_rbz,kxc,mband_mem_rbz,mkmem,mk1mem,mpert,mpi_enreg,&
1467 : : & mpw,mpw1_mq,nattyp,nband_rbz,nfftf,ngfftf,nkpt,nkpt_rbz,nkxc,npwarr,npwar1_mq,nspden,&
1468 : : & dtset%nsppol,nsym1,occ_rbz,ph1d,psps,qphon_mq,rhor1_mq,rmet,rprimd,symrc1,ucvol,&
1469 : 0 : & wtk_rbz,xred,ylm,ylm1_mq)
1470 : : end if
1471 : :
1472 : : !Mix up (q,w) and (-q,-w) second-order derivatives
1473 [ - + - - : 11 : d2bbb(1,:,idir,ipert,:,:)=half*(d2bbb_pq(1,:,idir,ipert,:,:)+d2bbb_mq(1,:,idir,ipert,:,:))
- - ]
1474 [ - + - - : 11 : d2bbb(2,:,idir,ipert,:,:)=half*(d2bbb_pq(2,:,idir,ipert,:,:)-d2bbb_mq(2,:,idir,ipert,:,:))
- - ]
1475 [ + + + + ]: 843 : d2lo(1,:,:,idir,ipert)=half*(d2lo_pq(1,:,:,idir,ipert)+d2lo_mq(1,:,:,idir,ipert))
1476 [ + + + + ]: 843 : d2lo(2,:,:,idir,ipert)=half*(d2lo_pq(2,:,:,idir,ipert)-d2lo_mq(2,:,:,idir,ipert))
1477 [ + + + + ]: 843 : d2nl(1,:,:,idir,ipert)=half*(d2nl_pq(1,:,:,idir,ipert)+d2nl_mq(1,:,:,idir,ipert))
1478 [ + + + + ]: 843 : d2nl(2,:,:,idir,ipert)=half*(d2nl_pq(2,:,:,idir,ipert)-d2nl_mq(2,:,:,idir,ipert))
1479 : :
1480 : : end if
1481 : : end if
1482 : : end if
1483 : :
1484 : 2354 : call timab(150,2,tsec)
1485 : 2354 : call timab(160,1,tsec)
1486 : :
1487 : :
1488 : : !calculate Born effective charge and store it in d2lo
1489 : : if ((dtset%berryopt== 4.or.dtset%berryopt== 6.or.dtset%berryopt== 7.or.&
1490 [ + + + + ]: 2354 : & dtset%berryopt==14.or.dtset%berryopt==16.or.dtset%berryopt==17).and.&
1491 : : & ipert<=dtset%natom) then
1492 : : call dfptff_bec(cg,cg1,dtefield,dtset%natom,d2lo,idir,ipert,dtset%mband,mband_mem_rbz,mkmem,&
1493 : 6 : & mpi_enreg,mpw,mpw1,mpert,nkpt,npwarr,npwar1,dtset%nsppol,dtset%nspinor,pwindall,qmat,rprimd)
1494 [ + + + + : 162 : blkflg(:,dtset%natom+2,:,1:dtset%natom)=1
+ + ]
1495 : : end if
1496 : :
1497 : :
1498 : : !calculate dielectric tensor and store it in d2lo
1499 : : if ((dtset%berryopt== 4.or.dtset%berryopt== 6.or.dtset%berryopt== 7.or.&
1500 [ + + ]: 9 : & dtset%berryopt==14.or.dtset%berryopt==16.or.dtset%berryopt==17).and.&
1501 : : & ipert==dtset%natom+2) then
1502 : : call dfptff_die(cg,cg1,dtefield,d2lo,idir,ipert,dtset%mband,mband_mem_rbz,mkmem,&
1503 : 3 : & mpi_enreg,mpw,mpw1,mpert,nkpt,npwarr,npwar1,dtset%nsppol,dtset%nspinor,pwindall,qmat,rprimd)
1504 [ + + + + ]: 39 : blkflg(:,dtset%natom+2,:,dtset%natom+2)=1
1505 : : end if
1506 : :
1507 : :
1508 : : !If SCF convergence was not reached (for nstep>0),
1509 : : !print a warning to the output file (non-dummy arguments: nstep,
1510 : : !residm, diffor - infos from tollist have been saved inside )
1511 : : !Set also the value of conv_retcode
1512 : 2354 : choice=3
1513 : : call scprqt(choice,cpus,deltae,diffor,maxmag,difmag,dtset,eigen0,&
1514 : : & etotal,favg,fcart,fermie,fermie,dtfil%fnametmp_eig,dtfil%filnam_ds(1),&
1515 : : & 1,iscf_mod,istep,istep_fock_outer,istep_mix,kpt_rbz,maxfor,&
1516 : : & mvdum,mpi_enreg,nband_rbz,nkpt_rbz,&
1517 : : & nstep,occ_rbz,0,prtfor,0,&
1518 : : & quit,res2,resid,residm,response,&
1519 : 2354 : & tollist,psps%usepaw,vxcavg,wtk_rbz,xred,conv_retcode)
1520 : :
1521 : : !Update the content of the header (evolving variables)
1522 [ + + ]: 151816 : bantot_rbz = sum(nband_rbz(1:nkpt_rbz*dtset%nsppol))
1523 : : call hdr%update(bantot_rbz,etotal,fermie,fermie,&
1524 : : & residm,rprimd,occ_rbz,pawrhoij1,xred,dtset%amu_orig(:,1),&
1525 : 2354 : & comm_atom=mpi_enreg%comm_atom,mpi_atmtab=mpi_enreg%my_atmtab )
1526 : :
1527 : : !Optionally provide output of charge density and/or potential in real space,
1528 : : !as well as analysis of geometrical factors (bond lengths and bond angles).
1529 : : !Warnings :
1530 : : !- core charge is excluded from the charge density;
1531 : : !- the potential is the INPUT vtrial.
1532 : :
1533 [ + + + + ]: 2354 : if (ipert/=dtset%natom+1.and.dtset%prt1mag/=0) then
1534 : 12 : prtopt=1
1535 : : ! if(ipert==dtset%natom+5 .or. ipert==dtset%natom+6 .or. ipert>dtset%natom+11 ) then
1536 : : ! prtopt=idir+1;
1537 : : call calcdenmagsph(mpi_enreg,dtset%natom,nfftf,ngfftf,nspden,&
1538 : : & dtset%ntypat,dtset%ratsm,dtset%ratsph,rhor1,rprimd,dtset%typat,xred,&
1539 : : & prtopt,cplex,dtset%qgbt,dtset%use_gbt,intgden=intgden,dentot=dentot,rhomag=rhomag,&
1540 : 12 : & qphon=qphon)
1541 : :
1542 : : call magmom_to_d2(blkflg,cplex,d2lo,idir,intgden,ipert,mpert,&
1543 : 12 : & dtset%natom,nspden,rhomag)
1544 : : end if
1545 : : ! end if
1546 [ + + + + : 2354 : if((iscf_mod>0).and.(dtset%nsppol==2.or.dtset%nspden>1)) then
+ + ]
1547 [ + + ]: 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)
1548 : : endif
1549 : :
1550 : : !MR: Next call to calcdenmagsph is commented since it provides redundant information
1551 : : ! if(ipert==dtset%natom+5.or.ipert<=dtset%natom)then
1552 : : ! prtopt=1
1553 : : ! if(ipert==dtset%natom+5) then
1554 : : ! prtopt=idir+1;
1555 : : ! call calcdenmagsph(mpi_enreg,dtset%natom,nfftf,ngfftf,nspden,&
1556 : : ! & dtset%ntypat,dtset%ratsm,dtset%ratsph,rhor1,rprimd,dtset%typat,xred,&
1557 : : ! & prtopt,cplex,intgden=intgden,dentot=dentot,rhomag=rhomag)
1558 : : ! call prtdenmagsph(cplex,intgden,dtset%natom,nspden,dtset%ntypat,ab_out,prtopt,dtset%ratsm,dtset%ratsph,rhomag,dtset%typat)
1559 : : ! !debug: write out the vtk first-order density components
1560 : : ! ! call appdig(pertcase,dtfil%fnameabo_den,fi1o_vtk)
1561 : : ! ! call printmagvtk(mpi_enreg,cplex,nspden,nfftf,ngfftf,rhor1,rprimd,adjustl(adjustr(fi1o_vtk)//"_PQ"))
1562 : : ! ! call printmagvtk(mpi_enreg,cplex,nspden,nfftf,ngfftf,rhor1,rprimd,adjustl(adjustr(fi1o_vtk)//"_MQ"))
1563 : : ! !SPr: add calculation of the contributions to susceptibility from all atomic spheres
1564 : : ! end if
1565 : : ! end if
1566 : :
1567 [ + + ]: 2354 : if (iwrite_fftdatar(mpi_enreg)) then
1568 [ + + ]: 2053 : if (dtset%prtden>0) then
1569 : 1841 : rdwrpaw=0
1570 : 1841 : call appdig(pertcase,dtfil%fnameabo_den,fi1o)
1571 : : ! TODO: should we write pawrhoij1 or pawrhoij. Note that ioarr writes hdr%pawrhoij
1572 : : call fftdatar_write_from_hdr("first_order_density",fi1o,dtset%iomode,hdr,&
1573 : 1841 : ngfftf,cplex,nfftf,dtset%nspden,rhor1,mpi_enreg)
1574 : : end if
1575 : :
1576 : : ! Write first order potentials (needed by EPH)
1577 : : ! In DFPT, prtpot is automatically set to 1 unless the user set it to 0 explictly in the input
1578 : : ! See invars2
1579 : : ! (actually we should avoid writing 1WFK)
1580 [ + + ]: 2053 : if (dtset%prtpot > 0) then
1581 : 2006 : rdwrpaw=0
1582 : 2006 : call appdig(pertcase,dtfil%fnameabo_pot,fi1o)
1583 : : ! TODO: should we write pawrhoij1 or pawrhoij. Note that ioarr writes hdr%pawrhoij
1584 : : call fftdatar_write_from_hdr("first_order_potential",fi1o,dtset%iomode,hdr,&
1585 : 2006 : ngfftf,cplex,nfftf,dtset%nspden,vtrial1,mpi_enreg)
1586 : :
1587 : : ! Add rhog1(G=0) to file
1588 : : ! This part is obsolete. I keep it just to maintain compatibility with the fileformat.
1589 [ + - ]: 2006 : if (mpi_enreg%me_g0 == 1) then
1590 [ + - ]: 2006 : if (dtset%iomode == IO_MODE_ETSF) then
1591 [ - + ]: 2006 : NCF_CHECK(nctk_open_modify(ncid, nctk_ncify(fi1o), xmpi_comm_self))
1592 : 2006 : ncerr = nctk_def_one_array(ncid, nctkarr_t('rhog1_g0', "dp", "two"), varid=varid)
1593 [ - + ]: 2006 : NCF_CHECK(ncerr)
1594 [ - + ]: 2006 : NCF_CHECK(nctk_set_datamode(ncid))
1595 [ - + ]: 2006 : NCF_CHECK(nf90_put_var(ncid, varid, rhog1(:,1)))
1596 [ - + ]: 2006 : NCF_CHECK(nf90_close(ncid))
1597 : : else
1598 : : ! Handle Fortran files.
1599 [ # # ]: 0 : if (open_file(fi1o, msg, newunit=ncid, form='unformatted', status='old', action="readwrite") /= 0) then
1600 : 0 : ABI_ERROR(msg)
1601 : : end if
1602 [ # # ]: 0 : if (fort_denpot_skip(ncid, msg) /= 0) ABI_ERROR(msg)
1603 : 0 : write(ncid) rhog1(:,1)
1604 : 0 : close(ncid)
1605 : : end if
1606 : : end if
1607 : :
1608 : : end if
1609 : :
1610 : : ! output files for perturbed potential components: vhartr1,vpsp1,vxc
1611 : : ! NB: only 1 spin for these
1612 [ - + ]: 2053 : if (dtset%prtvha > 0) then
1613 : 0 : rdwrpaw=0
1614 [ # # # # : 0 : ABI_MALLOC(vhartr1_tmp, (cplex*nfftf, dtset%nspden))
# # # # #
# # # # #
# # ]
1615 [ # # # # ]: 0 : vhartr1_tmp = zero
1616 [ # # ]: 0 : vhartr1_tmp(:,1) = vhartr1(:)
1617 : 0 : call appdig(pertcase,dtfil%fnameabo_vha,fi1o)
1618 : : ! TODO: should we write pawrhoij1 or pawrhoij. Note that ioarr writes hdr%pawrhoij
1619 : : call fftdatar_write_from_hdr("first_order_vhartree",fi1o,dtset%iomode,hdr,&
1620 : 0 : ngfftf,cplex,nfftf,dtset%nspden,vhartr1_tmp,mpi_enreg)
1621 [ # # ]: 0 : ABI_FREE(vhartr1_tmp)
1622 : : end if
1623 : :
1624 : : ! vpsp1 needs to be copied to a temp array - intent(inout) in fftdatar_write_from_hdr though I do not know why
1625 : : ! if (dtset%prtvpsp > 0) then
1626 : : ! rdwrpaw=0
1627 : : ! call appdig(pertcase,dtfil%fnameabo_vpsp,fi1o)
1628 : : ! ! TODO: should we write pawrhoij1 or pawrhoij. Note that ioarr writes hdr%pawrhoij
1629 : : ! call fftdatar_write_from_hdr("first_order_vpsp",fi1o,dtset%iomode,hdr,&
1630 : : ! ngfftf,cplex,nfftf,1,vpsp1,mpi_enreg)
1631 : : ! end if
1632 : :
1633 [ - + ]: 2053 : if (dtset%prtvxc > 0) then
1634 : 0 : rdwrpaw=0
1635 : 0 : call appdig(pertcase,dtfil%fnameabo_vxc,fi1o)
1636 : : ! TODO: should we write pawrhoij1 or pawrhoij. Note that ioarr writes hdr%pawrhoij
1637 : : call fftdatar_write_from_hdr("first_order_vxc",fi1o,dtset%iomode,hdr,&
1638 : 0 : ngfftf,cplex,nfftf,dtset%nspden,vxc1,mpi_enreg)
1639 : : end if
1640 : :
1641 : : end if ! iwrite_fftdatar(mpi_enreg)
1642 : :
1643 : : !All procs waiting here...
1644 [ - + ]: 2354 : if(mpi_enreg%paral_kgb==1)then
1645 : 0 : call timab(61,1,tsec)
1646 : 0 : call xmpi_barrier(spaceComm)
1647 : 0 : call timab(61,2,tsec)
1648 : : end if
1649 : :
1650 : : !Deallocate arrays
1651 : : #ifdef HAVE_OPENMP_OFFLOAD
1652 : : !$OMP TARGET EXIT DATA MAP(delete:cgq) IF(dtset%gpu_option==ABI_GPU_OPENMP)
1653 : : #endif
1654 : :
1655 [ - + ]: 2354 : ABI_FREE(fcart)
1656 [ - + ]: 2354 : ABI_FREE(vtrial1)
1657 [ + + ]: 2354 : if (.not.kramers_deg) then
1658 [ - + ]: 11 : ABI_FREE(vtrial1_mq)
1659 [ - + ]: 11 : ABI_FREE(d2bbb_mq)
1660 [ - + ]: 11 : ABI_FREE(d2lo_mq)
1661 [ - + ]: 11 : ABI_FREE(d2nl_mq)
1662 [ - + ]: 11 : ABI_FREE(d2bbb_pq)
1663 [ - + ]: 11 : ABI_FREE(d2lo_pq)
1664 [ - + ]: 11 : ABI_FREE(d2nl_pq)
1665 : : end if
1666 [ - + ]: 2354 : ABI_FREE(vhartr1)
1667 [ - + ]: 2354 : ABI_FREE(vxc1)
1668 [ - + ]: 2354 : ABI_FREE(pwindall)
1669 [ - + + + ]: 2354 : ABI_FREE(qmat)
1670 : : if (dtset%berryopt== 4.or.dtset%berryopt== 6.or.dtset%berryopt== 7.or.&
1671 : : dtset%berryopt==14.or.dtset%berryopt==16.or.dtset%berryopt==17) then
1672 : 9 : call dtefield%free()
1673 [ - + ]: 9 : ABI_SFREE(mpi_enreg%kpt_loc2ibz_sp)
1674 : : end if
1675 : :
1676 [ + - ]: 2354 : ABI_SFREE(vectornd)
1677 : :
1678 [ + + ]: 2354 : if(psps%usepaw==1) then
1679 : 409 : call paw_an_free(paw_an1)
1680 : 409 : call paw_ij_free(paw_ij1)
1681 : : end if
1682 [ + - + + : 3138 : ABI_FREE(paw_an1)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + -
+ ]
1683 [ + - + + : 3138 : ABI_FREE(paw_ij1)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + ]
1684 [ - + ]: 2354 : ABI_FREE(nhat1)
1685 : :
1686 : 2354 : call timab(160,2,tsec)
1687 : 2354 : call timab(120,2,tsec)
1688 : :
1689 : : DBG_EXIT("COLL")
1690 : :
1691 [ + + + + : 9438 : end subroutine dfpt_scfcv
- + - + -
+ - + - +
- + - - -
- - - - -
- - - - -
- - + - +
+ + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - -
- - - - -
+ - + - +
- + - + -
+ - + -
+ ]
1692 : : !!***
1693 : :
1694 : : !!****f* ABINIT/dfpt_etot
1695 : : !! NAME
1696 : : !! dfpt_etot
1697 : : !!
1698 : : !! FUNCTION
1699 : : !! Assemble different contributions to the variational part of the
1700 : : !! 2nd derivative of total energy
1701 : : !!
1702 : : !! INPUTS
1703 : : !! berryopt= 4/14: electric field is on; berryopt = 6/7/16/17: electric displacement field is on;
1704 : : !! eberry=energy associated with Berry phase
1705 : : !! edocc=correction to 2nd-order total energy coming from changes of occupation
1706 : : !! ehart1=1st-order Hartree part of 2nd-order total energy
1707 : : !! eeig0=0th-order eigenenergies part of 2nd-order total energy
1708 : : !! eew=2nd derivative of Ewald energy (hartree)
1709 : : !! efrhar=contrib. from frozen-wavefunction, hartree energy, to the 2nd-derivative of total energy
1710 : : !! efrkin=contrib. from frozen-wavefunction, kinetic energy, to the 2nd-derivative of total energy
1711 : : !! efrloc=contrib. from frozen-wavefunction, local potential, to the 2nd-derivative of total energy
1712 : : !! efrnl=contribution from frozen-wavefunction, non-local potential, to the 2nd-derivative of total energy
1713 : : !! efrx1=contrib. from frozen-wavefunction, xc core correction(1), to the 2nd-derivative of total energy
1714 : : !! efrx2=contribution from frozen-wavefunction, xc core correction(2),
1715 : : !! to the second-derivative of total energy.
1716 : : !! ek0=0th-order kinetic energy part of 2nd-order total energy.
1717 : : !! ek1=1st-order kinetic energy part of 2nd-order total energy.
1718 : : !! eii=2nd derivative of pseudopotential core energy (hartree)
1719 : : !! elmag1=1st-order Zeeman part of 2nd-order total energy.
1720 : : !! eloc0=0th-order local (psp+vxc+Hart) part of 2nd-order total energy
1721 : : !! elpsp1=1st-order local pseudopot. part of 2nd-order total energy.
1722 : : !! emagpen1= Magnetic penalty term entering the 2nd-onder total energy.
1723 : : !! end0=0th-order nuclear dipole energy part of 2nd-order total energy.
1724 : : !! end1=1st-order nuclear dipole energy part of 2nd-order total energy.
1725 : : !! enl0=0th-order nonlocal pseudopot. part of 2nd-order total energy.
1726 : : !! enl1=1st-order nonlocal pseudopot. part of 2nd-order total energy.
1727 : : !! epaw1=1st-order PAW on-sitew part of 2nd-order total energy.
1728 : : !! evdw=DFT-D semi-empirical part of 2nd-order total energy
1729 : : !! evxctau0=0th-order vxctau energy
1730 : : !! evxctau1=1st-order vxctau energy
1731 : : !! exc1=1st-order exchange-correlation part of 2nd-order total energy
1732 : : !! ipert=type of the perturbation
1733 : : !! natom=number of atoms
1734 : : !! optene=option for the computation of 2nd-order total energy
1735 : : !! (-1=no computation; 0=direct scheme; 1=double-counting scheme)
1736 : : !!
1737 : : !! OUTPUT
1738 : : !! deltae=change in energy between the previous and present SCF cycle
1739 : : !! and previous SCF cycle.
1740 : : !! etotal=2nd-order total energy
1741 : : !! evar=variational part of the 2nd-order total energy
1742 : : !!
1743 : : !! SIDE EFFECTS
1744 : : !! input/output
1745 : : !! elast=previous value of the 2nd-order total energy, needed to compute deltae,
1746 : : !! then updated (cannot simply be saved, because set to zero
1747 : : !! at each new call of dfpt_scfcv).
1748 : : !!
1749 : : !! SOURCE
1750 : :
1751 : 18712 : subroutine dfpt_etot(berryopt,deltae,eberry,edocc,eeig0,eew,efrhar,efrkin,efrloc,&
1752 : : & efrnl,efrx1,efrx2,ehart1,ek0,ek1,eii,elast,elmag1,eloc0,elpsp1,emagpen1,&
1753 : : & end0,end1,enl0,enl1,epaw1,etotal,evar,evdw,evxctau0,evxctau1,&
1754 : : & exc1,ipert,natom,optene)
1755 : :
1756 : : !Arguments ------------------------------------
1757 : : !scalars
1758 : : integer,intent(in) :: berryopt,ipert,natom,optene
1759 : : real(dp),intent(in) :: eberry,edocc,eeig0,eew,efrhar,efrkin,efrloc,efrnl,efrx1
1760 : : real(dp),intent(in) :: efrx2,ehart1,eii,ek0,ek1,elmag1,eloc0,elpsp1,emagpen1,end0,end1,enl0,enl1,epaw1
1761 : : real(dp),intent(in) :: evdw,evxctau0,evxctau1,exc1
1762 : : real(dp),intent(inout) :: elast
1763 : : real(dp),intent(out) :: deltae,etotal,evar
1764 : :
1765 : : !Local variables-------------------------------
1766 : : !scalars
1767 : : ! character(len=500) :: msg
1768 : : ! *********************************************************************
1769 : :
1770 [ - + ]: 18712 : if (optene==1) then
1771 : 0 : ABI_BUG('Double-counting scheme not yet allowed!')
1772 : : end if
1773 : :
1774 [ + - ]: 18712 : if (optene>-1) then
1775 : :
1776 : : ! Compute 2nd-order variational energy by direct scheme
1777 [ + - ]: 18712 : if (optene==0) then
1778 : :
1779 : : ! Atomic displ. perturbation
1780 [ + - + + ]: 18712 : if ( ipert>=1 .and. ipert<=natom ) then
1781 : 11388 : evar=ek0+edocc+eeig0+eloc0+enl0+ehart1+exc1+enl1+epaw1+elpsp1+emagpen1
1782 : :
1783 [ + + ]: 7324 : else if (ipert==natom+1) then
1784 : 3422 : evar=ek0+edocc+eeig0+eloc0+ek1+ehart1+exc1+enl0+enl1+end0+end1+evxctau0+evxctau1
1785 : :
1786 [ + + + + ]: 3902 : else if (ipert==natom+10 .or. ipert==natom+11) then
1787 : 179 : evar=ek0+edocc+eeig0+eloc0+enl0 +ek1 ! here ek1 contains a lot of contributions
1788 : :
1789 : : ! For ipert==natom+2, some contributions vanish, noticeably ek1
1790 [ + + ]: 3723 : else if (ipert==natom+2) then
1791 : 2067 : evar=ek0+edocc+eeig0+eloc0+enl0+ehart1+exc1+enl1+ek1+epaw1+emagpen1
1792 : :
1793 : : ! All terms enter for strain perturbation
1794 [ + + + + ]: 1656 : else if ( ipert==natom+3 .or. ipert==natom+4 ) then
1795 : 1507 : evar=ek0+edocc+eeig0+eloc0+enl0+ehart1+exc1+enl1+ek1+epaw1+elpsp1
1796 : :
1797 : : ! terms for Zeeman or scalar potential perturbation, SPr 2deb
1798 [ + + + + ]: 149 : else if ( ipert==natom+5 .or. ipert==natom+6 ) then
1799 : 125 : evar=ek0+edocc+eeig0+eloc0+enl0+ehart1+exc1+epaw1+emagpen1+elmag1
1800 : :
1801 : : ! terms for atomic-spheres local Zeeman perturbation
1802 [ + - + - ]: 24 : else if ( ipert>natom+11.and.ipert<=2*natom+11 ) then
1803 : 24 : evar=ek0+edocc+eeig0+eloc0+enl0+ehart1+exc1+epaw1+emagpen1+elmag1
1804 : : end if
1805 : : end if
1806 : :
1807 : : ! Compute energy residual
1808 : 18712 : deltae=evar-elast
1809 : 18712 : elast=evar
1810 : :
1811 : : ! Compute 2nd-order total energy by direct scheme
1812 [ + - ]: 18712 : if (optene==0) then
1813 [ + + ]: 18712 : if (berryopt==4 .or. berryopt==6 .or. berryopt==7 .or. berryopt==14 .or. berryopt==16 .or. berryopt==17) then
1814 [ + + ]: 97 : if (ipert<=natom) then
1815 : 61 : etotal=evar+eew+evdw+eii+efrhar+efrkin+efrloc+efrnl+efrx1+efrx2+two*eberry
1816 [ + - ]: 36 : else if (ipert==natom+2) then
1817 : 36 : etotal=half*evar+eew+evdw+eii+efrhar+efrkin+efrloc+efrnl+efrx1+efrx2+two*eberry
1818 : : end if
1819 : : else
1820 [ + + + + ]: 18615 : if (ipert/=natom+10 .and. ipert/=natom+11) then
1821 : 18436 : etotal=evar+eew+evdw+eii+efrhar+efrkin+efrloc+efrnl+efrx1+efrx2
1822 : : else
1823 : 179 : etotal=evar ! For 2nd order sternheimer equations, the total (4th order) energy is not used (yet)
1824 : : end if
1825 : : end if
1826 : : end if
1827 : :
1828 : : end if
1829 : :
1830 : 18712 : end subroutine dfpt_etot
1831 : : !!***
1832 : :
1833 : : !!****f* ABINIT/newfermie1
1834 : : !! NAME
1835 : : !! newfermie1
1836 : : !!
1837 : : !! FUNCTION
1838 : : !! This routine computes the derivative of the fermi energy wrt
1839 : : !! the active perturbation for use in evaluating the edocc term
1840 : : !! and active subspace contribution to the first-order wavefunctions
1841 : : !! in the case of metals. This is presently used only for the
1842 : : !! strain and magnetic field perturbations, and only for Q = 0.
1843 : : !!
1844 : : !! INPUTS
1845 : : !! cplex: if 1, real space 1-order functions on FFT grid are REAL,
1846 : : !! if 2, COMPLEX
1847 : : !! fe1fixed=fixed contribution to the first-order Fermi energy
1848 : : !! ipert=index of perturbation
1849 : : !! istep=index of the number of steps in the routine scfcv
1850 : : !! ixc= choice of exchange-correlation scheme
1851 : : !! mpi_atmtab(:)=--optional-- indexes of the atoms treated by current proc
1852 : : !! comm_atom=--optional-- MPI communicator over atoms
1853 : : !! my_natom=number of atoms treated by current processor
1854 : : !! natom=number of atoms
1855 : : !! nfft=(effective) number of FFT grid points (for this processor)
1856 : : !! nfftot= total number of FFT grid points
1857 : : !! nhatfermi(nfft,nspden)=fermi-level compensation charge density (PAW only)
1858 : : !! nspden=number of spin-density components
1859 : : !! ntypat=number of atom types
1860 : : !! occopt=option for occupancies
1861 : : !! paw_an(natom) <type(paw_an_type)>=paw arrays for 0th-order quantities given on angular mesh
1862 : : !! paw_an1(natom) <type(paw_an_type)>=paw arrays for 1st-order quantities given on angular mesh
1863 : : !! paw_ij1(natom) <type(paw_ij_type)>=(1st-order) paw arrays given on (i,j) channels
1864 : : !! pawang <type(pawang_type)>=paw angular mesh and related data
1865 : : !! pawnzlm=-- PAW only -- option for the computation of non-zero
1866 : : !! lm moments of the on-sites densities
1867 : : !! pawrad(ntypat) <type(pawrad_type)>=paw radial mesh and related data
1868 : : !! pawrhoij1(natom) <type(pawrhoij_type)>= paw rhoij 1st-order occupancies
1869 : : !! pawrhoijfermi(natom) <type(pawrhoij_type)>=paw rhoij occupancies at Fermi level
1870 : : !! pawtab(ntypat) <type(pawtab_type)>=paw tabulated starting data
1871 : : !! pawxcdev=Choice of XC development (0=no dev. (use of angular mesh) ; 1 or 2=dev. on moments)
1872 : : !! xclevel= XC functional level
1873 : : !! prtvol=control print volume and debugging output
1874 : : !! rhorfermi(nfft,nspden)=fermi-level electronic density
1875 : : !! ucvol=unit cell volume in bohr**3
1876 : : !! usepaw=1 if PAW is activated
1877 : : !! usexcnhat= -PAW only- flag controling use of compensation density in Vxc
1878 : : !! vtrial1(cplex*nfft,nspden)=1-st order potential
1879 : : !! vxc1(cplex*nfft,nspden)=1-st order XC potential
1880 : : !!
1881 : : !! OUTPUT
1882 : : !! (see side effects)
1883 : : !!
1884 : : !! SIDE EFFECTS
1885 : : !! fermie1=derivative of fermi energy wrt perturbation
1886 : : !! at input : old value
1887 : : !! at output : updated value
1888 : : !!
1889 : : !! SOURCE
1890 : :
1891 : 1678 : subroutine newfermie1(cplex,fermie1,fe1fixed,ipert,istep,ixc,my_natom,natom,nfft,nfftot,&
1892 [ - + ]: 1678 : & nhatfermi,nspden,ntypat,occopt,paw_an,paw_an1,paw_ij1,pawang,pawnzlm,pawrad,&
1893 : 1678 : & pawrhoij1,pawrhoijfermi,pawtab,pawxcdev,prtvol,rhorfermi,&
1894 [ - + ]: 1678 : & ucvol,usepaw,usexcnhat,vtrial1,vxc1,xclevel,&
1895 [ + - + + : 1678 : & mpi_atmtab,comm_atom) ! optional arguments (parallelism)
- + ]
1896 : :
1897 : : !Arguments -------------------------------
1898 : : !scalars
1899 : : integer,intent(in) :: cplex,ipert,istep,ixc,my_natom,natom,nfft,nfftot,nspden,ntypat
1900 : : integer,intent(in) :: occopt,pawnzlm,pawxcdev,prtvol,usepaw,usexcnhat,xclevel
1901 : : integer,optional,intent(in) :: comm_atom
1902 : : real(dp),intent(in) :: fe1fixed,ucvol
1903 : : real(dp),intent(inout) :: fermie1
1904 : : type(pawang_type),intent(in) :: pawang
1905 : : !arrays
1906 : : integer,optional,target,intent(in) :: mpi_atmtab(:)
1907 : : real(dp),intent(in) :: rhorfermi(nfft,nspden),vtrial1(cplex*nfft,nspden)
1908 : : real(dp),intent(in) :: nhatfermi(:,:),vxc1(:,:)
1909 : : type(paw_an_type),intent(in) :: paw_an(my_natom*usepaw)
1910 : : type(paw_an_type),intent(inout) :: paw_an1(my_natom*usepaw)
1911 : : type(paw_ij_type),intent(inout) :: paw_ij1(my_natom*usepaw)
1912 : : type(pawrad_type),intent(in) :: pawrad(ntypat*usepaw)
1913 : : type(pawrhoij_type),intent(in) :: pawrhoij1(my_natom*usepaw),pawrhoijfermi(my_natom*usepaw)
1914 : : type(pawtab_type),intent(in) :: pawtab(ntypat*usepaw)
1915 : :
1916 : : !Local variables-------------------------------
1917 : : !scalars
1918 : : integer :: ipert0,my_comm_atom,nzlmopt,nzlmopt_fermi,option,pawprtvol
1919 : : logical :: my_atmtab_allocated,paral_atom
1920 : : real(dp) :: doti,fe1_scf,fe1_tmp,fermie1_new,fermie1rs
1921 : : character(len=500) :: msg
1922 : : !arrays
1923 : 1678 : integer, pointer :: my_atmtab(:)
1924 : : real(dp) :: fe1_paw(2)
1925 : 1678 : real(dp), allocatable :: rhor_nonhat(:,:),vtrial1_novxc(:,:)
1926 : : ! *********************************************************************
1927 : :
1928 : : !Tests
1929 : 1678 : if (cplex==2) then
1930 : 0 : ABI_BUG('Not compatible with cplex=2!')
1931 : : end if
1932 [ + + + + : 8390 : if (usepaw==1.and.usexcnhat==0.and.(size(nhatfermi)<=0.or.size(vxc1)<=0)) then
+ + + + +
- - + ]
1933 : 0 : ABI_BUG('Should have nhatfermi and vxc1 allocated with usexcnhat=0!')
1934 : : end if
1935 : :
1936 : : !Set up parallelism over atoms
1937 [ + - + + ]: 1678 : paral_atom=(present(comm_atom).and.(my_natom/=natom))
1938 [ + + ]: 1678 : nullify(my_atmtab);if (present(mpi_atmtab)) my_atmtab => mpi_atmtab
1939 [ + - ]: 1678 : my_comm_atom=xmpi_comm_self;if (present(comm_atom)) my_comm_atom=comm_atom
1940 : 1678 : call get_my_atmtab(my_comm_atom,my_atmtab,my_atmtab_allocated,paral_atom,natom,my_natom_ref=my_natom)
1941 : :
1942 [ + - ]: 1678 : if(occopt>=3 .and. occopt <=8) then
1943 : :
1944 : : ! The product of the current trial potential and the so-called Fermi level
1945 : : ! density is integrated to give the local potential contributions to the
1946 : : ! first-order Fermi level.
1947 : 1678 : option=1
1948 [ + + + + ]: 1678 : if (usepaw==1.and.usexcnhat==0) then
1949 [ - + + - : 604 : ABI_MALLOC(rhor_nonhat,(nfft,nspden))
- + + - +
- + - - +
- + ]
1950 [ - + + - : 453 : ABI_MALLOC(vtrial1_novxc,(nfft,nspden))
- + + - -
+ + - ]
1951 [ + + + + ]: 1300838 : rhor_nonhat(1:nfft,1:nspden)=rhorfermi(1:nfft,1:nspden)-nhatfermi(1:nfft,1:nspden)
1952 [ + + + + ]: 1300838 : vtrial1_novxc(1:nfft,1:nspden)=vtrial1(1:nfft,1:nspden)-vxc1(1:nfft,1:nspden)
1953 : : call dotprod_vn(cplex,rhor_nonhat,fe1_scf,doti,nfft,nfftot,&
1954 : 151 : & nspden,option,vtrial1,ucvol)
1955 : : call dotprod_vn(cplex,nhatfermi,fe1_tmp,doti,nfft,nfftot,&
1956 [ - + - - : 151 : & nspden,option,vtrial1_novxc,ucvol)
- - - - -
+ ]
1957 : 151 : fe1_scf=fe1_scf+fe1_tmp
1958 [ - + ]: 151 : ABI_FREE(rhor_nonhat)
1959 [ - + ]: 302 : ABI_FREE(vtrial1_novxc)
1960 : : else
1961 : : call dotprod_vn(cplex,rhorfermi,fe1_scf,doti,nfft,nfftot,&
1962 : 1527 : & nspden,option,vtrial1,ucvol)
1963 : : end if
1964 : :
1965 : 1678 : fe1_paw(:)=zero
1966 : : ! PAW on-site contribution (use Fermi level occupation matrix)
1967 [ + + ]: 1678 : if (usepaw==1) then
1968 : 1250 : ipert0=0;pawprtvol=0
1969 [ + + ]: 1250 : nzlmopt=0;if (istep>1) nzlmopt=pawnzlm
1970 [ + + + - ]: 1250 : if (istep==1.and.pawnzlm>0) nzlmopt=-1
1971 [ + - ]: 1250 : nzlmopt_fermi=0;if (pawnzlm>0) nzlmopt_fermi=-1
1972 : : call pawdfptenergy(fe1_paw,ipert,ipert0,ixc,my_natom,natom,ntypat,nzlmopt,&
1973 : : & nzlmopt_fermi,paw_an,paw_an1,paw_ij1,pawang,pawprtvol,pawrad,&
1974 : : & pawrhoij1,pawrhoijfermi,pawtab,pawxcdev,xclevel,&
1975 : 1250 : & mpi_atmtab=my_atmtab, comm_atom=my_comm_atom)
1976 : : end if
1977 : :
1978 : : ! The fixed contributions consisting of non-local potential and kinetic terms
1979 : : ! are added
1980 : 1678 : fermie1_new=fe1fixed+fe1_scf+fe1_paw(1)
1981 : 1678 : fermie1rs=(fermie1-fermie1_new)**2
1982 : 1678 : fermie1=fermie1_new
1983 : :
1984 [ + + ]: 1678 : if(prtvol>=10)then
1985 : 1233 : write(msg, '(a,i5,2es18.8)' ) ' fermie1, residual squared',istep,fermie1,fermie1rs
1986 : 1233 : call wrtout(std_out,msg,'COLL')
1987 : : end if
1988 : :
1989 : : else
1990 : 0 : fermie1=zero
1991 : : end if
1992 : :
1993 : : !Destroy atom table used for parallelism
1994 : 1678 : call free_my_atmtab(my_atmtab,my_atmtab_allocated)
1995 : :
1996 [ - + ]: 1678 : end subroutine newfermie1
1997 : : !!***
1998 : :
1999 : : !!****f* ABINIT/dfpt_newvtr
2000 : : !! NAME
2001 : : !! dfpt_newvtr
2002 : : !!
2003 : : !! FUNCTION
2004 : : !! Compute new first-order trial potential by mixing new and old values.
2005 : : !! First, compute preconditioned residual first-order potential.
2006 : : !! Then, call one of the self-consistency drivers, and update vtrial.
2007 : : !!
2008 : : !! INPUTS
2009 : : !! cplex: if 1, real space 1-order functions on FFT grid are REAL, if 2, COMPLEX
2010 : : !! dielar(7)=input parameters for dielectric matrix:
2011 : : !! diecut,dielng,diemac,diemix,diegap,dielam,diemixmag.
2012 : : !! dtset <type(dataset_type)>=all input variables in this dataset
2013 : : !! | isecur=level of security of the computation
2014 : : !! | mffmem=governs the number of FFT arrays which are fit in core memory
2015 : : !! | it is either 1, in which case the array f_fftgr is used,
2016 : : !! | or 0, in which case the array f_fftgr_disk is used
2017 : : !! | natom=number of atoms
2018 : : !! | nspden=number of spin-density components
2019 : : !! | paral_kgb=option for (kpt,g vectors,bands) parallelism
2020 : : !! | pawoptmix= - PAW only - 1 if the computed residuals include the PAW (rhoij) part
2021 : : !! etotal=the total energy obtained from the input vtrial
2022 : : !! ffttomix(nfft*(1-nfftmix/nfft))=Index of the points of the FFT (fine) grid on the grid used for mixing (coarse)
2023 : : !! initialized= if 0 the initialization of the RF run is not yet finished
2024 : : !! iscf=( <= 0 =>non-SCF), >0 => SCF)
2025 : : !! iscf =1 => determination of the largest eigenvalue of the SCF cycle
2026 : : !! iscf =2 => SCF cycle, simple mixing
2027 : : !! iscf =3 => SCF cycle, Anderson mixing
2028 : : !! iscf =4 => SCF cycle, Anderson mixing (order 2)
2029 : : !! iscf =5 => SCF cycle, CG based on the minimization of the energy
2030 : : !! iscf =7 => SCF cycle, Pulay mixing
2031 : : !! ispmix=1 if mixing is done in real space, 2 if mixing is done in reciprocal space
2032 : : !! istep= number of the step in the SCF cycle
2033 : : !! mixtofft(nfftmix*(1-nfftmix/nfft))=Index of the points of the FFT grid used for mixing (coarse) on the FFT (fine) grid
2034 : : !! mpi_enreg=information about MPI parallelization
2035 : : !! my_natom=number of atoms treated by current processor
2036 : : !! nfft=(effective) number of FFT grid points (for this processor)
2037 : : !! nfftmix=dimension of FFT grid used to mix the densities (used in PAW only)
2038 : : !! ngfft(18)=contain all needed information about 3D FFT, see ~abinit/doc/variables/vargs.htm#ngfft
2039 : : !! ngfftmix(18)=contain all needed information about 3D FFT, for the grid corresponding to nfftmix
2040 : : !! npawmix=-PAW only- number of spherical part elements to be mixed
2041 : : !! qphon(3)=reduced coordinates for the phonon wavelength (needed if cplex==2).
2042 : : !! pawrhoij(natom) <type(pawrhoij_type)>= paw rhoij occupancies and related data
2043 : : !! Use here rhoij residuals (and gradients)
2044 : : !! rhor(cplex*nfft,nspden)=array for 1st-order electron density
2045 : : !! in electrons/bohr**3.
2046 : : !! rprimd(3,3)=dimensional primitive translations in real space (bohr)
2047 : : !! usepaw= 0 for non paw calculation; =1 for paw calculation
2048 : : !! vresid(cplex*nfft,nspden)=array for the residual of the potential
2049 : : !! xred(3,natom)=reduced dimensionless atomic coordinates
2050 : : !!
2051 : : !! OUTPUT
2052 : : !! dbl_nnsclo=1 if nnsclo has to be doubled to secure the convergence.
2053 : : !!
2054 : : !! SIDE EFFECTS
2055 : : !! vtrial(cplex*nfft,nspden)= at input, it is the "in" trial potential that gave vresid=(v_out-v_in)
2056 : : !! at output, it is an updated "mixed" trial potential
2057 : : !! ==== if usepaw==1
2058 : : !! pawrhoij(natom)%nrhoijsel,rhoijselect,rhoijp= several arrays
2059 : : !! containing new values of rhoij (augmentation occupancies)
2060 : : !!
2061 : : !! NOTES
2062 : : !! In case of PAW calculations:
2063 : : !! Computations are done either on the fine FFT grid or the coarse grid (depending on dtset%pawmixdg)
2064 : : !! All variables (nfft,ngfft,mgfft) refer to the fine FFT grid.
2065 : : !! All arrays (densities/potentials...) are computed on this fine FFT grid.
2066 : : !! Developpers have to be careful when introducing others arrays:
2067 : : !! they have to be stored on the fine FFT grid.
2068 : : !! In case of norm-conserving calculations the FFT grid is the usual FFT grid.
2069 : : !!
2070 : : !! Subtility in PAW and non-collinear magnetism:
2071 : : !! Potentials are stored in (up-up,dn-dn,Re[up-dn],Im[up-dn]) format
2072 : : !! On-site occupancies (rhoij) are stored in (n,mx,my,mz)
2073 : : !! This is compatible provided that the mixing factors for n and m are identical
2074 : : !! and that the residual is not a combination of V_res and rhoij_res (pawoptmix=0).
2075 : : !!
2076 : : !! SOURCE
2077 : :
2078 : 13541 : subroutine dfpt_newvtr(cplex,dbl_nnsclo,dielar,dtset,etotal,ffttomix,&
2079 : 13541 : & initialized,iscf,ispmix,istep,mix,mixtofft,&
2080 : 13541 : & mpi_enreg,my_natom,nfft,nfftmix,ngfft,ngfftmix,npawmix,pawrhoij,&
2081 : 13541 : & qphon,rhor,rprimd,usepaw,vresid,vtrial)
2082 : :
2083 : : !Arguments-------------------------------
2084 : : !scalars
2085 : : integer,intent(in) :: cplex,initialized,iscf,ispmix,istep,my_natom,nfft
2086 : : integer,intent(in) :: nfftmix,npawmix,usepaw
2087 : : integer,intent(inout) :: dbl_nnsclo !vz_i
2088 : : real(dp),intent(in) :: etotal
2089 : : type(MPI_type),intent(in) :: mpi_enreg
2090 : : type(abi_mixing_object), intent(inout) :: mix
2091 : : type(dataset_type),intent(in) :: dtset
2092 : : !arrays
2093 : : integer,intent(in) :: ffttomix(nfft*(1-nfftmix/nfft))
2094 : : integer,intent(in) :: mixtofft(nfftmix*(1-nfftmix/nfft)),ngfft(18)
2095 : : integer,intent(in) :: ngfftmix(18)
2096 : : real(dp),intent(in) :: dielar(7),qphon(3)
2097 : : real(dp), intent(in), target :: rhor(cplex*nfft,dtset%nspden)
2098 : : real(dp),intent(in) :: rprimd(3,3)
2099 : : real(dp),intent(inout) :: vresid(cplex*nfft,dtset%nspden)
2100 : : real(dp),intent(inout) :: vtrial(cplex*nfft,dtset%nspden)
2101 : : type(pawrhoij_type),intent(inout) :: pawrhoij(my_natom*usepaw)
2102 : :
2103 : : !Local variables-------------------------------
2104 : : !scalars
2105 : : integer :: cplex_mix,cplex_rhoij,dplex,i_vresid1,i_vrespc1,iatom,ifft,indx,iq,iq0
2106 : : integer :: irhoij,ispden,jfft,jrhoij,klmn,kklmn,kmix,moved_atm_inside,nfftot,qphase
2107 : : integer :: mpicomm,errid
2108 : : logical :: mpi_summarize,reset
2109 : : real(dp) :: fact,mixfac,mixfac_eff,mixfacmag,ucvol
2110 : : character(len=500) :: msg
2111 : : !arrays
2112 : : real(dp) :: gmet(3,3),gprimd(3,3),rmet(3,3),tsec(2)
2113 : 13541 : real(dp),allocatable :: rhoijrespc(:),rhoijtmp(:,:)
2114 : 13541 : real(dp),allocatable :: vresid0(:,:),vrespc(:,:),vreswk(:,:)
2115 : 13541 : real(dp), pointer :: vtrial0(:,:),vpaw(:)
2116 : 13541 : real(dp),allocatable :: vtrialg(:,:,:)
2117 : : ! *************************************************************************
2118 : :
2119 : : DBG_ENTER("COLL")
2120 : :
2121 : 13541 : call timab(158,1,tsec)
2122 : :
2123 : : !Compatibility tests
2124 [ + + ]: 13541 : if(usepaw==1) then
2125 [ - + - - ]: 2439 : if(dtset%nspden==4.and.dtset%pawoptmix==1) then
2126 : 0 : ABI_ERROR('pawoptmix=1 is not compatible with nspden=4 !')
2127 : : end if
2128 [ + + ]: 2439 : if (my_natom>0) then
2129 [ - + ]: 2421 : if (pawrhoij(1)%qphase<cplex) then
2130 : 0 : ABI_ERROR('pawrhoij()%qphase must be >=cplex !')
2131 : : end if
2132 : : end if
2133 : : end if
2134 : :
2135 : 13541 : nfftot=ngfft(1)*ngfft(2)*ngfft(3)
2136 : 13541 : cplex_mix=max(cplex,ispmix)
2137 [ + + + + ]: 13541 : if (usepaw==1.and.my_natom>0) then
2138 : 2421 : cplex_rhoij=pawrhoij(1)%cplex_rhoij
2139 : 2421 : qphase=pawrhoij(1)%qphase
2140 : : end if
2141 : :
2142 : : !Compute different geometric tensor, as well as ucvol, from rprimd
2143 : 13541 : call metric(gmet,gprimd,-1,rmet,rprimd,ucvol)
2144 : 13541 : moved_atm_inside=0
2145 : :
2146 : : !Select components of potential to be mixed
2147 [ - + + - : 54164 : ABI_MALLOC(vtrial0,(cplex_mix*nfftmix,dtset%nspden))
- + + - +
- + - - +
- + ]
2148 [ - + + - : 40623 : ABI_MALLOC(vresid0,(cplex_mix*nfftmix,dtset%nspden))
- + + - -
+ - + ]
2149 [ + + + - ]: 13541 : if (ispmix==1.and.nfft==nfftmix) then
2150 [ + + + + : 283102714 : vtrial0=vtrial;vresid0=vresid
+ - - + -
- + + +
+ ]
2151 [ + + ]: 2439 : else if (nfft==nfftmix) then
2152 [ + + ]: 2406 : do ispden=1,dtset%nspden
2153 [ - + ]: 1203 : call fourdp(cplex,vtrial0(:,ispden),vtrial(:,ispden),-1,mpi_enreg,nfft,1, ngfft, 0)
2154 : 2406 : call fourdp(cplex,vresid0(:,ispden),vresid(:,ispden),-1,mpi_enreg,nfft,1, ngfft, 0)
2155 : : end do
2156 : : else
2157 [ - + + - : 4944 : ABI_MALLOC(vtrialg,(2,nfft,dtset%nspden))
- + + - +
- + - - +
- + ]
2158 [ - + + - : 3708 : ABI_MALLOC(vreswk,(2,nfft))
+ - + - -
+ + - ]
2159 [ + + ]: 2859 : do ispden=1,dtset%nspden
2160 [ + + ]: 1623 : fact=dielar(4);if (ispden>1) fact=dielar(7)
2161 : 1623 : call fourdp(cplex,vtrialg(:,:,ispden),vtrial(:,ispden),-1,mpi_enreg,nfft,1, ngfft, 0)
2162 : 1623 : call fourdp(cplex,vreswk,vresid(:,ispden),-1,mpi_enreg,nfft,1, ngfft, 0)
2163 [ + + ]: 32468731 : do ifft=1,nfft
2164 [ + + ]: 32467495 : if (ffttomix(ifft)>0) then
2165 : 10369934 : jfft=2*ffttomix(ifft)
2166 : 10369934 : vtrial0(jfft-1,ispden)=vtrialg(1,ifft,ispden)
2167 : 10369934 : vtrial0(jfft ,ispden)=vtrialg(2,ifft,ispden)
2168 : 10369934 : vresid0(jfft-1,ispden)=vreswk(1,ifft)
2169 : 10369934 : vresid0(jfft ,ispden)=vreswk(2,ifft)
2170 : : else
2171 [ + + ]: 66287814 : vtrialg(:,ifft,ispden)=vtrialg(:,ifft,ispden)+fact*vreswk(:,ifft)
2172 : : end if
2173 : : end do
2174 : : end do
2175 [ - + ]: 1236 : ABI_FREE(vreswk)
2176 : : end if
2177 : :
2178 : : !Precondition the potential residual:
2179 : : !Use a model dielectric function preconditioning, or simple mixing
2180 [ - + + - : 40623 : ABI_MALLOC(vrespc,(cplex_mix*nfftmix,dtset%nspden))
- + + - -
+ - + ]
2181 : 13541 : call moddiel(cplex_mix,dielar,mpi_enreg,nfftmix,ngfftmix,dtset%nspden,ispmix,0,qphon,rprimd,vresid0,vrespc)
2182 : :
2183 : : !PAW only : precondition the rhoij quantities (augmentation occupancies) residuals.
2184 : : !Use a simple preconditionning with the same mixing factor
2185 : : !as the model dielectric function.
2186 [ + + + + ]: 13541 : if (usepaw==1.and.my_natom>0) then
2187 [ - + + - : 7263 : ABI_MALLOC(rhoijrespc,(npawmix))
+ - + - -
+ - + ]
2188 : 2421 : mixfac=dielar(4);mixfacmag=abs(dielar(7))
2189 [ - + ]: 2421 : if (cplex_rhoij==1) then
2190 : : indx=0
2191 [ + + ]: 7393 : do iatom=1,my_natom
2192 [ + + ]: 12881 : do iq=1,qphase
2193 [ + + ]: 5488 : iq0=merge(0,cplex_rhoij*pawrhoij(iatom)%lmn2_size,iq==1)
2194 [ + + ]: 16722 : do ispden=1,pawrhoij(iatom)%nspden
2195 [ + + ]: 6262 : mixfac_eff=mixfac;if (ispden>1) mixfac_eff=mixfacmag
2196 [ + + ]: 250270 : do kmix=1,pawrhoij(iatom)%lmnmix_sz
2197 : 238520 : indx=indx+1;klmn=iq0+pawrhoij(iatom)%kpawmix(kmix)
2198 : 244782 : rhoijrespc(indx)=mixfac_eff*pawrhoij(iatom)%rhoijres(klmn,ispden)
2199 : : end do
2200 : : end do
2201 : : end do
2202 : : end do
2203 : : else
2204 : : indx=-1
2205 [ # # ]: 0 : do iatom=1,my_natom
2206 [ # # ]: 0 : do iq=1,qphase
2207 [ # # ]: 0 : iq0=merge(0,cplex_rhoij*pawrhoij(iatom)%lmn2_size,iq==1)
2208 [ # # ]: 0 : do ispden=1,pawrhoij(iatom)%nspden
2209 [ # # ]: 0 : mixfac_eff=mixfac;if (ispden>1) mixfac_eff=mixfacmag
2210 [ # # ]: 0 : do kmix=1,pawrhoij(iatom)%lmnmix_sz
2211 : 0 : indx=indx+2;klmn=iq0+2*pawrhoij(iatom)%kpawmix(kmix)-1
2212 [ # # ]: 0 : rhoijrespc(indx:indx+1)=mixfac_eff*pawrhoij(iatom)%rhoijres(klmn:klmn+1,ispden)
2213 : : end do
2214 : : end do
2215 : : end do
2216 : : end do
2217 : : end if
2218 : : end if
2219 : :
2220 : : !------Compute new vtrial
2221 : :
2222 : 13541 : i_vresid1=mix%i_vresid(1)
2223 : 13541 : i_vrespc1=mix%i_vrespc(1)
2224 : :
2225 : : !Initialise working arrays for the mixing object.
2226 : 13541 : call abi_mixing_eval_allocate(mix, istep)
2227 : :
2228 : : !Copy current step arrays.
2229 : 13541 : call abi_mixing_copy_current_step(mix, vresid0, errid, msg, arr_respc = vrespc)
2230 : :
2231 [ - + ]: 13541 : if (errid /= AB7_NO_ERROR) then
2232 : 0 : ABI_ERROR(msg)
2233 : : end if
2234 : :
2235 [ - + ]: 13541 : ABI_FREE(vrespc)
2236 [ - + ]: 13541 : ABI_FREE(vresid0)
2237 : :
2238 : : !PAW: either use the array f_paw or the array f_paw_disk
2239 [ + + + - : 40623 : ABI_MALLOC(vpaw,(npawmix*usepaw))
+ - + + -
+ - + ]
2240 [ + + + + ]: 13541 : if (usepaw==1.and.my_natom>0) then
2241 : 2421 : dplex=cplex_rhoij-1 ; indx=-dplex
2242 [ + + ]: 7393 : do iatom=1,my_natom
2243 [ - + + - : 14916 : ABI_MALLOC(rhoijtmp,(cplex_rhoij*pawrhoij(iatom)%lmn2_size,1))
+ - + - -
+ - + ]
2244 [ + + ]: 10460 : do iq=1,qphase
2245 [ + + ]: 5488 : iq0=merge(0,cplex_rhoij*pawrhoij(iatom)%lmn2_size,iq==1)
2246 [ + + ]: 16722 : do ispden=1,pawrhoij(iatom)%nspden
2247 [ + + + + ]: 251044 : rhoijtmp=zero ; jrhoij=iq0+1
2248 [ + + ]: 194459 : do irhoij=1,pawrhoij(iatom)%nrhoijsel
2249 : 188197 : klmn=cplex_rhoij*pawrhoij(iatom)%rhoijselect(irhoij)-dplex
2250 [ + + ]: 376394 : rhoijtmp(klmn:klmn+dplex,1)=pawrhoij(iatom)%rhoijp(jrhoij:jrhoij+dplex,ispden)
2251 : 194459 : jrhoij=jrhoij+cplex_rhoij
2252 : : end do
2253 [ + + ]: 250270 : do kmix=1,pawrhoij(iatom)%lmnmix_sz
2254 : 238520 : indx=indx+cplex_rhoij;klmn=cplex_rhoij*pawrhoij(iatom)%kpawmix(kmix)-dplex ; kklmn=iq0+klmn
2255 [ + + ]: 477040 : vpaw(indx:indx+dplex)=rhoijtmp(klmn:klmn+dplex,1)-pawrhoij(iatom)%rhoijres(kklmn:kklmn+dplex,ispden)
2256 [ + + ]: 477040 : mix%f_paw(indx:indx+dplex,i_vresid1)=pawrhoij(iatom)%rhoijres(kklmn:kklmn+dplex,ispden)
2257 [ + + ]: 483302 : mix%f_paw(indx:indx+dplex,i_vrespc1)=rhoijrespc(indx:indx+dplex)
2258 : : end do
2259 : : end do
2260 : : end do
2261 [ - + ]: 7393 : ABI_FREE(rhoijtmp)
2262 : : end do
2263 : : end if
2264 : :
2265 : : !Unlike for GS, no need to modify the mean of vtrial
2266 : :
2267 : 13541 : mpicomm=0;mpi_summarize=.false.
2268 [ + + ]: 13541 : reset=.false.;if (initialized==0) reset=.true.
2269 : : call abi_mixing_eval(mix, vtrial0, istep, nfftot, ucvol, &
2270 : : & mpicomm, mpi_summarize, errid, msg, &
2271 : : & reset = reset, isecur = dtset%isecur, &
2272 : : & pawopt = dtset%pawoptmix, response = 1, pawarr = vpaw, &
2273 [ - + - + ]: 13541 : & etotal = etotal, potden = rhor, comm_atom=mpi_enreg%comm_atom)
2274 : :
2275 [ - + ]: 13541 : if (errid == AB7_ERROR_MIXING_INC_NNSLOOP) then
2276 : 0 : dbl_nnsclo = 1
2277 [ - + ]: 13541 : else if (errid /= AB7_NO_ERROR) then
2278 : : ! MG FIXME, Why this?
2279 : : ! One should propagate the error so that we can handle it
2280 : : ! in the caller!
2281 : 0 : ABI_ERROR(msg)
2282 : : end if
2283 : :
2284 : : !Do here the mixing of the potential
2285 [ + - ]: 13541 : if(iscf==2 .or. iscf==3 .or. iscf==7)then
2286 : : ! PAW: restore rhoij from compact storage
2287 [ + + + + ]: 13541 : if (usepaw==1.and.my_natom>0) then
2288 : 2421 : dplex=cplex_rhoij-1 ; indx=-dplex
2289 [ + + ]: 7393 : do iatom=1,my_natom
2290 [ - + + - : 19888 : ABI_MALLOC(rhoijtmp,(cplex_rhoij*qphase*pawrhoij(iatom)%lmn2_size,pawrhoij(iatom)%nspden))
- + + - +
- + - - +
- + ]
2291 [ + + + + ]: 249226 : rhoijtmp=zero
2292 [ + + ]: 10460 : do iq=1,qphase
2293 [ + + ]: 5488 : iq0=merge(0,cplex_rhoij*pawrhoij(iatom)%lmn2_size,iq==1)
2294 [ - + ]: 5488 : if (pawrhoij(iatom)%lmnmix_sz<pawrhoij(iatom)%lmn2_size) then
2295 [ # # ]: 0 : do ispden=1,pawrhoij(iatom)%nspden
2296 : 0 : jrhoij=iq0+1
2297 [ # # ]: 0 : do irhoij=1,pawrhoij(iatom)%nrhoijsel
2298 : 0 : klmn=iq0+cplex_rhoij*pawrhoij(iatom)%rhoijselect(irhoij)-dplex
2299 [ # # ]: 0 : rhoijtmp(klmn:klmn+dplex,ispden)=pawrhoij(iatom)%rhoijp(jrhoij:jrhoij+dplex,ispden)
2300 : 0 : jrhoij=jrhoij+cplex_rhoij
2301 : : end do
2302 : : end do
2303 : : end if
2304 [ + + ]: 16722 : do ispden=1,pawrhoij(iatom)%nspden
2305 [ + + ]: 250270 : do kmix=1,pawrhoij(iatom)%lmnmix_sz
2306 : 238520 : indx=indx+cplex_rhoij;klmn=iq0+cplex_rhoij*pawrhoij(iatom)%kpawmix(kmix)-dplex
2307 [ + + ]: 483302 : rhoijtmp(klmn:klmn+dplex,ispden)=vpaw(indx:indx+dplex)
2308 : : end do
2309 : : end do
2310 : : end do
2311 : : call pawrhoij_filter(pawrhoij(iatom)%rhoijp,pawrhoij(iatom)%rhoijselect,&
2312 : : & pawrhoij(iatom)%nrhoijsel,pawrhoij(iatom)%cplex_rhoij,pawrhoij(iatom)%qphase,&
2313 : 4972 : & pawrhoij(iatom)%lmn2_size,pawrhoij(iatom)%nspden,rhoij_input=rhoijtmp)
2314 [ - + ]: 7393 : ABI_FREE(rhoijtmp)
2315 : : end do
2316 : : end if
2317 : :
2318 [ # # ]: 0 : else if(iscf==5 .or. iscf==6)then
2319 [ # # ]: 0 : if(ispmix/=1) then
2320 : 0 : ABI_ERROR('Mixing on reciprocal space not allowed with iscf=5 or 6.')
2321 : : end if
2322 : : ! PAW: apply a simple mixing to rhoij (this is temporary)
2323 [ # # # # ]: 0 : if (usepaw==1.and.my_natom>0) then
2324 : 0 : indx=1-cplex_rhoij
2325 [ # # ]: 0 : do iatom=1,my_natom
2326 [ # # # # : 0 : ABI_MALLOC(rhoijtmp,(cplex_rhoij*qphase*pawrhoij(iatom)%lmn2_size,pawrhoij(iatom)%nspden))
# # # # #
# # # # #
# # ]
2327 [ # # # # ]: 0 : rhoijtmp=zero
2328 [ # # ]: 0 : do iq=1,qphase
2329 [ # # ]: 0 : iq0=merge(0,cplex_rhoij*pawrhoij(iatom)%lmn2_size,iq==1)
2330 [ # # ]: 0 : if (pawrhoij(iatom)%lmnmix_sz<pawrhoij(iatom)%lmn2_size) then
2331 [ # # ]: 0 : do ispden=1,pawrhoij(iatom)%nspden
2332 [ # # ]: 0 : do kmix=1,pawrhoij(iatom)%lmnmix_sz
2333 : 0 : indx=indx+cplex_rhoij;klmn=iq0+cplex_rhoij*pawrhoij(iatom)%kpawmix(kmix)-dplex
2334 : : rhoijtmp(klmn:klmn+dplex,ispden)=rhoijrespc(indx:indx+dplex) &
2335 [ # # ]: 0 : & -pawrhoij(iatom)%rhoijres(klmn:klmn+dplex,ispden)
2336 : : end do
2337 : : end do
2338 : : end if
2339 [ # # ]: 0 : do ispden=1,pawrhoij(iatom)%nspden
2340 : 0 : jrhoij=iq0+1
2341 [ # # ]: 0 : do irhoij=1,pawrhoij(iatom)%nrhoijsel
2342 : 0 : klmn=iq0+cplex_rhoij*pawrhoij(iatom)%rhoijselect(irhoij)-dplex
2343 : : rhoijtmp(klmn:klmn+dplex,ispden)=rhoijtmp(klmn:klmn+dplex,ispden) &
2344 [ # # ]: 0 : & +pawrhoij(iatom)%rhoijp(jrhoij:jrhoij+dplex,ispden)
2345 : 0 : jrhoij=jrhoij+cplex_rhoij
2346 : : end do
2347 : : end do
2348 : : end do
2349 : : call pawrhoij_filter(pawrhoij(iatom)%rhoijp,pawrhoij(iatom)%rhoijselect,&
2350 : : & pawrhoij(iatom)%nrhoijsel,pawrhoij(iatom)%cplex_rhoij,pawrhoij(iatom)%qphase,&
2351 : 0 : & pawrhoij(iatom)%lmn2_size,pawrhoij(iatom)%nspden,rhoij_input=rhoijtmp)
2352 [ # # ]: 0 : ABI_FREE(rhoijtmp)
2353 : : end do
2354 : : end if
2355 : : end if
2356 : :
2357 [ - + ]: 13541 : ABI_FREE(vpaw)
2358 [ + + + + ]: 13541 : if (usepaw==1.and.my_natom>0) then
2359 [ - + ]: 2421 : ABI_FREE(rhoijrespc)
2360 : : end if
2361 : :
2362 : : !Eventually write the data on disk and deallocate f_fftgr_disk
2363 : 13541 : call abi_mixing_eval_deallocate(mix)
2364 : :
2365 : : !Restore potential
2366 [ + + + - ]: 13541 : if (ispmix==1.and.nfft==nfftmix) then
2367 [ + + + + ]: 141551357 : vtrial=vtrial0
2368 [ + + ]: 2439 : else if (nfft==nfftmix) then
2369 [ + + ]: 2406 : do ispden=1,dtset%nspden
2370 [ - + ]: 2406 : call fourdp(cplex,vtrial0(:,ispden),vtrial(:,ispden),+1,mpi_enreg,nfft,1, ngfft,0)
2371 : : end do
2372 : : else
2373 [ + + ]: 2859 : do ispden=1,dtset%nspden
2374 [ + + ]: 10371557 : do ifft=1,nfftmix
2375 : 10369934 : jfft=mixtofft(ifft)
2376 : 10369934 : vtrialg(1,jfft,ispden)=vtrial0(2*ifft-1,ispden)
2377 : 10371557 : vtrialg(2,jfft,ispden)=vtrial0(2*ifft ,ispden)
2378 : : end do
2379 : 2859 : call fourdp(cplex,vtrialg(:,:,ispden),vtrial(:,ispden),+1,mpi_enreg,nfft,1,ngfft,0)
2380 : : end do
2381 [ - + ]: 1236 : ABI_FREE(vtrialg)
2382 : : end if
2383 [ - + ]: 13541 : ABI_FREE(vtrial0)
2384 : :
2385 : 13541 : call timab(158,2,tsec)
2386 : :
2387 : : DBG_ENTER("COLL")
2388 : :
2389 [ - + - + ]: 40623 : end subroutine dfpt_newvtr
2390 : : !!***
2391 : :
2392 : : !!****f* ABINIT/dfpt_nselt
2393 : : !! NAME
2394 : : !! dfpt_nselt
2395 : : !!
2396 : : !! FUNCTION
2397 : : !! This routine compute the non-stationary expression for the
2398 : : !! second derivative of the total energy, wrt strain for a whole row of
2399 : : !! mixed strain derivatives.
2400 : : !!
2401 : : !! INPUTS
2402 : : !! cg(2,mpw*nspinor*mband_mem*mkmem*nsppol)=planewave coefficients of wavefunctions
2403 : : !! cg1(2,mpw1*nspinor*mband_mem*mk1mem*nsppol)=pw coefficients of RF wavefunctions at k,q.
2404 : : !! cplex: if 1, real space 1-order functions on FFT grid are REAL,
2405 : : !! if 2, COMPLEX
2406 : : !! ecut=cut-off energy for plane wave basis sphere (Ha)
2407 : : !! ecutsm=smearing energy for plane wave kinetic energy (Ha)
2408 : : !! effmass_free=effective mass for electrons (1. in common case)
2409 : : !! gmet(3,3)=reciprocal space metric tensor in bohr**-2.
2410 : : !! gprimd(3,3)=dimensional reciprocal space primitive translations
2411 : : !! gsqcut=cutoff on (k+G)^2 (bohr^-2)
2412 : : !! idir=direction of the perturbation
2413 : : !! ipert=type of the perturbation
2414 : : !! istwfk_rbz(nkpt_rbz)=input option parameter that describes the
2415 : : !! storage of wfs
2416 : : !! kg(3,mpw*mkmem)=reduced planewave coordinates.
2417 : : !! kg1(3,mpw1*mk1mem)=reduced planewave coordinates at k+q, with RF k points
2418 : : !! kpt_rbz(3,nkpt_rbz)=reduced coordinates of k points in the reduced BZ
2419 : : !! kxc(nfft,nkxc)=exchange and correlation kernel
2420 : : !! mband=maximum number of bands
2421 : : !! mband_mem=maximum number of bands on this cpu
2422 : : !! mgfft=maximum size of 1D FFTs
2423 : : !! mkmem =number of k points treated by this node.
2424 : : !! mk1mem =number of k points treated by this node (RF data).
2425 : : !! mpert =maximum number of ipert
2426 : : !! mpi_enreg=information about MPI parallelization
2427 : : !! mpsang= 1+maximum angular momentum for nonlocal pseudopotentials
2428 : : !! mpw=maximum dimensioned size of npw or wfs at k
2429 : : !! mpw1=maximum dimensioned size of npw for wfs at k+q (also for 1-order wfs).
2430 : : !! maximum dimension for q points in grids for nonlocal form factors
2431 : : !! natom=number of atoms in cell.
2432 : : !! nband_rbz(nkpt_rbz*nsppol)=number of bands at each RF k point for each spin
2433 : : !! nfft=(effective) number of FFT grid points (for this processor)
2434 : : !! ngfft(18)=contain all needed information about 3D FFT,
2435 : : !! see ~abinit/doc/variables/vargs.htm#ngfft
2436 : : !! nkpt_rbz=number of k points in the reduced BZ for this perturbation
2437 : : !! nkxc=second dimension of the kxc array. If /=0,
2438 : : !! the exchange-correlation kernel must be computed.
2439 : : !! nloalg(3)=governs the choice of the algorithm for non-local operator.
2440 : : !! npwarr(nkpt_rbz)=number of planewaves in basis at this GS k point
2441 : : !! npwar1(nkpt_rbz)=number of planewaves in basis at this RF k+q point
2442 : : !! nspden=number of spin-density components
2443 : : !! nspinor=number of spinorial components of the wavefunctions
2444 : : !! nsppol=1 for unpolarized, 2 for spin-polarized
2445 : : !! nsym1=number of symmetry elements in space group consistent with
2446 : : !! perturbation
2447 : : !! ntypat=number of types of atoms in unit cell.
2448 : : !! occ_rbz(mband*nkpt_rbz*nsppol)=occupation number for each band
2449 : : !! and k in the reduced Brillouin zone (usually =2)
2450 : : !! ph1d(2,3*(2*mgfft+1)*natom)=one-dimensional structure factor information
2451 : : !! prtbbb=if 1, band-by-band decomposition (also dim of d2bbb)
2452 : : !! psps <type(pseudopotential_type)>=variables related to pseudopotentials
2453 : : !! qphon(3)=reduced coordinates for the phonon wavelength
2454 : : !! rhog(2,nfft)=array for Fourier transform of GS electron density
2455 : : !! rhor(nfft,nspden)=GS electron density in electrons/bohr**3.
2456 : : !! rhor1(cplex*nfft,nspden)=RF electron density in electrons/bohr**3.
2457 : : !! rmet(3,3)=real space metric (bohr**2)
2458 : : !! rprimd(3,3)=dimensional primitive translations in real space (bohr)
2459 : : !! symrc1(3,3,nsym1)=symmetry operations in reciprocal space
2460 : : !! typat(natom)=type integer for each atom in cell
2461 : : !! ucvol=unit cell volume in bohr**3.
2462 : : !! wtk_rbz(nkpt_rbz)=weight assigned to each k point in the reduced BZ
2463 : : !! xred(3,natom)=reduced dimensionless atomic coordinates
2464 : : !! ylm(mpw*mkmem,mpsang*mpsang)= real spherical harmonics for each G and k point
2465 : : !! ylm1(mpw1*mk1mem,mpsang*mpsang)= real spherical harmonics for each G and k+q point
2466 : : !! ylmgr(mpw*mkmem,3,mpsang*mpsang*useylm)= gradients of real spherical for each G and k point
2467 : : !! ylmgr1(mpw1*mk1mem,3,mpsang*mpsang*useylm)= gradients of real spherical for each G and k+g point
2468 : : !! [rfstrs_ref]= if eq 1 the reference energy in vlocalstr is shited to the same valuea as in the FxE routines
2469 : : !!
2470 : : !! OUTPUT
2471 : : !! blkflg(3,mpert,3,mpert)=flags for each element of the 2DTE (=1 if computed)
2472 : : !! d2bbb(2,3,3,mpert,mband,mband*prtbbb)=band by band decomposition of some
2473 : : !! second order derivatives
2474 : : !! d2lo(2,3,mpert,3,mpert)=local contributions to the 2DTEs
2475 : : !! d2nl(2,3,mpert,3,mpert)=non-local contributions to the 2DTEs
2476 : : !!
2477 : : !! SOURCE
2478 : :
2479 : 96 : subroutine dfpt_nselt(blkflg,cg,cg1,cplex,&
2480 : 96 : & d2bbb,d2lo,d2nl,ecut,ecutsm,effmass_free,&
2481 : : & gmet,gprimd,gsqcut,idir,&
2482 : 96 : & ipert,istwfk_rbz,kg,kg1,kpt_rbz,kxc,mband,mband_mem,mgfft,&
2483 : : & mkmem,mk1mem,mpert,mpi_enreg,mpsang,mpw,mpw1,&
2484 : 96 : & natom,nband_rbz,nfft,ngfft,&
2485 : 96 : & nkpt_rbz,nkxc,nloalg,npwarr,npwar1,nspden,nspinor,nsppol,&
2486 : 96 : & nsym1,ntypat,occ_rbz,&
2487 : 96 : & ph1d,prtbbb,psps,qphon,rhog,&
2488 : 96 : & rhor,rhor1,rmet,rprimd,symrc1,typat,ucvol,&
2489 : 96 : & wtk_rbz,&
2490 : 96 : & xred,ylm,ylm1,ylmgr,ylmgr1,&
2491 : : & rfstrs_ref)
2492 : :
2493 : : !Arguments -------------------------------
2494 : : !scalars
2495 : : integer,intent(in) :: cplex,idir,ipert,mband,mgfft,mk1mem
2496 : : integer,intent(in) :: mband_mem
2497 : : integer,intent(in) :: mkmem,mpert,mpsang,mpw,mpw1,natom,nfft,nkpt_rbz
2498 : : integer,intent(in) :: nkxc,nspden,nspinor,nsppol,nsym1,ntypat
2499 : : integer,intent(in) :: prtbbb
2500 : : integer,intent(in),optional :: rfstrs_ref
2501 : : real(dp),intent(in) :: ecut,ecutsm,effmass_free,gsqcut,ucvol
2502 : : type(MPI_type),intent(in) :: mpi_enreg
2503 : : type(pseudopotential_type),intent(in) :: psps
2504 : : !arrays
2505 : : integer,intent(in) :: istwfk_rbz(nkpt_rbz)
2506 : : integer,intent(in) :: kg(3,mpw*mkmem),kg1(3,mpw1*mk1mem)
2507 : : integer,intent(in) :: nband_rbz(nkpt_rbz*nsppol),ngfft(18)
2508 : : integer,intent(in) :: nloalg(3),npwar1(nkpt_rbz),npwarr(nkpt_rbz)
2509 : : integer,intent(in) :: symrc1(3,3,nsym1),typat(natom)
2510 : : integer,intent(inout) :: blkflg(3,mpert,3,mpert)
2511 : : real(dp),intent(in) :: cg(2,mpw*nspinor*mband_mem*mkmem*nsppol)
2512 : : real(dp),intent(in) :: cg1(2,mpw1*nspinor*mband_mem*mk1mem*nsppol)
2513 : : real(dp),intent(in) :: gmet(3,3)
2514 : : real(dp),intent(in) :: gprimd(3,3),kpt_rbz(3,nkpt_rbz),kxc(nfft,nkxc)
2515 : : real(dp),intent(in) :: occ_rbz(mband*nkpt_rbz*nsppol)
2516 : : real(dp),intent(in) :: ph1d(2,3*(2*mgfft+1)*natom),qphon(3),rhog(2,nfft)
2517 : : real(dp),intent(in) :: rhor(nfft,nspden)
2518 : : real(dp),intent(in) :: rhor1(cplex*nfft,nspden),rmet(3,3),rprimd(3,3)
2519 : : real(dp),intent(in) :: wtk_rbz(nkpt_rbz),xred(3,natom)
2520 : : real(dp),intent(in) :: ylm(mpw*mkmem,mpsang*mpsang*psps%useylm)
2521 : : real(dp),intent(in) :: ylm1(mpw1*mk1mem,mpsang*mpsang*psps%useylm)
2522 : : real(dp),intent(in) :: ylmgr(mpw*mkmem,3,mpsang*mpsang*psps%useylm)
2523 : : real(dp),intent(in) :: ylmgr1(mpw1*mk1mem,3,mpsang*mpsang*psps%useylm)
2524 : : real(dp),intent(out) :: d2bbb(2,3,3,mpert,mband,mband*prtbbb)
2525 : : real(dp),intent(inout) :: d2lo(2,3,mpert,3,mpert)
2526 : : real(dp),intent(inout) :: d2nl(2,3,mpert,3,mpert)
2527 : :
2528 : : !Local variables-------------------------------
2529 : : !scalars
2530 : : integer :: ban2tot,bantot,bd2tot_index,bdtot_index,g0term
2531 : : integer :: icg,icg1,idir1,ifft,ii,ikg,ikg1,ikpt,comm
2532 : : integer :: ilm,ipert1,ispden,isppol,istr1,istwf_k
2533 : : integer :: mbd2kpsp,mbdkpsp,me,n1,n2,n3,n3xccc,n4,n5,n6
2534 : : integer :: nband_k,nfftot,npw1_k,npw_k,option,rfstrs_ref_
2535 : : logical :: nmxc=.false.
2536 : : real(dp) :: doti,dotr
2537 : : real(dp) :: wtk_k
2538 : : character(len=500) :: msg
2539 : 96 : type(gs_hamiltonian_type) :: gs_hamk
2540 : : !arrays
2541 : : integer :: ikpt_fbz(3)
2542 : 96 : integer,allocatable :: kg1_k(:,:),kg_k(:,:)
2543 : : real(dp) :: kpoint(3),restr(6),dummy(0,0)
2544 : 96 : real(dp),allocatable :: d2bbb_k(:,:,:,:),d2nl_k(:,:,:)
2545 : 96 : real(dp),allocatable :: occ_k(:)
2546 : 96 : real(dp),allocatable :: vhartr01(:),vpsp1(:),vxc1(:,:),xccc3d1(:),ylm1_k(:,:)
2547 : 96 : real(dp),allocatable :: ylm_k(:,:),ylmgr1_k(:,:,:),ylmgr_k(:,:,:)
2548 : 96 : type(pawtab_type) :: pawtab_dum(0)
2549 : : ! *********************************************************************
2550 : :
2551 : : ABI_NVTX_START_RANGE(NVTX_DFPT_NSELT)
2552 : : !Init me
2553 : 96 : comm = mpi_enreg%comm_cell
2554 : 96 : me = mpi_enreg%me_kpt
2555 : :
2556 : : !Zero only portion of nonlocal matrix to be computed here
2557 [ + + + + : 2016 : d2nl(:,:,natom+3:natom+4,idir,ipert)=zero
+ + ]
2558 : 96 : bdtot_index=0
2559 : 96 : bd2tot_index=0
2560 : 96 : icg=0
2561 : 96 : icg1=0
2562 : 96 : mbdkpsp=mband*nkpt_rbz*nsppol
2563 : 96 : mbd2kpsp=2*mband**2*nkpt_rbz*nsppol
2564 : :
2565 : : !Update list of computed matrix elements
2566 [ + + + - ]: 96 : if((ipert==natom+3) .or. (ipert==natom+4)) then
2567 : : ! Eventually expand when strain coupling to other perturbations is implemented
2568 [ + + ]: 288 : do ipert1=natom+3,natom+4
2569 [ + + ]: 864 : do idir1=1,3
2570 : 768 : blkflg(idir1,ipert1,idir,ipert)=1
2571 : : end do
2572 : : end do
2573 : : end if
2574 : :
2575 [ - + + - : 384 : ABI_MALLOC(d2bbb_k,(2,3,mband,mband*prtbbb))
+ - - - +
- - + - +
- + ]
2576 [ - + + - : 288 : ABI_MALLOC(d2nl_k,(2,3,mpert))
+ - + - -
+ - + ]
2577 : :
2578 [ - + + - : 288 : ABI_MALLOC(kg_k,(3,mpw))
+ - + - -
+ - + ]
2579 [ - + + - : 288 : ABI_MALLOC(kg1_k,(3,mpw1))
+ - + - -
+ - + ]
2580 : :
2581 : 96 : n1=ngfft(1) ; n2=ngfft(2) ; n3=ngfft(3)
2582 : 96 : n4=ngfft(4) ; n5=ngfft(5) ; n6=ngfft(6)
2583 : 96 : nfftot=n1*n2*n3
2584 : :
2585 : : !Initialize Hamiltonian (k-independent terms) - NCPP only
2586 : : call gs_hamk%init(psps,pawtab_dum,nspinor,nsppol,nspden,natom,&
2587 : 96 : & typat,xred,nfft,mgfft,ngfft,rprimd,nloalg,ph1d=ph1d)
2588 : :
2589 : 96 : bantot = 0
2590 : 96 : ban2tot = 0
2591 : :
2592 : : !LOOP OVER SPINS
2593 [ + + ]: 195 : do isppol=1,nsppol
2594 : :
2595 [ + + ]: 99 : if (nsppol/=1) then
2596 : 6 : write(msg,*)' **** In dfpt_nselt for isppol=',isppol
2597 : 6 : call wrtout(std_out,msg,'COLL')
2598 : : end if
2599 : :
2600 : 99 : ikg=0
2601 : 99 : ikg1=0
2602 : :
2603 : : ikpt_fbz(1:3)=0
2604 : :
2605 : : ! BIG FAT k POINT LOOP
2606 [ + + ]: 10307 : do ikpt=1,nkpt_rbz
2607 : :
2608 : 10112 : nband_k=nband_rbz(ikpt+(isppol-1)*nkpt_rbz)
2609 : 10112 : istwf_k=istwfk_rbz(ikpt)
2610 : 10112 : npw_k=npwarr(ikpt)
2611 : 10112 : npw1_k=npwar1(ikpt)
2612 [ + + ]: 40448 : kpoint(:)=kpt_rbz(:,ikpt)
2613 : :
2614 : 10112 : bantot = bantot + nband_k
2615 : 10112 : ban2tot = ban2tot + 2*nband_k**2
2616 : :
2617 : : ! asserts at least 1 band of the current k and spin is on present processor
2618 [ + - ]: 10112 : if(proc_distrb_cycle(mpi_enreg%proc_distrb,ikpt,1,nband_k,isppol,me)) then
2619 : : bdtot_index=bdtot_index+nband_k
2620 : : bd2tot_index=bd2tot_index+2*nband_k**2
2621 : : ! Skip the rest of the k-point loop
2622 : : cycle
2623 : : end if
2624 : :
2625 [ - + + - : 30336 : ABI_MALLOC(occ_k,(nband_k))
+ - + - -
+ - + ]
2626 : :
2627 [ - + + - : 40448 : ABI_MALLOC(ylm_k,(npw_k,mpsang*mpsang))
- + + - +
- + - - +
- + ]
2628 [ - + + - : 40448 : ABI_MALLOC(ylm1_k,(npw1_k,mpsang*mpsang))
- + + - +
- + - - +
- + ]
2629 [ + + + - ]: 10112 : if (ipert==natom+3.or.ipert==natom+4) then
2630 [ - + + - : 40448 : ABI_MALLOC(ylmgr_k,(npw_k,3,mpsang*mpsang))
- + + - +
- + - - +
- + - + ]
2631 [ - + + - : 40448 : ABI_MALLOC(ylmgr1_k,(npw1_k,3,mpsang*mpsang))
- + + - +
- + - - +
- + - + ]
2632 : : end if
2633 : :
2634 : : ! enl1_k(:)=zero
2635 [ + + + + : 908022 : d2nl_k(:,:,:)=zero
+ + ]
2636 [ - + - - : 10112 : if(prtbbb==1)d2bbb_k(:,:,:,:)=zero
- - - - -
- ]
2637 [ + + ]: 51218 : occ_k(:)=occ_rbz(1+bdtot_index:nband_k+bdtot_index)
2638 : :
2639 [ + + + + ]: 3546832 : kg_k(:,1:npw_k)=kg(:,1+ikg:npw_k+ikg)
2640 [ + + ]: 10112 : if (psps%useylm==1) then
2641 [ + + ]: 23040 : do ilm=1,mpsang*mpsang
2642 [ + + ]: 2071368 : ylm_k(1:npw_k,ilm)=ylm(1+ikg:npw_k+ikg,ilm)
2643 : : end do
2644 [ + + + - ]: 2304 : if (ipert==natom+3.or.ipert==natom+4) then
2645 [ + + ]: 23040 : do ilm=1,mpsang*mpsang
2646 [ + + ]: 85248 : do ii=1,3
2647 [ + + ]: 6227928 : ylmgr_k(1:npw_k,ii,ilm)=ylmgr(1+ikg:npw_k+ikg,ii,ilm)
2648 : : end do
2649 : : end do
2650 : : end if
2651 : : end if
2652 : :
2653 : 10112 : wtk_k=wtk_rbz(ikpt)
2654 : :
2655 [ + + + + ]: 3738856 : kg1_k(:,:) = 0
2656 : :
2657 [ + + + + ]: 3546832 : kg1_k(:,1:npw1_k)=kg1(:,1+ikg1:npw1_k+ikg1)
2658 [ + + ]: 10112 : if (psps%useylm==1) then
2659 [ + + ]: 23040 : do ilm=1,mpsang*mpsang
2660 [ + + ]: 2071368 : ylm1_k(1:npw1_k,ilm)=ylm1(1+ikg1:npw1_k+ikg1,ilm)
2661 : : end do
2662 [ + + + - ]: 2304 : if (ipert==natom+3.or.ipert==natom+4) then
2663 [ + + ]: 23040 : do ilm=1,mpsang*mpsang
2664 [ + + ]: 85248 : do ii=1,3
2665 [ + + ]: 6227928 : ylmgr1_k(1:npw1_k,ii,ilm)=ylmgr1(1+ikg1:npw1_k+ikg1,ii,ilm)
2666 : : end do
2667 : : end do
2668 : : end if
2669 : : end if
2670 : :
2671 : : ! Compute the eigenvalues, wavefunction,
2672 : : ! contributions to kinetic energy, nonlocal energy, forces,
2673 : : ! and update of rhor1 to this k-point and this spin polarization.
2674 : :
2675 : : ! Note that dfpt_nsteltwf is called with kpoint, while kpt is used inside dfpt_vtowfk
2676 : : call dfpt_nsteltwf(cg,cg1,d2nl_k,ecut,ecutsm,effmass_free,gs_hamk,icg,icg1,ikpt,isppol,&
2677 : : & istwf_k,kg_k,kg1_k,kpoint,mband,mband_mem,mkmem,mk1mem,mpert,mpi_enreg,mpw,mpw1,natom,nband_k,&
2678 : 10112 : & npw_k,npw1_k,nspinor,nsppol,ntypat,occ_k,psps,rmet,wtk_k,ylm_k,ylmgr_k)
2679 [ + + + + : 908022 : d2nl(:,:,:,idir,ipert)=d2nl(:,:,:,idir,ipert)+d2nl_k(:,:,:)
+ + ]
2680 [ - + ]: 10112 : if(prtbbb==1)then
2681 : : d2bbb(:,:,idir,ipert,:,:) = d2bbb(:,:,idir,ipert,:,:) + &
2682 [ # # # # : 0 : & d2bbb_k(:,:,:,:)
# # # # ]
2683 : : end if
2684 : :
2685 [ - + ]: 10112 : ABI_FREE(occ_k)
2686 : :
2687 : : ! Keep track of total number of bands (all k points so far, even for
2688 : : ! k points not treated by me)
2689 : 10112 : bdtot_index=bdtot_index+nband_k
2690 : 10112 : bd2tot_index=bd2tot_index+2*nband_k**2
2691 : :
2692 : : ! Shift array memory
2693 [ + - ]: 10112 : if (mkmem/=0) then
2694 : 10112 : icg=icg+npw_k*nspinor*proc_distrb_nband(mpi_enreg%proc_distrb,ikpt,nband_k,isppol,me)
2695 : 10112 : ikg=ikg+npw_k
2696 : : end if
2697 [ + - ]: 10112 : if (mk1mem/=0) then
2698 : 10112 : icg1=icg1+npw1_k*nspinor*proc_distrb_nband(mpi_enreg%proc_distrb,ikpt,nband_k,isppol,me)
2699 : 10112 : ikg1=ikg1+npw1_k
2700 : : end if
2701 [ - + ]: 10112 : ABI_FREE(ylm_k)
2702 [ - + ]: 10112 : ABI_FREE(ylm1_k)
2703 [ + + + - ]: 10211 : if (ipert==natom+3.or.ipert==natom+4) then
2704 [ - + ]: 10112 : ABI_FREE(ylmgr_k)
2705 [ - + ]: 10112 : ABI_FREE(ylmgr1_k)
2706 : : end if
2707 : :
2708 : : end do ! End big k point loop
2709 : : end do ! End loop over spins
2710 : :
2711 : : if(xmpi_paral==1)then
2712 : 96 : call xmpi_barrier(comm)
2713 : 96 : call wrtout(std_out,' dfpt_nselt: loop on k-points and spins done in parallel','COLL')
2714 : : end if
2715 : :
2716 : : !Treat now varying occupation numbers
2717 : : !if(occopt>=3 .and. occopt <=8) then
2718 : : !SUPPRESSED metallic coding of vtorho
2719 : :
2720 : : !Treat fixed occupation numbers
2721 : : !else
2722 : :
2723 : : !Accumulation over parallel processed now carried out for all terms
2724 : : !in dfpt_nstdy.f
2725 : :
2726 : : !End of test on varying or fixed occupation numbers
2727 : : !end if
2728 : :
2729 : : !The imaginary part of d2nl will be must be set to zero here since
2730 : : !time-reversal symmetry will always be true for the strain peturbation.
2731 : : !The symmetry-reduced kpt set will leave a non-zero imaginary part.
2732 : :
2733 [ + + + + ]: 864 : d2nl(2,:,natom+3:natom+4,idir,ipert)=zero
2734 : :
2735 : : !Symmetrize the non-local contributions,
2736 : : !as was needed for the stresses in a ground-state calculation
2737 : :
2738 [ + + ]: 96 : if (nsym1>1) then
2739 : : ! Pack like symmetric-storage cartesian stress tensor
2740 : 62 : ii=0
2741 [ + + ]: 186 : do ipert1=natom+3,natom+4
2742 [ + + ]: 558 : do idir1=1,3
2743 : 372 : ii=ii+1
2744 : 496 : restr(ii)=d2nl(1,idir1,ipert1,idir,ipert)
2745 : : end do
2746 : : end do
2747 : : ! Do the symmetrization using the ground state routine
2748 : 62 : call stresssym(gprimd,nsym1,restr,symrc1)
2749 : : ! Unpack symmetrized stress tensor
2750 : 62 : ii=0
2751 [ + + ]: 186 : do ipert1=natom+3,natom+4
2752 [ + + ]: 558 : do idir1=1,3
2753 : 372 : ii=ii+1
2754 : 496 : d2nl(1,idir1,ipert1,idir,ipert)=restr(ii)
2755 : : end do
2756 : : end do
2757 : : end if !nsym>1
2758 : :
2759 : : !----------------------------------------------------------------------------
2760 : : !Now, treat the local contribution
2761 : :
2762 [ - + + - : 288 : ABI_MALLOC(vpsp1,(cplex*nfft))
+ - + - -
+ - + ]
2763 : 96 : n3xccc=0
2764 [ + + ]: 96 : if(psps%n1xccc/=0)n3xccc=nfft
2765 [ + + + - : 288 : ABI_MALLOC(xccc3d1,(cplex*n3xccc))
+ - + + -
+ - + ]
2766 [ - + + - : 384 : ABI_MALLOC(vxc1,(cplex*nfft,nspden))
- + + - +
- + - - +
- + ]
2767 [ - + + - : 288 : ABI_MALLOC(vhartr01,(nfft))
+ - + - -
+ - + ]
2768 [ + + ]: 234066 : xccc3d1(:)=zero
2769 : :
2770 : : !To compute Absolute Deformation Potentials toghether with FxE tensor
2771 : : !the reference has to be the same as in the FxE routines
2772 [ - + ]: 96 : rfstrs_ref_=0; if (present(rfstrs_ref)) rfstrs_ref_=rfstrs_ref
2773 [ + + ]: 96 : g0term=0; if (rfstrs_ref_==1) g0term=1
2774 : :
2775 : : !Double loop over strain perturbations
2776 [ + + ]: 288 : do ipert1=natom+3,natom+4
2777 [ + + ]: 864 : do idir1=1,3
2778 [ + + ]: 576 : if(ipert1==natom+3) then
2779 : 288 : istr1=idir1
2780 : : else
2781 : 288 : istr1=idir1+3
2782 : : end if
2783 : :
2784 : : ! Get first-order local potential.
2785 : : call vlocalstr(gmet,gprimd,gsqcut,istr1,mgfft,mpi_enreg,&
2786 : : & psps%mqgrid_vl,natom,gs_hamk%nattyp,nfft,ngfft,ntypat,ph1d,psps%qgrid_vl,&
2787 : 576 : & ucvol,psps%vlspl,vpsp1,g0term=g0term)
2788 : :
2789 : : ! Get first-order hartree potential.
2790 : : call hartrestr(gsqcut,idir1,ipert1,mpi_enreg,natom,nfft,ngfft,&
2791 : 576 : & rhog,rprimd,vhartr01)
2792 : :
2793 : : ! Get first-order exchange-correlation potential
2794 [ + + ]: 576 : if(psps%n1xccc/=0)then
2795 : : call dfpt_mkcore(cplex,idir1,ipert1,natom,ntypat,n1,psps%n1xccc,&
2796 : 348 : & n2,n3,qphon,rprimd,typat,ucvol,psps%xcccrc,psps%xccc1d,xccc3d1,xred)
2797 : : end if ! psps%n1xccc/=0
2798 : :
2799 : 576 : option=0
2800 : : call dfpt_mkvxcstr(cplex,idir1,ipert1,kxc,mpi_enreg,natom,nfft,ngfft,&
2801 : : & dummy,dummy,nkxc,nmxc,nspden,n3xccc,option,qphon,rhor,rhor1,rprimd,&
2802 : 576 : & 0,0,vxc1,xccc3d1)
2803 : :
2804 : : ! Combines density j2 with local potential j1
2805 [ + + ]: 1170 : do ispden=1,min(nspden,2)
2806 [ + + ]: 2412978 : do ifft=1,cplex*nfft
2807 : 2412402 : vxc1(ifft,ispden)=vxc1(ifft,ispden)+vpsp1(ifft)+vhartr01(ifft)
2808 : : end do
2809 : : end do
2810 : 576 : call dotprod_vn(cplex,rhor1,dotr,doti,nfft,nfftot,nspden,2,vxc1,ucvol)
2811 : 576 : write(std_out,*)
2812 : 576 : d2lo(1,idir1,ipert1,idir,ipert)=dotr
2813 : 768 : d2lo(2,idir1,ipert1,idir,ipert)=doti
2814 : : end do ! istr1
2815 : : end do ! ipert1
2816 : :
2817 : 96 : call gs_hamk%free()
2818 : :
2819 [ - + ]: 96 : ABI_FREE(vxc1)
2820 [ - + ]: 96 : ABI_FREE(xccc3d1)
2821 [ - + ]: 96 : ABI_FREE(vhartr01)
2822 : :
2823 [ - + ]: 96 : ABI_FREE(d2bbb_k)
2824 [ - + ]: 96 : ABI_FREE(d2nl_k)
2825 [ - + ]: 96 : ABI_FREE(kg_k)
2826 [ - + ]: 96 : ABI_FREE(kg1_k)
2827 [ - + ]: 96 : ABI_FREE(vpsp1)
2828 : : ABI_NVTX_END_RANGE()
2829 : :
2830 [ - + - + : 96 : end subroutine dfpt_nselt
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + ]
2831 : : !!***
2832 : :
2833 : : !!****f* ABINIT/dfpt_nsteltwf
2834 : : !! NAME
2835 : : !! dfpt_nsteltwf
2836 : : !!
2837 : : !! FUNCTION
2838 : : !! This routine computes the non-local and kinetic contribution to the
2839 : : !! 2DTE matrix elements, in the non-stationary formulation
2840 : : !!
2841 : : !! INPUTS
2842 : : !! cg(2,mpw*nspinor*mband_mem*mkmem*nsppol)=planewave coefficients of wavefunctions
2843 : : !! cg1(2,mpw1*nspinor*mband_mem*mk1mem*nsppol)=pw coefficients of RF
2844 : : !! wavefunctions at k,q.
2845 : : !! ecut=cut-off energy for plane wave basis sphere (Ha)
2846 : : !! ecutsm=smearing energy for plane wave kinetic energy (Ha) (NOT NEEDED !)
2847 : : !! effmass_free=effective mass for electrons (1. in common case)
2848 : : !! gs_hamk <type(gs_hamiltonian_type)>=all data for the Hamiltonian at k
2849 : : !! icg=shift to be applied on the location of data in the array cg
2850 : : !! icg1=shift to be applied on the location of data in the array cg1
2851 : : !! ikpt=number of the k-point
2852 : : !! isppol=1 for unpolarized, 2 for spin-polarized
2853 : : !! istwf_k=flag controlling the storage of WFs
2854 : : !! kg_k(3,npw_k)=reduced planewave coordinates.
2855 : : !! kg1_k(3,npw1_k)=reduced planewave coordinates at k+q, with RF k points
2856 : : !! kpoint(3)=k-point in reduced coordinates
2857 : : !! mband=maximum number of bands
2858 : : !! mband_mem=maximum number of bands on this cpu
2859 : : !! mkmem =number of k points treated by this node.
2860 : : !! mk1mem =number of k points treated by this node (RF data).
2861 : : !! mpert =maximum number of ipert
2862 : : !! mpi_enreg=information about MPI parallelization
2863 : : !! mpw=maximum dimensioned size of npw or wfs at k
2864 : : !! mpw1=maximum dimensioned size of npw for wfs at k+q (also for 1-order wfs).
2865 : : !! natom=number of atoms in cell.
2866 : : !! nband_k=number of bands at this k point for that spin polarization
2867 : : !! npw_k=number of plane waves at this k point
2868 : : !! npw1_k=number of plane waves at this k+q point
2869 : : !! nspinor=number of spinorial components of the wavefunctions
2870 : : !! nsppol=1 for unpolarized, 2 for spin-polarized
2871 : : !! ntypat=number of types of atoms in unit cell.
2872 : : !! occ_k(nband_k)=occupation number for each band (usually 2) for each k.
2873 : : !! psps <type(pseudopotential_type)>=variables related to pseudopotentials
2874 : : !! rmet(3,3)=real space metric (bohr**2)
2875 : : !! wtk_k=weight assigned to the k point.
2876 : : !! ylm(npw_k,mpsang*mpsang)= real spherical harmonics for each G and k point
2877 : : !! ylmgr(npw_k,3,mpsang*mpsang*useylm)= gradients of real spherical for each G and k point
2878 : : !!
2879 : : !! OUTPUT
2880 : : !! d2nl_k(2,3,mpert)=non-local contributions to
2881 : : !! non-stationary 2DTE, for the present k point, and perturbation idir, ipert
2882 : : !!
2883 : : !! SOURCE
2884 : :
2885 : 10112 : subroutine dfpt_nsteltwf(cg,cg1,d2nl_k,ecut,ecutsm,effmass_free,gs_hamk,icg,icg1,ikpt,isppol,&
2886 : 10112 : & istwf_k,kg_k,kg1_k,kpoint,mband,mband_mem,mkmem,mk1mem,mpert,mpi_enreg,mpw,mpw1,natom,nband_k,&
2887 : 10112 : & npw_k,npw1_k,nspinor,nsppol,ntypat,occ_k,psps,rmet,wtk_k,ylm,ylmgr)
2888 : :
2889 : :
2890 : :
2891 : : !Arguments ------------------------------------
2892 : : !scalars
2893 : : integer,intent(in) :: icg,icg1,ikpt,isppol,istwf_k,mband,mk1mem,mkmem,mpert,mpw,mpw1,natom
2894 : : integer,intent(in) :: mband_mem
2895 : : integer,intent(in) :: nspinor,nsppol,ntypat
2896 : : integer,intent(inout) :: nband_k,npw1_k,npw_k
2897 : : real(dp),intent(in) :: ecut,ecutsm,effmass_free,wtk_k
2898 : : type(MPI_type),intent(in) :: mpi_enreg
2899 : : type(pseudopotential_type),intent(in) :: psps
2900 : : !arrays
2901 : : integer,intent(in) :: kg1_k(3,npw1_k),kg_k(3,npw_k)
2902 : : real(dp),intent(in) :: kpoint(3)
2903 : : real(dp),intent(in) :: cg(2,mpw*nspinor*mband_mem*mkmem*nsppol)
2904 : : real(dp),intent(in) :: cg1(2,mpw1*nspinor*mband_mem*mk1mem*nsppol)
2905 : : real(dp),intent(in) :: occ_k(nband_k),rmet(3,3)
2906 : : real(dp),intent(in) :: ylm(npw_k,psps%mpsang*psps%mpsang)
2907 : : real(dp),intent(in) :: ylmgr(npw_k,3,psps%mpsang*psps%mpsang)
2908 : : real(dp),intent(inout) :: d2nl_k(2,3,mpert)
2909 : :
2910 : : !Local variables-------------------------------
2911 : : !scalars
2912 : : integer :: choice,cpopt,dimffnl,dimffnl2,iband
2913 : : integer :: iband_me
2914 : : integer :: ider,idir0,idir1,ilmn,ipert1,ipw,ipws,ispinor,istr1,itypat
2915 : : integer :: nkpg,nnlout,paw_opt,signs,tim_nonlop
2916 : : real(dp) :: doti,dotr
2917 : : type(gs_hamiltonian_type) :: gs_hamk
2918 : : !arrays
2919 : : real(dp) :: enlout(6),dum_svectout(1,1),dum(1),kpg_dum(0,0)
2920 : 10112 : real(dp),allocatable :: cwave0(:,:),cwavef(:,:),dkinpw(:),eig2_k(:)
2921 : 10112 : real(dp),allocatable :: ffnl(:,:,:,:),ffnl_ylm(:,:,:,:),ghc(:,:)
2922 : 10112 : real(dp),allocatable :: gvnlx1(:,:),gvnlxc(:,:),kinpw1(:),ph3d(:,:,:)
2923 : 10112 : type(pawcprj_type) :: cprj_dum(0,0)
2924 : : ! *********************************************************************
2925 : :
2926 : : !Init me
2927 [ - + + - : 30336 : ABI_MALLOC(ghc,(2,npw1_k*nspinor))
+ - + - -
+ - + ]
2928 [ - + + - : 20224 : ABI_MALLOC(gvnlxc,(2,npw1_k*nspinor))
- + - + ]
2929 [ - + + - : 20224 : ABI_MALLOC(gvnlx1,(2,npw1_k*nspinor))
- + - + ]
2930 [ + - - + : 30336 : ABI_MALLOC(eig2_k,(2*nsppol*mband**2))
+ - + - +
- - + -
+ ]
2931 [ - + + - : 30336 : ABI_MALLOC(kinpw1,(npw1_k))
+ - + - -
+ - + ]
2932 [ - + + - : 30336 : ABI_MALLOC(dkinpw,(npw_k))
+ - + - -
+ - + ]
2933 : 10112 : nkpg=0
2934 : :
2935 : : !Compute nonlocal form factors ffnl at (k+G), for all atoms
2936 : 10112 : dimffnl=2
2937 [ - + + - : 60672 : ABI_MALLOC(ffnl,(npw_k,dimffnl,psps%lmnmax,ntypat))
+ - - + +
- - + + -
+ - + - -
+ - + ]
2938 [ + + ]: 10112 : if (psps%useylm==0) then
2939 : 7808 : ider=1;idir0=0
2940 : : call mkffnl(psps%dimekb,dimffnl,psps%ekb,ffnl,psps%ffspl,gs_hamk%gmet,gs_hamk%gprimd,ider,idir0,&
2941 : : & psps%indlmn,kg_k,kpg_dum,kpoint,psps%lmnmax,psps%lnmax,psps%mpsang,psps%mqgrid_ff,nkpg,&
2942 : 7808 : & npw_k,ntypat,psps%pspso,psps%qgrid_ff,rmet,psps%usepaw,psps%useylm,ylm,ylmgr)
2943 : : else
2944 : 2304 : ider=1;idir0=-7;dimffnl2=7
2945 [ - + + - : 13824 : ABI_MALLOC(ffnl_ylm,(npw_k,dimffnl2,psps%lmnmax,ntypat))
+ - - + +
- - + + -
+ - + - -
+ - + ]
2946 : : call mkffnl(psps%dimekb,dimffnl2,psps%ekb,ffnl_ylm,psps%ffspl,gs_hamk%gmet,gs_hamk%gprimd,&
2947 : : & ider,idir0,psps%indlmn,kg_k,kpg_dum,kpoint,psps%lmnmax,psps%lnmax,psps%mpsang,psps%mqgrid_ff,&
2948 : 2304 : & nkpg,npw_k,ntypat,psps%pspso,psps%qgrid_ff,rmet,psps%usepaw,psps%useylm,ylm,ylmgr)
2949 [ + + ]: 4608 : do itypat=1,ntypat
2950 [ + + ]: 32256 : do ilmn=1,psps%lmnmax
2951 [ + + ]: 2761056 : ffnl(:,1,ilmn,itypat)=ffnl_ylm(:,1,ilmn,itypat)
2952 : : end do
2953 : : end do
2954 : : end if
2955 : :
2956 : : !Compute kinetic contributions (1/2) (2 Pi)**2 (k+G)**2:
2957 : 10112 : call mkkin(ecut,ecutsm,effmass_free,gs_hamk%gmet,kg1_k,kinpw1,kpoint,npw1_k,0,0)
2958 : :
2959 : : !Load k/k+q-dependent part in the Hamiltonian datastructure
2960 [ - + + - : 40448 : ABI_MALLOC(ph3d,(2,npw_k,gs_hamk%matblk))
- + + - +
- + - - +
- + - + ]
2961 : : call gs_hamk%load_k(kpt_k=kpoint,npw_k=npw_k,istwf_k=istwf_k,kg_k=kg_k,ffnl_k=ffnl,&
2962 : 10112 : ph3d_k=ph3d,compute_ph3d=.true.)
2963 : :
2964 [ - + + - : 30336 : ABI_MALLOC(cwave0,(2,npw_k*nspinor))
+ - + - -
+ - + -
+ ]
2965 [ - + + - : 30336 : ABI_MALLOC(cwavef,(2,npw1_k*nspinor))
+ - + - -
+ - + ]
2966 : :
2967 : : !Loop over bands
2968 : 10112 : iband_me = 0
2969 [ + + ]: 51218 : do iband=1,nband_k
2970 : :
2971 [ + - ]: 41106 : if(mpi_enreg%proc_distrb(ikpt, iband, isppol) /= mpi_enreg%me_kpt) then
2972 : : ! Skip the eigenvalue and the gvnl records of this band
2973 : : cycle
2974 : : end if
2975 : 41106 : iband_me = iband_me + 1
2976 : :
2977 : : ! Get ground-state and first-order wavefunctions
2978 [ + + + + ]: 11303586 : cwave0(:,:)=cg(:,1+(iband_me-1)*npw_k*nspinor+icg:iband_me*npw_k*nspinor+icg)
2979 [ + + + + ]: 11303586 : cwavef(:,:)=cg1(:,1+(iband_me-1)*npw1_k*nspinor+icg1:iband_me*npw1_k*nspinor+icg1)
2980 : :
2981 : : ! Double loop over strain perturbations
2982 [ + + ]: 133430 : do ipert1=natom+3,natom+4
2983 [ + + ]: 369954 : do idir1=1,3
2984 [ + + ]: 246636 : if (ipert1==natom+3) istr1=idir1
2985 [ + + ]: 246636 : if (ipert1==natom+4) istr1=idir1+3
2986 : :
2987 : : ! Compute the derivative of the kinetic operator vs strain in dkinpw
2988 : : call kpgstr(dkinpw,ecut,ecutsm,effmass_free,gs_hamk%gmet,gs_hamk%gprimd,istr1,&
2989 : 246636 : & kg1_k,kpoint,npw1_k)
2990 : :
2991 : : ! Get |vnon-locj1|u0> :
2992 : : ! first-order non-local, applied to zero-order wavefunction
2993 : : ! (??) this routine gives MINUS the non-local contribution
2994 : :
2995 : : ! When using Ylms, load the correct ffnl derivative
2996 [ + + ]: 246636 : if (psps%useylm==1) then
2997 [ + + ]: 110592 : do itypat=1,ntypat
2998 [ + + ]: 774144 : do ilmn=1,psps%lmnmax
2999 [ + + ]: 66265344 : ffnl(:,2,ilmn,itypat)=ffnl_ylm(:,1+istr1,ilmn,itypat)
3000 : : end do
3001 : : end do
3002 : : end if
3003 : :
3004 : 246636 : signs=2 ; choice=3 ; nnlout=6 ; paw_opt=0 ; cpopt=-1 ; tim_nonlop=5
3005 : : call nonlop(choice,cpopt,cprj_dum,enlout,gs_hamk,istr1,dum,mpi_enreg,1,nnlout,paw_opt,&
3006 : 246636 : & signs,dum_svectout,tim_nonlop,cwave0,gvnlx1)
3007 : : ! <G|Vnl1|Cnk> is contained in gvnlx1
3008 : :
3009 : : ! Kinetic contribution
3010 [ + + ]: 493272 : do ispinor=1,nspinor
3011 [ + + ]: 23018232 : do ipw=1,npw1_k
3012 : 22524960 : ipws=ipw+npw1_k*(ispinor-1)
3013 [ + - ]: 22771596 : if(kinpw1(ipw)<huge(zero)*1.d-11)then
3014 : 22524960 : gvnlx1(1,ipws)=gvnlx1(1,ipws)+dkinpw(ipw)*cwave0(1,ipws)
3015 : 22524960 : gvnlx1(2,ipws)=gvnlx1(2,ipws)+dkinpw(ipw)*cwave0(2,ipws)
3016 : : else
3017 : 0 : gvnlx1(1,ipws)=0.0_dp
3018 : 0 : gvnlx1(2,ipws)=0.0_dp
3019 : : end if
3020 : : end do
3021 : : end do
3022 : :
3023 : : ! construct the matrix element (<uj2|vj1|u0>)complex conjug.
3024 : : ! and add it to the 2nd-order matrix
3025 : : ! imaginary term should be zero for strain-strain 2nd derivatives,
3026 : : ! but keep it as a test for now
3027 : : call dotprod_g(dotr,doti,gs_hamk%istwf_k,npw1_k*nspinor,2,cwavef,gvnlx1,&
3028 : 246636 : & mpi_enreg%me_g0,mpi_enreg%comm_spinorfft)
3029 : :
3030 : 246636 : d2nl_k(1,idir1,ipert1)= d2nl_k(1,idir1,ipert1)+wtk_k*occ_k(iband)*2.0_dp*dotr
3031 : 328848 : d2nl_k(2,idir1,ipert1)= d2nl_k(2,idir1,ipert1)-wtk_k*occ_k(iband)*2.0_dp*doti
3032 : :
3033 : : end do !idir1
3034 : : end do !ipert1
3035 : :
3036 : : ! UNTIL NOW, DO NOT TAKE INTO ACCOUNT istwf_k
3037 : : end do ! End loop over bands
3038 : :
3039 [ - + ]: 10112 : ABI_FREE(cwave0)
3040 [ - + ]: 10112 : ABI_FREE(cwavef)
3041 : :
3042 : : !###################################################################
3043 : :
3044 [ - + ]: 10112 : ABI_FREE(eig2_k)
3045 [ - + ]: 10112 : ABI_FREE(ghc)
3046 [ - + ]: 10112 : ABI_FREE(gvnlxc)
3047 [ - + ]: 10112 : ABI_FREE(gvnlx1)
3048 [ - + ]: 10112 : ABI_FREE(kinpw1)
3049 [ - + ]: 10112 : ABI_FREE(dkinpw)
3050 [ - + ]: 10112 : ABI_FREE(ffnl)
3051 [ - + ]: 10112 : ABI_FREE(ph3d)
3052 [ + + ]: 10112 : ABI_SFREE(ffnl_ylm)
3053 : :
3054 [ - + - + : 10112 : end subroutine dfpt_nsteltwf
- + ]
3055 : : !!***
3056 : :
3057 : : !!****f* ABINIT/dfpt_nstdy
3058 : : !! NAME
3059 : : !! dfpt_nstdy
3060 : : !!
3061 : : !! FUNCTION
3062 : : !! This routine compute the non-stationary expression for the
3063 : : !! second derivative of the total energy, for a whole row of
3064 : : !! mixed derivatives.
3065 : : !! Only for norm-conserving pseudopotentials (no PAW)
3066 : : !!
3067 : : !! INPUTS
3068 : : !! atindx(natom)=index table for atoms (see gstate.f)
3069 : : !! cg(2,mpw*nspinor*mband_mem*mkmem*nsppol)=planewave coefficients of wavefunctions at k
3070 : : !! cg1(2,mpw1*nspinor*mband_mem*mk1mem*nsppol)=pw coefficients of RF wavefunctions at k,q.
3071 : : !! cplex: if 1, real space 1-order functions on FFT grid are REAL, if 2, COMPLEX
3072 : : !! dtfil <type(datafiles_type)>=variables related to files
3073 : : !! dtset <type(dataset_type)>=all input variables for this dataset
3074 : : !! eigen0(mband*nkpt_rbz*nsppol)=GS eigenvalues at k (hartree)
3075 : : !! eigen1(2*mband*mband*nkpt_rbz*nsppol)=array for holding eigenvalues
3076 : : !! gmet(3,3)=reciprocal space metric tensor in bohr**-2.
3077 : : !! gsqcut=cutoff on (k+G)^2 (bohr^-2)
3078 : : !! idir=direction of the perturbation
3079 : : !! indkpt1(nkpt_rbz)=non-symmetrized indices of the k-points
3080 : : !! indsy1(4,nsym1,natom)=indirect indexing array for atom labels
3081 : : !! ipert=type of the perturbation
3082 : : !! istwfk_rbz(nkpt_rbz)=input option parameter that describes the storage of wfs
3083 : : !! kg(3,mpw*mkmem)=reduced planewave coordinates.
3084 : : !! kg1(3,mpw1*mk1mem)=reduced planewave coordinates at k+q, with RF k points
3085 : : !! kpt_rbz(3,nkpt_rbz)=reduced coordinates of k points in the reduced BZ
3086 : : !! kxc(nfft,nkxc)=exchange and correlation kernel
3087 : : !! mkmem =number of k points treated by this node (GS data)
3088 : : !! mk1mem =number of k points treated by this node (RF data)
3089 : : !! mpert =maximum number of ipert
3090 : : !! mpi_enreg=information about MPI parallelization
3091 : : !! mpw=maximum dimensioned size of npw or wfs at k
3092 : : !! mpw1=maximum dimensioned size of npw for wfs at k+q (also for 1-order wfs).
3093 : : !! nattyp(ntypat)= # atoms of each type.
3094 : : !! nband_rbz(nkpt_rbz*nsppol)=number of bands at each RF k point for each spin
3095 : : !! nfft=(effective) number of FFT grid points (for this proc)
3096 : : !! ngfft(1:18)=integer array with FFT box dimensions and other
3097 : : !! nkpt=number of k points in the full BZ
3098 : : !! nkpt_rbz=number of k points in the reduced BZ for this perturbation
3099 : : !! nkxc=second dimension of the kxc array. If /=0, the XC kernel must be computed.
3100 : : !! npwarr(nkpt_rbz)=number of planewaves in basis at this GS k point
3101 : : !! npwar1(nkpt_rbz)=number of planewaves in basis at this RF k+q point
3102 : : !! nspden=number of spin-density components
3103 : : !! nsppol=1 for unpolarized, 2 for spin-polarized
3104 : : !! nsym1=number of symmetry elements in space group consistent with i perturbation
3105 : : !! occ_rbz(mband*nkpt_rbz*nsppol)=occupation number for each band
3106 : : !! and k in the reduced Brillouin zone (usually =2)
3107 : : !! ph1d(2,3*(2*mgfft+1)*natom)=one-dimensional structure factor information
3108 : : !! psps <type(pseudopotential_type)>=variables related to pseudopotentials
3109 : : !! qphon(3)=reduced coordinates for the phonon wavelength
3110 : : !! rhor1(cplex*nfft,nspden)=RF electron density in electrons/bohr**3.
3111 : : !! rmet(3,3)=real space metric (bohr**2)
3112 : : !! rprimd(3,3)=dimensional primitive translations in real space (bohr)
3113 : : !! symrc1(3,3,nsym1)=symmetry operations in reciprocal space
3114 : : !! ucvol=unit cell volume in bohr**3.
3115 : : !! wtk_rbz(nkpt_rbz)=weight assigned to each k point in the reduced BZ
3116 : : !! xred(3,natom)=reduced dimensionless atomic coordinates
3117 : : !! ylm(mpw*mkmem,mpsang*mpsang*useylm)= real spherical harmonics for each G and k point
3118 : : !! ylm1(mpw1*mk1mem,mpsang*mpsang*useylm)= real spherical harmonics for each G and k+q point
3119 : : !!
3120 : : !! OUTPUT
3121 : : !! blkflg(3,mpert,3,mpert)=flags for each element of the 2DTE (=1 if computed)
3122 : : !! d2bbb(2,3,3,mpert,mband,mband*prtbbb)=band by band decomposition of some
3123 : : !! second order derivatives
3124 : : !! d2lo(2,3,mpert,3,mpert)=local contributions to the 2DTEs
3125 : : !! d2nl(2,3,mpert,3,mpert)=non-local contributions to the 2DTEs
3126 : : !!
3127 : : !! NOTES
3128 : : !! Note that the ddk perturbation should not be treated here.
3129 : : !!
3130 : : !! SOURCE
3131 : :
3132 : 1827 : subroutine dfpt_nstdy(atindx,blkflg,cg,cg1,cplex,dtfil,dtset,d2bbb,d2lo,d2nl,eigen0,eigen1,&
3133 : 1827 : & gmet,gsqcut,idir,indkpt1,indsy1,ipert,istwfk_rbz,kg,kg1,kpt_rbz,kxc,mband_mem_rbz,mkmem,mk1mem,&
3134 : 1827 : & mpert,mpi_enreg,mpw,mpw1,nattyp,nband_rbz,nfft,ngfft,nkpt,nkpt_rbz,nkxc,&
3135 : 1827 : & npwarr,npwar1,nspden,nsppol,nsym1,occ_rbz,ph1d,psps,qphon,rhor1,rmet,rprimd,&
3136 : 1827 : & symrc1,ucvol,wtk_rbz,xred,ylm,ylm1,rhor,vxc,ixcrot)
3137 : :
3138 : : !Arguments -------------------------------
3139 : : !scalars
3140 : : integer,intent(in) :: cplex,idir,ipert,mk1mem,mkmem,mpert,mpw,mpw1,nfft,nkpt,nkpt_rbz,nkxc,nspden,nsppol,nsym1
3141 : : integer,intent(in) :: mband_mem_rbz
3142 : : real(dp),intent(in) :: gsqcut,ucvol
3143 : : type(MPI_type),intent(in) :: mpi_enreg
3144 : : type(datafiles_type),intent(in) :: dtfil
3145 : : type(dataset_type),intent(in) :: dtset
3146 : : type(pseudopotential_type),intent(in) :: psps
3147 : : !optional
3148 : : integer,optional,intent(in) :: ixcrot
3149 : : !arrays
3150 : : integer,intent(in) :: atindx(dtset%natom),indkpt1(nkpt_rbz),indsy1(4,nsym1,dtset%natom)
3151 : : integer,intent(in) :: istwfk_rbz(nkpt_rbz),kg(3,mpw*mkmem),kg1(3,mpw1*mk1mem)
3152 : : integer,intent(in) :: nattyp(dtset%ntypat),nband_rbz(nkpt_rbz*nsppol),ngfft(18)
3153 : : integer,intent(in) :: npwar1(nkpt_rbz),npwarr(nkpt_rbz),symrc1(3,3,nsym1)
3154 : : integer,intent(inout) :: blkflg(3,mpert,3,mpert) !vz_i
3155 : : real(dp),intent(in) :: cg(2,mpw*dtset%nspinor*mband_mem_rbz*mkmem*nsppol)
3156 : : real(dp),intent(in) :: cg1(2,mpw1*dtset%nspinor*mband_mem_rbz*mk1mem*nsppol)
3157 : : real(dp),intent(in) :: eigen0(dtset%mband*nkpt_rbz*nsppol)
3158 : : real(dp),intent(in) :: eigen1(2*dtset%mband*dtset%mband*nkpt_rbz*nsppol)
3159 : : real(dp),intent(in) :: gmet(3,3),kpt_rbz(3,nkpt_rbz)
3160 : : real(dp),intent(in) :: kxc(nfft,nkxc),occ_rbz(dtset%mband*nkpt_rbz*nsppol)
3161 : : real(dp),intent(in) :: ph1d(2,3*(2*dtset%mgfft+1)*dtset%natom),qphon(3)
3162 : : real(dp),intent(in) :: rhor1(cplex*nfft,nspden),rmet(3,3),rprimd(3,3)
3163 : : real(dp),intent(in) :: wtk_rbz(nkpt_rbz),xred(3,dtset%natom)
3164 : : real(dp),intent(in) :: ylm(mpw*mkmem,psps%mpsang*psps%mpsang*psps%useylm)
3165 : : real(dp),intent(in) :: ylm1(mpw1*mk1mem,psps%mpsang*psps%mpsang*psps%useylm)
3166 : : real(dp),intent(inout) :: d2bbb(2,3,3,mpert,dtset%mband,dtset%mband*dtset%prtbbb)!vz_i
3167 : : real(dp),intent(inout) :: d2lo(2,3,mpert,3,mpert),d2nl(2,3,mpert,3,mpert) !vz_i
3168 : : ! optional
3169 : : real(dp),optional,intent(in) :: rhor(nfft,nspden)
3170 : : real(dp),optional,intent(in) :: vxc(nfft,nspden)
3171 : :
3172 : : !Local variables-------------------------------
3173 : : !scalars
3174 : : integer,parameter :: formeig1=1
3175 : : integer :: ban2tot,bantot,bdtot_index,ddkcase,iband,icg,icg1,idir1
3176 : : integer :: ierr,ifft,ii,ikg,ikg1,ikpt,ilm,ipert1,ispden,isppol
3177 : : integer :: istwf_k,isym,jj,master,me,n1,n2,n3,n3xccc,n4,n5,n6
3178 : : integer :: nband_k,nfftot,npw1_k,npw_k,nspinor_,option,spaceworld,optnc
3179 : : real(dp) :: doti,dotr,wtk_k
3180 : : logical :: nmxc=.false.,t_exist
3181 : : character(len=500) :: msg
3182 : : character(len=fnlen) :: fiwfddk
3183 : 1827 : type(gs_hamiltonian_type) :: gs_hamkq
3184 : : !arrays
3185 : : integer :: ddkfil(3)
3186 : 3654 : integer,allocatable :: kg1_k(:,:),kg_k(:,:),symrl1(:,:,:)
3187 : : real(dp) :: d2nl_elfd(2,3),d2nl_mgfd(2,3),kpoint(3),kpq(3),sumelfd(2),summgfd(2),tsec(2)
3188 : 1827 : real(dp),allocatable :: buffer1(:),buffer2(:),d2bbb_k(:,:,:,:),d2nl_k(:,:,:)
3189 : 1827 : real(dp),allocatable :: eig1_k(:),eig_k(:),occ_k(:)
3190 : : real(dp) :: rhodummy(0,0)
3191 : 1827 : real(dp),allocatable :: vpsp1(:),vxc1(:,:),work1(:,:,:),xccc3d1(:),ylm1_k(:,:),ylm_k(:,:)
3192 [ - + - + : 3654 : type(pawtab_type) :: pawtab(dtset%ntypat*psps%usepaw)
- + - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - ]
3193 [ + + + + : 179046 : type(wfk_t) :: ddks(3)
+ + + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - -
- - - - -
- - - - -
- - - + -
+ - + - ]
3194 : : ! *********************************************************************
3195 : :
3196 : : ABI_UNUSED(nkpt)
3197 : :
3198 : : DBG_ENTER("COLL")
3199 : :
3200 : : ABI_NVTX_START_RANGE(NVTX_DFPT_NSTDY)
3201 : :
3202 : : !Not valid for PAW
3203 [ - + ]: 1827 : if (psps%usepaw==1) then
3204 : 0 : ABI_BUG('This routine cannot be used for PAW (use dfpt_nstpaw instead) !')
3205 : : end if
3206 : :
3207 : : !Keep track of total time spent in dfpt_nstdy
3208 : 1827 : call timab(111,1,tsec)
3209 : :
3210 : : !Init parallelism
3211 : 1827 : spaceworld=mpi_enreg%comm_cell
3212 : 1827 : me=mpi_enreg%me_kpt
3213 : :
3214 : 1827 : master =0
3215 : :
3216 : : !Zero only portion of nonlocal matrix to be computed here
3217 [ + + + + : 77787 : d2nl(:,:,1:dtset%natom+2,idir,ipert)=zero
+ + ]
3218 : :
3219 [ - + + - : 7308 : ABI_MALLOC(d2bbb_k,(2,3,dtset%mband,dtset%mband*dtset%prtbbb))
+ + + - +
- + + - +
- + ]
3220 [ - + + - : 5481 : ABI_MALLOC(d2nl_k,(2,3,mpert))
+ - + - -
+ - + ]
3221 [ - + + - : 5481 : ABI_MALLOC(eig_k,(nsppol*dtset%mband))
+ - + - -
+ - + ]
3222 [ + - - + : 5481 : ABI_MALLOC(eig1_k,(2*nsppol*dtset%mband**2))
+ - + - +
- - + -
+ ]
3223 [ - + + - : 5481 : ABI_MALLOC(kg_k,(3,mpw))
+ - + - -
+ - + ]
3224 [ - + + - : 5481 : ABI_MALLOC(kg1_k,(3,mpw1))
+ - + - -
+ - + ]
3225 : :
3226 : : !Do not try to open electric field file
3227 : 1827 : ddkfil(:)=0
3228 : : !The treatment of homogeneous electric field potential need the existence of d/dk files.
3229 [ + + ]: 7308 : do idir1=1,3
3230 : 5481 : ddkcase=idir1+dtset%natom*3
3231 : 5481 : call appdig(ddkcase,dtfil%fnamewffddk,fiwfddk)
3232 : :
3233 : : ! Check that ddk file exists
3234 : 5481 : t_exist = file_exists(fiwfddk)
3235 [ + - ]: 5481 : if (.not. t_exist) then
3236 : : ! Try netcdf file.
3237 : 5481 : t_exist = file_exists(nctk_ncify(fiwfddk))
3238 [ + + ]: 5481 : if (t_exist) then
3239 : 1195 : fiwfddk = nctk_ncify(fiwfddk)
3240 : 1195 : write(msg,"(3a)")"- File: ",trim(fiwfddk)," does not exist but found netcdf file with similar name."
3241 : 1195 : call wrtout(std_out,msg,'COLL')
3242 : : end if
3243 : : end if
3244 : :
3245 : 1827 : if (t_exist) then
3246 : : ! Note the use of unit numbers 21, 22 and 23
3247 : : ! Open files in sequential mode
3248 : 1195 : ddkfil(idir1)=20+idir1
3249 : 1195 : write(msg, '(a,a)') '-open ddk wf file :',trim(fiwfddk)
3250 [ + + ]: 3585 : call wrtout([std_out, ab_out], msg)
3251 : 1195 : call ddks(idir1)%open_read(fiwfddk, formeig1, dtset%iomode, ddkfil(idir1), xmpi_comm_self)
3252 : : end if
3253 : : end do
3254 : :
3255 : : !Update list of computed matrix elements
3256 [ + + ]: 1827 : if (ipert /= dtset%natom + 1) then
3257 [ + + ]: 15644 : do ipert1=1,mpert
3258 [ + + ]: 58016 : do idir1=1,3
3259 [ + + + + : 56496 : if(ipert1 <= dtset%natom .or. ipert1==dtset%natom+2 .and. ddkfil(idir1)/=0) then
+ + ]
3260 : 11038 : blkflg(idir1,ipert1,idir,ipert)=1
3261 : : end if
3262 : : end do
3263 : : end do
3264 : : else
3265 : 307 : ipert1 = dtset%natom + 1
3266 [ + + ]: 1228 : do idir1=1,3
3267 : : ! If was already computed in another run or dataset, or if is to be computed in the present one
3268 [ + + + + : 1228 : if ((ddkfil(idir1) /= 0).or. (dtset%rfdir(idir1)/=0.and. idir1<=idir) ) then
+ + ]
3269 : : ! if ((ddkfil(idir1) /= 0).or. (idir1==idir) ) then
3270 : 544 : blkflg(idir1,ipert1,idir,ipert)=1
3271 : : end if
3272 : : end do
3273 : : end if
3274 : :
3275 : 1827 : n1=dtset%ngfft(1) ; n2=dtset%ngfft(2) ; n3=dtset%ngfft(3)
3276 : 1827 : n4=dtset%ngfft(4) ; n5=dtset%ngfft(5) ; n6=dtset%ngfft(6)
3277 : 1827 : nspinor_=dtset%nspinor
3278 : :
3279 : 1827 : bantot = 0
3280 : 1827 : ban2tot = 0
3281 : :
3282 : : !==== Initialize most of the Hamiltonian ====
3283 : : !1) Allocate all arrays and initialize quantities that do not depend on k and spin.
3284 : : !2) Perform the setup needed for the non-local factors:
3285 : : !3) Constant kleimann-Bylander energies are copied from psps to gs_hamk.
3286 : : call gs_hamkq%init(psps,pawtab,dtset%nspinor,nsppol,nspden,dtset%natom,&
3287 : : & dtset%typat,xred,nfft,dtset%mgfft,ngfft,rprimd,dtset%nloalg,ph1d=ph1d,&
3288 : 1827 : & gpu_option=dtset%gpu_option)
3289 : :
3290 : : !LOOP OVER SPINS
3291 : 1827 : bdtot_index=0
3292 : 1827 : icg=0;icg1=0
3293 [ + + ]: 3738 : do isppol=1,nsppol
3294 : :
3295 : 1911 : ikg=0;ikg1=0
3296 : :
3297 : : ! Continue to initialize the Hamiltonian
3298 : 1911 : call gs_hamkq%load_spin(isppol,with_nonlocal=.true.)
3299 : :
3300 : : ! BIG FAT k POINT LOOP
3301 [ + + ]: 123933 : do ikpt=1,nkpt_rbz
3302 : :
3303 : 120195 : nband_k=nband_rbz(ikpt+(isppol-1)*nkpt_rbz)
3304 : 120195 : istwf_k=istwfk_rbz(ikpt)
3305 : 120195 : npw_k=npwarr(ikpt)
3306 : 120195 : npw1_k=npwar1(ikpt)
3307 : :
3308 [ + + ]: 810651 : eig_k(1:nband_k) = eigen0(1+bantot:nband_k+bantot)
3309 [ + + ]: 11213507 : eig1_k(1:2*nband_k**2) = eigen1(1+ban2tot:2*nband_k**2+ban2tot)
3310 : 120195 : bantot = bantot + nband_k
3311 : 120195 : ban2tot = ban2tot + 2*nband_k**2
3312 : :
3313 : :
3314 [ + + ]: 120195 : if(proc_distrb_cycle(mpi_enreg%proc_distrb,ikpt,1,nband_k,isppol,me)) then
3315 : 20872 : bdtot_index=bdtot_index+nband_k
3316 : : ! The wavefunction blocks for ddk file is skipped elsewhere in the loop
3317 : : ! Skip the rest of the k-point loop
3318 : 20872 : cycle
3319 : : end if
3320 : :
3321 [ - + + - : 397292 : ABI_MALLOC(ylm_k,(npw_k,psps%mpsang*psps%mpsang*psps%useylm))
+ + + - +
- + + - +
- + ]
3322 [ - + + - : 397292 : ABI_MALLOC(ylm1_k,(npw1_k,psps%mpsang*psps%mpsang*psps%useylm))
+ + + - +
- + + - +
- + ]
3323 : :
3324 : : ! In case of electric field pert1, read ddk wfs file
3325 : : ! Note that the symmetries are not used for ddk, so read each k point
3326 : : ! Also take into account implicitly the parallelism over k points
3327 : :
3328 [ + + ]: 397292 : do idir1=1,3
3329 [ + + ]: 397292 : if (ddkfil(idir1)/=0) then
3330 : 75546 : ii = ddks(idir1)%findk(kpt_rbz(:, ikpt))
3331 [ - + ]: 75546 : ABI_CHECK(ii == indkpt1(ikpt), "ii != indkpt1")
3332 : : end if
3333 : : end do
3334 : :
3335 [ - + + - : 297969 : ABI_MALLOC(occ_k,(nband_k))
+ - + - -
+ - + ]
3336 [ + + ]: 678003 : occ_k(:)=occ_rbz(1+bdtot_index:nband_k+bdtot_index)
3337 [ + + ]: 397292 : kpoint(:)=kpt_rbz(:,ikpt)
3338 [ + + ]: 397292 : kpq(:)=kpoint(:)+qphon(:)
3339 : 99323 : wtk_k=wtk_rbz(ikpt)
3340 [ + + + + : 8858203 : d2nl_k(:,:,:)=zero
+ + ]
3341 [ + + + + : 197819 : if(dtset%prtbbb==1)d2bbb_k(:,:,:,:)=zero
+ + + + +
+ ]
3342 : :
3343 : : ! Get plane-wave vectors and related data at k
3344 [ + + + + ]: 59775719 : kg_k(:,1:npw_k)=kg(:,1+ikg:npw_k+ikg)
3345 [ + + ]: 99323 : if (psps%useylm==1) then
3346 [ + + ]: 224358 : do ilm=1,psps%mpsang*psps%mpsang
3347 [ + + ]: 28397291 : ylm_k(1:npw_k,ilm)=ylm(1+ikg:npw_k+ikg,ilm)
3348 : : end do
3349 : : end if
3350 : :
3351 : : ! Get plane-wave vectors and related data at k+q
3352 [ + + + + ]: 59766471 : kg1_k(:,1:npw1_k)=kg1(:,1+ikg1:npw1_k+ikg1)
3353 [ + + ]: 99323 : if (psps%useylm==1) then
3354 [ + + ]: 224358 : do ilm=1,psps%mpsang*psps%mpsang
3355 [ + + ]: 28397291 : ylm1_k(1:npw1_k,ilm)=ylm1(1+ikg1:npw1_k+ikg1,ilm)
3356 : : end do
3357 : : end if
3358 : :
3359 : : ! Compute the eigenvalues, wavefunction,
3360 : : ! contributions to kinetic energy, nonlocal energy, forces,
3361 : : ! and update of rhor1 to this k-point and this spin polarization.
3362 : : ! Note that dfpt_nstwf is called with kpoint, while kpt is used inside dfpt_vtowfk
3363 : : call dfpt_nstwf(cg,cg1,ddkfil,dtset,d2bbb_k,d2nl_k,eig_k,eig1_k,gs_hamkq,&
3364 : : & icg,icg1,idir,ikpt,ipert,isppol,istwf_k,kg_k,kg1_k,kpoint,kpq,mband_mem_rbz,mkmem,mk1mem,mpert,&
3365 : : & mpi_enreg,mpw,mpw1,nband_k,npw_k,npw1_k,nsppol,&
3366 : 99323 : & occ_k,psps,rmet,ddks,wtk_k,ylm_k,ylm1_k)
3367 : :
3368 [ + + + + : 8858203 : d2nl(:,:,:,idir,ipert)=d2nl(:,:,:,idir,ipert)+d2nl_k(:,:,:)
+ + ]
3369 [ + + + + : 197819 : if(dtset%prtbbb==1)d2bbb(:,:,idir,ipert,:,:)=d2bbb(:,:,idir,ipert,:,:)+d2bbb_k(:,:,:,:)
+ + + + +
+ ]
3370 : :
3371 : : ! Keep track of total number of bands
3372 : 99323 : bdtot_index=bdtot_index+nband_k
3373 : :
3374 : : ! Shift arrays memory
3375 [ + - ]: 99323 : if (mkmem/=0) then
3376 : 99323 : icg=icg+npw_k*dtset%nspinor*proc_distrb_nband(mpi_enreg%proc_distrb,ikpt,nband_k,isppol,me)
3377 : 99323 : ikg=ikg+npw_k
3378 : : end if
3379 [ + - ]: 99323 : if (mk1mem/=0) then
3380 : 99323 : icg1=icg1+npw1_k*dtset%nspinor*proc_distrb_nband(mpi_enreg%proc_distrb,ikpt,nband_k,isppol,me)
3381 : 99323 : ikg1=ikg1+npw1_k
3382 : : end if
3383 : :
3384 [ - + ]: 99323 : ABI_FREE(occ_k)
3385 [ - + ]: 99323 : ABI_FREE(ylm_k)
3386 [ - + ]: 101234 : ABI_FREE(ylm1_k)
3387 : : end do ! End big k point loop
3388 : : end do ! End loop over spins
3389 : :
3390 : 1827 : call gs_hamkq%free()
3391 : :
3392 : : !Treat fixed occupation numbers (as in vtorho)
3393 : : if(xmpi_paral==1)then
3394 [ + - - + : 7308 : ABI_MALLOC(buffer1,(2*3*mpert))
+ - + - +
- - + -
+ ]
3395 [ - + + - : 3654 : ABI_MALLOC(buffer2,(2*3*mpert))
- + - + ]
3396 : : ! Pack d2nl
3397 [ + + ]: 3654 : buffer1(1:2*3*mpert)=reshape(d2nl(:,:,:,idir,ipert),(/2*3*mpert/))
3398 : : ! Build sum of everything
3399 : 1827 : call timab(48,1,tsec)
3400 : 1827 : call xmpi_sum(buffer1,buffer2,2*3*mpert,spaceworld,ierr)
3401 : 1827 : call timab(48,2,tsec)
3402 : : ! Unpack the final result
3403 [ + + ]: 7308 : d2nl(:,:,:,idir,ipert)=reshape(buffer2(:),(/2,3,mpert/))
3404 [ - + ]: 1827 : ABI_FREE(buffer1)
3405 [ - + ]: 1827 : ABI_FREE(buffer2)
3406 : :
3407 [ + + ]: 1827 : if(dtset%prtbbb==1)then
3408 [ + - - + : 36 : ABI_MALLOC(buffer1,(2*3*dtset%mband*dtset%mband))
+ - + - +
- - + -
+ ]
3409 [ - + + - : 24 : ABI_MALLOC(buffer2,(2*3*dtset%mband*dtset%mband))
- + - + ]
3410 : : ! Pack d2bbb
3411 [ + + ]: 24 : buffer1(1:2*3*dtset%mband*dtset%mband)=reshape(d2bbb(:,:,idir,ipert,:,:),(/2*3*dtset%mband*dtset%mband/))
3412 : : ! Build sum of everything
3413 : 12 : call timab(48,1,tsec)
3414 : 12 : call xmpi_sum(buffer1,buffer2,2*3*dtset%mband*dtset%mband,spaceworld,ierr)
3415 : 12 : call timab(48,2,tsec)
3416 : : ! Unpack the final result
3417 [ + + + + : 7836 : d2bbb(:,:,idir,ipert,:,:)=reshape(buffer2(:),(/2,3,dtset%mband,dtset%mband/))
+ + + + +
+ ]
3418 [ - + ]: 12 : ABI_FREE(buffer1)
3419 [ - + ]: 12 : ABI_FREE(buffer2)
3420 : : end if
3421 : : end if ! xmpi_paral==1
3422 : :
3423 : : !In the case of the strain perturbation time-reversal symmetry will always
3424 : : !be true so imaginary part of d2nl will be must be set to zero here since
3425 : : !the symmetry-reduced kpt set will leave a non-zero imaginary part.
3426 [ + + + + : 5359 : if(ipert==dtset%natom+3 .or. ipert==dtset%natom+4) d2nl(2,:,:,idir,ipert)=zero
+ + + + ]
3427 : :
3428 : : !In case of electric field ipert1, close the ddk wf files
3429 [ + + ]: 7308 : do idir1=1,3
3430 [ + + ]: 7308 : if (ddkfil(idir1)/=0) call ddks(idir1)%close()
3431 : : end do
3432 : :
3433 : : !Symmetrize the non-local contributions,
3434 : : !as was needed for the forces in a ground-state calculation
3435 : : !However, here the quantity is complex, and there are phases !
3436 : :
3437 : : !Do the transform
3438 [ - + + - : 5481 : ABI_MALLOC(work1,(2,3,dtset%natom))
+ - + - -
+ - + ]
3439 [ + + ]: 5769 : do ipert1=1,dtset%natom
3440 [ + + ]: 17595 : do idir1=1,3
3441 : 11826 : work1(1,idir1,ipert1)=d2nl(1,idir1,ipert1,idir,ipert)
3442 : 15768 : work1(2,idir1,ipert1)=d2nl(2,idir1,ipert1,idir,ipert)
3443 : : end do
3444 : : end do
3445 : 1827 : call dfpt_sygra(dtset%natom,d2nl(:,:,:,idir,ipert),work1,indsy1,ipert,nsym1,qphon,symrc1)
3446 [ - + ]: 1827 : ABI_FREE(work1)
3447 : :
3448 : : !Must also symmetrize the electric/magnetic field perturbation response !
3449 : : !(XG 000803 This was not implemented until now)
3450 [ + + + + ]: 7308 : if(sum(ddkfil(:))/=0)then
3451 : : ! Get the symmetry matrices in terms of real space basis
3452 [ - + + - : 1386 : ABI_MALLOC(symrl1,(3,3,nsym1))
+ - + - -
+ - + ]
3453 [ + + ]: 1233 : do isym=1,nsym1
3454 : 1233 : call mati3inv(symrc1(:,:,isym),symrl1(:,:,isym))
3455 : : end do
3456 : : ! There should not be any imaginary part, but stay general (for debugging)
3457 [ + + + + ]: 4620 : d2nl_elfd(:,:)=d2nl(:,:,dtset%natom+2,idir,ipert)
3458 [ + + ]: 1848 : do ii=1,3
3459 : 1386 : sumelfd(:)=zero
3460 : : summgfd(:)=zero
3461 [ + + ]: 3699 : do isym=1,nsym1
3462 [ + + ]: 9252 : do jj=1,3
3463 [ + + ]: 9252 : if(symrl1(ii,jj,isym)/=0)then
3464 [ + + ]: 2570 : if(ddkfil(jj)==0)then
3465 : 347 : blkflg(ii,dtset%natom+2,idir,ipert)=0
3466 : : end if
3467 : : end if
3468 : : end do
3469 : : sumelfd(:)=sumelfd(:)+dble(symrl1(ii,1,isym))*d2nl_elfd(:,1)+&
3470 : : & dble(symrl1(ii,2,isym))*d2nl_elfd(:,2)+&
3471 [ + + ]: 6939 : & dble(symrl1(ii,3,isym))*d2nl_elfd(:,3)
3472 : : summgfd(:)=summgfd(:)+dble(symrl1(ii,1,isym))*d2nl_mgfd(:,1)+&
3473 : : & dble(symrl1(ii,2,isym))*d2nl_mgfd(:,2)+&
3474 : 1386 : & dble(symrl1(ii,3,isym))*d2nl_mgfd(:,3)
3475 : : end do
3476 [ + + ]: 4620 : d2nl(:,ii,dtset%natom+2,idir,ipert)=sumelfd(:)/dble(nsym1)
3477 : : end do
3478 : :
3479 [ + + + + ]: 462 : if ((dtset%prtbbb==1).and.(ipert<=dtset%natom)) then
3480 [ + + ]: 36 : do iband = 1,dtset%mband
3481 [ + + + + ]: 320 : d2nl_elfd(:,:)=d2bbb(:,:,idir,ipert,iband,iband)
3482 [ + + ]: 132 : do ii=1,3
3483 : 96 : sumelfd(:)=zero
3484 [ + + ]: 480 : do isym=1,nsym1
3485 : : sumelfd(:)=sumelfd(:)+dble(symrl1(ii,1,isym))*d2nl_elfd(:,1)+&
3486 : : & dble(symrl1(ii,2,isym))*d2nl_elfd(:,2)+&
3487 [ + + ]: 1248 : & dble(symrl1(ii,3,isym))*d2nl_elfd(:,3)
3488 : : end do
3489 [ + + ]: 320 : d2bbb(:,ii,idir,ipert,iband,iband)=sumelfd(:)/dble(nsym1)
3490 : : end do
3491 : : end do !iband
3492 : : end if
3493 : :
3494 [ - + ]: 462 : ABI_FREE(symrl1)
3495 : : end if
3496 : :
3497 : : !----------------------------------------------------------------------------
3498 : : !Now, treat the local contribution
3499 : :
3500 : 1827 : nfftot=ngfft(1)*ngfft(2)*ngfft(3)
3501 [ - + + - : 5481 : ABI_MALLOC(vpsp1,(cplex*nfft))
+ - + - -
+ - + ]
3502 [ + + ]: 1827 : if (ipert /= dtset%natom + 1) then
3503 [ + + ]: 1520 : n3xccc=0;if(psps%n1xccc/=0) n3xccc=nfft
3504 [ + + + - : 4560 : ABI_MALLOC(xccc3d1,(cplex*n3xccc))
+ - + + -
+ - + ]
3505 [ - + + - : 6080 : ABI_MALLOC(vxc1,(cplex*nfft,nspden))
- + + - +
- + - - +
- + ]
3506 : :
3507 [ + + ]: 15644 : do ipert1=1,mpert
3508 [ + + ]: 58016 : do idir1=1,3
3509 [ + + ]: 56496 : if(ipert1 <= dtset%natom)then
3510 : :
3511 : : ! Get first-order local potential and first-order pseudo core density
3512 : : call dfpt_vlocal(atindx,cplex,gmet,gsqcut,dtset%icutcoul,idir1,ipert1,mpi_enreg,psps%mqgrid_ff,dtset%natom,&
3513 : : & nattyp,nfft,ngfft,dtset%nkpt,dtset%ntypat,n1,n2,n3,ph1d,psps%qgrid_ff,&
3514 : : & qphon,dtset%rcut,rprimd,ucvol,dtset%vcutgeo,psps%vlspl,vpsp1,xred,&
3515 : 9852 : & zion=dtset%ziontypat)
3516 [ + + ]: 9852 : if(psps%n1xccc/=0)then
3517 : : call dfpt_mkcore(cplex,idir1,ipert1,dtset%natom,dtset%ntypat,n1,psps%n1xccc,&
3518 : 6459 : & n2,n3,qphon,rprimd,dtset%typat,ucvol,psps%xcccrc,psps%xccc1d,xccc3d1,xred)
3519 : : end if
3520 : :
3521 : : ! Get first-order exchange-correlation potential (core-correction contribution only !)
3522 [ + + ]: 9852 : if(psps%n1xccc/=0)then
3523 : 6459 : option=0
3524 : : !FR SPr EB non-collinear magnetism
3525 [ + + + - : 6459 : if (nspden==4.and.present(rhor).and.present(vxc).and.present(ixcrot)) then
+ - ]
3526 : 450 : optnc=1
3527 : : call dfpt_mkvxc_noncoll(cplex,dtset%ixc,kxc,mpi_enreg,nfft,ngfft,rhodummy,0,rhodummy,0,rhodummy,0,&
3528 : : & nkxc,nmxc,nspden,n3xccc,optnc,option,qphon,rhor,rhor1,&
3529 : 450 : & rprimd,0,vxc,vxc1,xccc3d1,ixcrot=ixcrot)
3530 : : else
3531 : : call dfpt_mkvxc(cplex,dtset%ixc,kxc,mpi_enreg,nfft,ngfft,rhodummy,0,rhodummy,0,&
3532 : : & nkxc,nmxc,nspden,n3xccc,option,qphon,rhodummy,&
3533 : 6009 : & rprimd,0,vxc1,xccc3d1)
3534 : : end if
3535 : : else
3536 [ + + + + ]: 28747548 : vxc1(:,:)=zero
3537 : : end if
3538 : :
3539 : : ! Norm-conserving pseudpopotential case:
3540 : : ! Combines density j2 with local potential j1 (vpsp1 and vxc1)
3541 : : ! XG030514 : this is a first possible coding, however, each dotprod contains
3542 : : ! a parallel section (reduction), so it is better to use only one dotprod ...
3543 : : ! call dotprod_vn(cplex,rhor1,dr_psp1,di_psp1,mpi_enreg,nfft,nfftot,1,2,vpsp1,ucvol)
3544 : : ! call dotprod_vn(cplex,rhor1,dr_xc1,di_xc1,mpi_enreg,nfft,nfftot,nspden,2,vxc1,ucvol)
3545 : : ! dotr=dr_psp1+dr_xc1;doti=di_psp1+di_xc1... but then, one needs to overload vxc1
3546 [ + + ]: 20499 : do ispden=1,min(nspden,2)
3547 [ + + ]: 140922459 : do ifft=1,cplex*nfft
3548 : 140912607 : vxc1(ifft,ispden)=vxc1(ifft,ispden)+vpsp1(ifft)
3549 : : end do
3550 : : end do
3551 : 9852 : call dotprod_vn(cplex,rhor1,dotr,doti,nfft,nfftot,nspden,2,vxc1,ucvol)
3552 : :
3553 : : ! MVeithen 021212 : in case ipert = 2, these lines compute the local part
3554 : : ! of the Born effective charges from phonon and electric
3555 : : ! field type perturbations, see eq. 43 of
3556 : : ! X. Gonze and C. Lee, PRB 55, 10355 (1997) [[cite:Gonze1997a]]
3557 : : ! The minus sign is due to the fact that the effective charges
3558 : : ! are minus the second derivatives of the energy
3559 : :
3560 [ + + ]: 9852 : if (ipert == dtset%natom+2) then
3561 : 1140 : d2lo(1,idir1,ipert1,idir,ipert)=-dotr
3562 : 1140 : d2lo(2,idir1,ipert1,idir,ipert)=-doti
3563 : : else
3564 : 8712 : d2lo(1,idir1,ipert1,idir,ipert)=dotr
3565 : 8712 : d2lo(2,idir1,ipert1,idir,ipert)=doti
3566 : : end if
3567 : : ! Endif ipert1<=natom
3568 : : end if
3569 : : end do
3570 : : end do
3571 : :
3572 [ - + ]: 1520 : ABI_FREE(vxc1)
3573 [ - + ]: 1520 : ABI_FREE(xccc3d1)
3574 : :
3575 : : end if ! ipert /= natom +1
3576 : :
3577 [ - + ]: 1827 : ABI_FREE(d2bbb_k)
3578 [ - + ]: 1827 : ABI_FREE(d2nl_k)
3579 [ - + ]: 1827 : ABI_FREE(kg_k)
3580 [ - + ]: 1827 : ABI_FREE(kg1_k)
3581 [ - + ]: 1827 : ABI_FREE(vpsp1)
3582 [ - + ]: 1827 : ABI_FREE(eig_k)
3583 [ - + ]: 1827 : ABI_FREE(eig1_k)
3584 : :
3585 : 1827 : call timab(111,2,tsec)
3586 : :
3587 : : ABI_NVTX_END_RANGE()
3588 : :
3589 : : DBG_EXIT("COLL")
3590 : :
3591 [ - + - + : 168084 : end subroutine dfpt_nstdy
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + ]
3592 : : !!***
3593 : :
3594 : : !!****f* ABINIT/dfpt_rhofermi
3595 : : !! NAME
3596 : : !! dfpt_rhofermi
3597 : : !!
3598 : : !! FUNCTION
3599 : : !! This routine computes the fixed contribution to the first-order
3600 : : !! Fermi energy for metallic occupation and Q=0, as well as the
3601 : : !! Fermi level charge density needed to compute the remainder of the
3602 : : !! first-order Fermi energy from the self-consistent local potential
3603 : : !! at each step in the iteration process.
3604 : : !!
3605 : : !! INPUTS
3606 : : !! atindx(natom)=index table for atoms (see gstate.f)
3607 : : !! cg(2,mpw*nspinor*mband_mem*mkmem*nsppol)=planewave coefficients of wavefunctions.
3608 : : !! cgq(2,mpw1*nspinor*mband_mem*mkqmem*nsppol)=pw coefficients of GS wavefunctions at k+q.
3609 : : !! cplex: if 1, real space 1-order functions on FFT grid are REAL; if 2, COMPLEX
3610 : : !! cprj(natom,nspinor*mband_mem*mkmem*nsppol*usecprj)= wave functions at k
3611 : : !! projected with non-local projectors: cprj=<p_i|Cnk>
3612 : : !! cprjq(natom,nspinor*mband_mem*mkqmem*nsppol*usecprj)= wave functions at k+q
3613 : : !! projected with non-local projectors: cprjq=<p_i|Cnk+q>
3614 : : !! doccde_rbz(mband*nkpt_rbz*nsppol)=derivative of occ_rbz wrt the energy
3615 : : !! docckqde(mband*nkpt_rbz*nsppol)=derivative of occkq wrt the energy
3616 : : !! dtfil <type(datafiles_type)>=variables related to files
3617 : : !! dtset <type(dataset_type)>=all input variables for this dataset
3618 : : !! eigenq(mband*nkpt_rbz*nsppol)=GS eigenvalues at k+q (hartree)
3619 : : !! eigen0(mband*nkpt_rbz*nsppol)=GS eigenvalues at k (hartree)
3620 : : !! gmet(3,3)=reciprocal space metric tensor in bohr**-2.
3621 : : !! gprimd(3,3)=dimensional reciprocal space primitive translations
3622 : : !! idir=direction of the perturbation
3623 : : !! indsy1(4,nsym1,natom)=indirect indexing array for atom labels
3624 : : !! ipert=type of the perturbation
3625 : : !! irrzon1(nfft**(1-1/nsym1),2,(nspden/nsppol)-3*(nspden/4))=irreducible zone data
3626 : : !! istwfk_rbz(nkpt_rbz)=input option parameter that describes the storage of wfs
3627 : : !! kg(3,mpw*mkmem)=reduced planewave coordinates.
3628 : : !! kg1(3,mpw1*mk1mem)=reduced planewave coordinates at k+q, with RF k points
3629 : : !! kpt_rbz(3,nkpt_rbz)=reduced coordinates of k points.
3630 : : !! mband=maximum number of bands
3631 : : !! mband_mem=maximum number of bands on this cpu
3632 : : !! mkmem =number of k points treated by this node (GS data)
3633 : : !! mkqmem =number of k+q points treatede by this node (GS data)
3634 : : !! mk1mem =number of k points treated by this node.
3635 : : !! mpw=maximum dimensioned size of npw or wfs at k
3636 : : !! mpw1=maximum dimensioned size of npw for wfs at k+q (also for 1-order wfs).
3637 : : !! maximum dimension for q points in grids for nonlocal form factors
3638 : : !! natom=number of atoms in cell.
3639 : : !! nband_rbz(nkpt_rbz*nsppol)=number of bands at each RF k point for each spin
3640 : : !! ncpgr=number of gradients stored in cprj array (cprj=<p_i|Cnk>)
3641 : : !! nfftf= -PAW ONLY- number of FFT grid points for the fine grid
3642 : : !! (nfftf=nfft for norm-conserving potential runs - see comment in respfn.F90)
3643 : : !! ngfftf(1:18)=integer array with FFT box dimensions and other for the "fine" grid
3644 : : !! nhatfermi(nfft,nspden)=array for fermi-level compensation charge density (PAW only)
3645 : : !! nkpt_rbz=number of k points in the IBZ for this perturbation
3646 : : !! mpi_enreg=information about MPI parallelization
3647 : : !! my_natom=number of atoms treated by current processor
3648 : : !! npwarr(nkpt_rbz)=number of planewaves in basis at this GS k point
3649 : : !! npwar1(nkpt_rbz)=number of planewaves in basis at this RF k+q point
3650 : : !! nspden=number of spin-density components
3651 : : !! nsppol=1 for unpolarized, 2 for spin-polarized
3652 : : !! nsym1=number of symmetry elements in space group consistent with
3653 : : !! perturbation
3654 : : !! occkq(mband*nkpt_rbz*nsppol)=occupation number for each band (often 2)
3655 : : !! at each k+q point of the reduced Brillouin zone.
3656 : : !! occ_rbz(mband*nkpt_rbz*nsppol)=occupation number for each band and k (usually 2)
3657 : : !! paw_ij(natom*usepaw) <type(paw_ij_type)>=paw arrays given on (i,j) channels for the GS
3658 : : !! pawang <type(pawang_type)>=paw angular mesh and related data
3659 : : !! pawang1 <type(pawang_type)>=pawang datastr. containing only symmetries preserving the perturbation
3660 : : !! pawfgr <type(pawfgr_type)>=fine grid parameters and related data
3661 : : !! pawfgrtab(natom*usepaw) <type(pawfgrtab_type)>=atomic data given on fine rectangular grid for the GS
3662 : : !! pawrad(ntypat*usepaw) <type(pawrad_type)>=paw radial mesh and related data
3663 : : !! pawtab(ntypat*usepaw) <type(pawtab_type)>=paw tabulated starting data
3664 : : !! phnons1(2,nfft**(1-1/nsym1),(nspden/nsppol)-3*(nspden/4))=nonsymmorphic translation phases
3665 : : !! ph1d(2,3*(2*mgfft+1)*natom)=one-dimensional structure factor information
3666 : : !! prtvol=control print volume and debugging output
3667 : : !! psps <type(pseudopotential_type)>=variables related to pseudopotentials
3668 : : !! rmet(3,3)=real space metric (bohr**2)
3669 : : !! rprimd(3,3)=dimensional real space primitive translations
3670 : : !! symaf1(nsym1)=(anti)ferromagnetic part of symmetry operations
3671 : : !! symrc1(3,3,nsym1)=symmetry operations in reciprocal space
3672 : : !! symrl1(3,3,nsym1)=3x3 matrices of the group symmetries
3673 : : !! tnons1(3,nsym1)=non-symmorphic translations
3674 : : !! ucvol=volume of the unit cell
3675 : : !! usecprj= 1 if cprj, cprjq, cprj1 arrays are stored in memory
3676 : : !! useylmgr1= 1 if ylmgr1 array is allocated
3677 : : !! vtrial(nfftf,nspden)=GS potential (Hartree).
3678 : : !! vxc(nfftf,nspden)=XC potential (Hartree).
3679 : : !! wtk_rbz(nkpt_rbz)=weight assigned to each k point.
3680 : : !! xred(3,natom)=reduced dimensionless atomic coordinates
3681 : : !! ylm(mpw*mkmem,mpsang*mpsang*useylm)= real spherical harmonics for each G and k point
3682 : : !! ylm1(mpw1*mk1mem,mpsang*mpsang*useylm)= spherical harmonics for each G and k+g point
3683 : : !! ylmgr1(mpw*mkmem,3,mpsang*mpsang*useylm)= gradients of real spherical harmonics at k+q
3684 : : !!
3685 : : !! OUTPUT
3686 : : !! eigen1(2*mband*mband*nkpt_rbz*nsppol)=array for holding eigenvalues
3687 : : !! (hartree) - only digonal elements computed here
3688 : : !! fe1fixed=fixed contribution to the first-order Fermi energy
3689 : : !! (nonlocal and kinetic in the case of strain)
3690 : : !! nhatfermi(cplex*nfftf,nspden)=fermi-level compensation charge density (PAW only)
3691 : : !! rhorfermi(cplex*nfftf,nspden)=fermi-level electronic density
3692 : : !!
3693 : : !! NOTES
3694 : : !! This routine will NOT work with nspden==4:
3695 : : !! at least the use of fftpac should be modified.
3696 : : !!
3697 : : !! SOURCE
3698 : :
3699 : 192 : subroutine dfpt_rhofermi(cg,cgq,cplex,cprj,cprjq,&
3700 : 192 : & doccde_rbz,docckqde,dtfil,dtset,eigenq,eigen0,eigen1,fe1fixed,gmet,gprimd,idir,&
3701 : 384 : & indsy1,ipert,irrzon1,istwfk_rbz,kg,kg1,kpt_rbz,mband,mband_mem,mkmem,mkqmem,mk1mem,mpi_enreg,&
3702 : 384 : & mpw,mpw1,my_natom,natom,nband_rbz,ncpgr,nfftf,ngfftf,nhatfermi,nkpt_rbz,npwarr,npwar1,nspden,&
3703 : 192 : & nsppol,nsym1,occkq,occ_rbz,paw_ij,pawang,pawang1,pawfgr,pawfgrtab,pawrad,pawrhoijfermi,pawtab,&
3704 : 384 : & phnons1,ph1d,prtvol,psps,rhorfermi,rmet,rprimd,symaf1,symrc1,symrl1,tnons1,&
3705 [ - + ]: 192 : & ucvol,usecprj,useylmgr1,vtrial,vxc,wtk_rbz,xred,ylm,ylm1,ylmgr1, &
3706 : : & eta,omega) !Optional
3707 : :
3708 : : !Arguments -------------------------------
3709 : : !scalars
3710 : : integer,intent(in) :: cplex,idir,ipert,mband,mk1mem,mkmem,mkqmem
3711 : : integer,intent(in) :: mband_mem
3712 : : integer,intent(in) :: mpw,mpw1,my_natom,natom,ncpgr,nfftf,nkpt_rbz,nspden,nsppol,nsym1
3713 : : integer,intent(in) :: prtvol,usecprj,useylmgr1
3714 : : real(dp),intent(in) :: ucvol
3715 : : real(dp),intent(out) :: fe1fixed
3716 : : real(dp),intent(in),optional :: eta,omega
3717 : : type(MPI_type),intent(in) :: mpi_enreg
3718 : : type(datafiles_type),intent(in) :: dtfil
3719 : : type(dataset_type),intent(in) :: dtset
3720 : : type(pawang_type),intent(in) :: pawang,pawang1
3721 : : type(pawfgr_type),intent(in) :: pawfgr
3722 : : type(pseudopotential_type),intent(in) :: psps
3723 : : !arrays
3724 : : integer,intent(in) :: indsy1(4,nsym1,natom)
3725 : : integer,intent(in) :: irrzon1(dtset%nfft**(1-1/nsym1),2,(nspden/nsppol)-3*(nspden/4))
3726 : : integer,intent(in) :: istwfk_rbz(nkpt_rbz),kg(3,mpw*mkmem),kg1(3,mpw1*mk1mem)
3727 : : integer,intent(in) :: nband_rbz(nkpt_rbz*nsppol),ngfftf(18)
3728 : : integer,intent(in) :: npwar1(nkpt_rbz),npwarr(nkpt_rbz),symaf1(nsym1)
3729 : : integer,intent(in) :: symrc1(3,3,nsym1),symrl1(3,3,nsym1)
3730 : : real(dp),intent(in) :: cg(2,mpw*dtset%nspinor*mband_mem*mkmem*nsppol)
3731 : : real(dp),intent(in) :: cgq(2,mpw1*dtset%nspinor*mband_mem*mkqmem*nsppol)
3732 : : real(dp),intent(in) :: doccde_rbz(mband*nkpt_rbz*nsppol)
3733 : : real(dp),intent(in) :: docckqde(mband*nkpt_rbz*nsppol)
3734 : : real(dp),intent(in) :: eigen0(mband*nkpt_rbz*nsppol)
3735 : : real(dp),intent(in) :: eigenq(mband*nkpt_rbz*nsppol),gmet(3,3),gprimd(3,3)
3736 : : real(dp),intent(in) :: kpt_rbz(3,nkpt_rbz)
3737 : : real(dp),intent(in) :: occ_rbz(mband*nkpt_rbz*nsppol),occkq(mband*nkpt_rbz*nsppol)
3738 : : real(dp),intent(in) :: ph1d(2,3*(2*dtset%mgfft+1)*natom)
3739 : : real(dp),intent(in) :: phnons1(2,dtset%nfft**(1-1/nsym1),(nspden/nsppol)-3*(nspden/4))
3740 : : real(dp),intent(in) :: rmet(3,3),rprimd(3,3),tnons1(3,nsym1)
3741 : : real(dp),intent(in) :: vtrial(nfftf,nspden),vxc(nfftf,nspden),wtk_rbz(nkpt_rbz)
3742 : : real(dp),intent(in) :: xred(3,natom),ylm(mpw*mkmem,psps%mpsang*psps%mpsang*psps%useylm)
3743 : : real(dp),intent(in) :: ylm1(mpw1*mk1mem,psps%mpsang*psps%mpsang*psps%useylm)
3744 : : real(dp),intent(in) :: ylmgr1(mpw1*mk1mem,3,psps%mpsang*psps%mpsang*psps%useylm*useylmgr1)
3745 : : real(dp),intent(out) :: eigen1(2*mband*mband*nkpt_rbz*nsppol)
3746 : : real(dp),intent(out) :: nhatfermi(:,:)
3747 : : real(dp),intent(out) :: rhorfermi(cplex*nfftf,nspden)
3748 : : type(pawcprj_type),intent(in) :: cprj (natom,dtset%nspinor*mband_mem*mkmem *nsppol*usecprj)
3749 : : type(pawcprj_type),intent(in) :: cprjq(natom,dtset%nspinor*mband_mem*mkqmem*nsppol*usecprj)
3750 : : type(paw_ij_type),intent(in) :: paw_ij(my_natom*psps%usepaw)
3751 : : type(pawfgrtab_type),intent(inout) :: pawfgrtab(my_natom*psps%usepaw)
3752 : : type(pawrad_type),intent(in) :: pawrad(dtset%ntypat*psps%usepaw)
3753 : : type(pawrhoij_type),target,intent(inout)::pawrhoijfermi(my_natom*psps%usepaw)!vz_i
3754 : : type(pawtab_type), intent(in) :: pawtab(dtset%ntypat*psps%usepaw)
3755 : :
3756 : : !Local variables-------------------------------
3757 : : !scalars
3758 : : integer,parameter :: level=17
3759 : : integer :: bd2tot_index,bdtot_index,buffer_size,cplex_rhoij
3760 : : integer :: dimffnl1,dimffnlk,iatom,iband,ibg,ibgq
3761 : : integer :: icg,icgq,ider,idir0,ierr,ii,ikg,ikg1,ikpt,ilm,ilmn,indx
3762 : : integer :: ispden,isppol,istr,istwf_k
3763 : : integer :: mbd2kpsp,mcgq,mcgq_disk,mcprjq,mcprjq_disk
3764 : : integer :: me,n1,n2,n3,n4,n5,n6,nband_k,nkpg,nkpg1,npw1_k,npw_k,nspden_rhoij
3765 : : integer :: optfr,qphase_rhoij,spaceworld
3766 : : integer :: nband_me
3767 : : logical :: paral_atom,qne0
3768 : : real(dp) :: arg,eta_,fe1norm,invfe1norm,omega_,wtk_k
3769 : 192 : type(gs_hamiltonian_type) :: gs_hamkq
3770 : 192 : type(rf_hamiltonian_type) :: rf_hamkq
3771 : : !arrays
3772 : 192 : integer,allocatable :: kg1_k(:,:),kg_k(:,:)
3773 : : real(dp) :: kpoint(3),kpq(3),tsec(2)
3774 : : real(dp) :: ylmgr_dum(1,1,1)
3775 : 192 : real(dp),allocatable :: buffer1(:),dkinpw(:),doccde_k(:)
3776 : 192 : real(dp),allocatable :: doccde_kq(:),eig0_k(:),eig0_kq(:),eig1_k(:)
3777 : 192 : real(dp),allocatable :: fe1fixed_k(:),fe1norm_k(:)
3778 : 192 : real(dp),allocatable :: ffnl1(:,:,:,:),ffnlk(:,:,:,:)
3779 : 192 : real(dp),allocatable :: kinpw1(:),kpg1_k(:,:),kpg_k(:,:)
3780 : 192 : real(dp),allocatable :: occ_k(:),occ_kq(:),ph3d(:,:,:),ph3d1(:,:,:)
3781 : 192 : real(dp),allocatable :: rhoaug(:,:,:),rhogfermi(:,:),rhowfr(:,:)
3782 : 192 : real(dp),allocatable :: rhoaug4(:,:,:,:)
3783 : 192 : real(dp),allocatable :: rocceig(:,:),ylm1_k(:,:),ylm_k(:,:),ylmgr1_k(:,:,:)
3784 : 192 : type(paw_ij_type),allocatable :: paw_ij1fr(:)
3785 : 192 : type(pawrhoij_type),pointer :: pawrhoijfermi_unsym(:)
3786 : : ! real(dp),allocatable :: vlocal1(:,:,:,:),vlocal_tmp(:,:,:,:)
3787 : : ! real(dp),allocatable :: v1hspinfield(:,:),vtrial_tmp(:,:)
3788 : : ! *********************************************************************
3789 : :
3790 : : DBG_ENTER('COLL')
3791 : : ABI_NVTX_START_RANGE(NVTX_DFPT_RHOFERMI)
3792 : :
3793 : : !Check arguments validity
3794 : : if (ipert>natom.and.ipert/=natom+3.and.ipert/=natom+4.and.ipert/=natom+5.and. &
3795 [ + + + + : 85 : & ipert/=natom+6.and.(ipert>natom+11.and.ipert<2*natom+11)) then
- + - - -
- - - ]
3796 : 0 : ABI_BUG('wrong ipert argument!')
3797 : : end if
3798 [ - + ]: 192 : if (cplex/=1) then
3799 : 0 : ABI_BUG('wrong cplex/=1 argument !')
3800 : : end if
3801 : :
3802 : : !Treat optional arguments
3803 : 192 : eta_=zero; if (present(eta)) eta_=eta
3804 : 192 : omega_=zero; if (present(omega)) omega_=omega
3805 : :
3806 : : !Keep track of total time spent in this routine
3807 : 192 : call timab(121,1,tsec)
3808 : 192 : call timab(124,1,tsec)
3809 : :
3810 : : !Retrieve parallelism data
3811 : 192 : spaceworld=mpi_enreg%comm_cell
3812 : 192 : me=mpi_enreg%me_kpt
3813 : 192 : paral_atom=(my_natom/=dtset%natom)
3814 : :
3815 : : !Initialize output variables
3816 : 192 : fe1fixed=zero
3817 [ + + + + : 331943 : if (psps%usepaw==0) rhorfermi(:,:)=zero
+ + ]
3818 : :
3819 : : !Initialisations/allocation of temporary variables
3820 : 192 : n1=dtset%ngfft(1) ; n2=dtset%ngfft(2) ; n3=dtset%ngfft(3)
3821 : 192 : n4=dtset%ngfft(4) ; n5=dtset%ngfft(5) ; n6=dtset%ngfft(6)
3822 : 192 : bdtot_index=0 ; bd2tot_index=0 ; ibg=0 ; ibgq=0 ; icg=0 ; icgq=0
3823 : 192 : qne0=(dtset%qptn(1)**2+dtset%qptn(2)**2+dtset%qptn(3)**2>=tol14)
3824 : 192 : mbd2kpsp=2*mband**2*nkpt_rbz*nsppol
3825 : 192 : fe1norm=zero
3826 [ + - ]: 192 : if (nspden/=4) then
3827 [ - + + - : 960 : ABI_MALLOC(rhoaug,(cplex*n4,n5,n6))
- + + - -
+ + - + -
+ - - + -
+ ]
3828 : : else
3829 [ # # # # : 0 : ABI_MALLOC(rhoaug4,(cplex*n4,n5,n6,nspden))
# # # # #
# # # # #
# # # # #
# # # #
# ]
3830 : : end if
3831 [ - + + - : 576 : ABI_MALLOC(kg_k,(3,mpw))
+ - + - -
+ - + -
+ ]
3832 [ - + + - : 576 : ABI_MALLOC(kg1_k,(3,mpw1))
+ - + - -
+ - + -
+ ]
3833 [ + + ]: 192 : if (psps%usepaw==1) then
3834 [ - + + - : 460 : ABI_MALLOC(rhowfr,(cplex*dtset%nfft,dtset%nspden))
- + + - +
- + - - +
- + ]
3835 [ + + + + ]: 1046854 : rhowfr(:,:)=zero
3836 : : end if
3837 : :
3838 : 192 : mcgq=mpw1*dtset%nspinor*mband_mem*mkqmem*nsppol;mcgq_disk=0
3839 : :
3840 : : !Prepare RF PAW files for reading and writing if mkmem, mkqmem or mk1mem==0
3841 [ + + ]: 192 : if (psps%usepaw==1) then
3842 : 115 : mcprjq=dtset%nspinor*mband_mem*mkqmem*nsppol*usecprj;mcprjq_disk=0
3843 : : else
3844 : 77 : mcprjq=0;mcprjq_disk=0
3845 : : end if
3846 : :
3847 : : !PAW:has to compute frozen part of Dij^(1) (without Vpsp(1) contribution)
3848 [ + + ]: 192 : if (psps%usepaw==1) then
3849 [ - + + - : 601 : ABI_MALLOC(paw_ij1fr,(my_natom))
+ - + - -
+ - + + +
+ - ]
3850 : 115 : call paw_ij_nullify(paw_ij1fr)
3851 : : call paw_ij_init(paw_ij1fr,cplex,dtset%nspinor,dtset%nsppol,dtset%nspden,0,&
3852 : : & dtset%natom,dtset%ntypat,dtset%typat,pawtab,has_dijfr=1,&
3853 : 115 : & mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom )
3854 : 115 : optfr=1
3855 [ - + ]: 115 : ABI_MALLOC(buffer1,(0))
3856 : : call pawdijfr(gprimd,idir,ipert,my_natom,natom,nfftf,ngfftf,dtset%nspden,dtset%nsppol,&
3857 : : & dtset%ntypat,optfr,paw_ij1fr,pawang,pawfgrtab,pawrad,pawtab,&
3858 : : & cplex,dtset%qptn,rprimd,ucvol,buffer1,vtrial,vxc,xred,&
3859 : 115 : & mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom)
3860 [ - + ]: 115 : ABI_FREE(buffer1)
3861 : : end if
3862 : :
3863 : : !PAW:allocate memory for non-symetrized occupancies matrix at EFermi (pawrhoijfermi)
3864 : 192 : pawrhoijfermi_unsym => pawrhoijfermi
3865 [ + + ]: 192 : if (psps%usepaw==1) then
3866 [ + + ]: 115 : if (paral_atom) then
3867 [ - + + - : 420 : ABI_MALLOC(pawrhoijfermi_unsym,(natom))
+ - + - -
+ - + +
+ ]
3868 : : !Q phase should be 1 because Q=0
3869 : : call pawrhoij_inquire_dim(cplex_rhoij=cplex_rhoij,qphase_rhoij=qphase_rhoij,nspden_rhoij=nspden_rhoij,&
3870 : 60 : & nspden=dtset%nspden,spnorb=dtset%pawspnorb,cplex=cplex,cpxocc=dtset%pawcpxocc)
3871 : : call pawrhoij_alloc(pawrhoijfermi_unsym,cplex_rhoij,nspden_rhoij,dtset%nspinor,&
3872 : 60 : & dtset%nsppol,dtset%typat,qphase=qphase_rhoij,pawtab=pawtab,use_rhoijp=0,use_rhoij_=1)
3873 : : else
3874 : 55 : call pawrhoij_init_unpacked(pawrhoijfermi_unsym)
3875 : : end if
3876 : : end if
3877 : :
3878 : : !Initialize most of the Hamiltonian (arrays and quantities that do not depend on k + nl form factors)
3879 : : call gs_hamkq%init(psps,pawtab,dtset%nspinor,nsppol,nspden,natom,&
3880 : : & dtset%typat,xred,dtset%nfft,dtset%mgfft,dtset%ngfft,rprimd,dtset%nloalg,&
3881 : : & paw_ij=paw_ij,usecprj=usecprj,ph1d=ph1d,gpu_option=dtset%gpu_option,&
3882 : 192 : & mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom,mpi_spintab=mpi_enreg%my_isppoltab)
3883 : : call rf_hamkq%init(cplex,gs_hamkq,ipert,paw_ij1=paw_ij1fr,&
3884 : 192 : & mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom,mpi_spintab=mpi_enreg%my_isppoltab)
3885 : :
3886 : :
3887 : : !LOOP OVER SPINS
3888 [ + + ]: 400 : do isppol=1,nsppol
3889 : 208 : ikg=0;ikg1=0
3890 : : ! Continue to initialize the Hamiltonian at k+q
3891 : 208 : call gs_hamkq%load_spin(isppol,with_nonlocal=.true.)
3892 : 208 : call rf_hamkq%load_spin(isppol,with_nonlocal=.true.)
3893 : :
3894 : : ! Nullify contribution to density at EFermi from this k-point
3895 [ + - ]: 208 : if (nspden/=4) then
3896 [ + + + + : 1626104 : rhoaug(:,:,:)=zero
+ + ]
3897 : : else
3898 [ # # # # : 0 : rhoaug4(:,:,:,:)=zero
# # # # ]
3899 : : end if
3900 : 208 : call timab(125,1,tsec)
3901 : :
3902 : : ! BIG FAT k POINT LOOP
3903 [ + + ]: 4964 : do ikpt=1,nkpt_rbz
3904 : 4756 : nband_k=nband_rbz(ikpt+(isppol-1)*nkpt_rbz)
3905 : 4756 : istwf_k=istwfk_rbz(ikpt)
3906 : 4756 : npw_k=npwarr(ikpt)
3907 : 4756 : npw1_k=npwar1(ikpt)
3908 : 4756 : wtk_k=wtk_rbz(ikpt)
3909 : :
3910 [ + + ]: 4756 : if(proc_distrb_cycle(mpi_enreg%proc_distrb,ikpt,1,nband_k,isppol,me)) then
3911 [ + + ]: 62112 : eigen1(1+bd2tot_index : 2*nband_k**2+bd2tot_index) = zero
3912 : 288 : bdtot_index=bdtot_index+nband_k
3913 : 288 : bd2tot_index=bd2tot_index+2*nband_k**2
3914 : : ! Skip the rest of the k-point loop
3915 : 288 : cycle
3916 : : end if
3917 : :
3918 [ - + + - : 17872 : ABI_MALLOC(ylm_k,(npw_k,psps%mpsang*psps%mpsang*psps%useylm))
+ + + - +
- + + - +
- + - + ]
3919 [ - + + - : 17872 : ABI_MALLOC(ylm1_k,(npw1_k,psps%mpsang*psps%mpsang*psps%useylm))
+ + + - +
- + + - +
- + - + ]
3920 [ - + + - : 17872 : ABI_MALLOC(ylmgr1_k,(npw1_k,3,psps%mpsang*psps%mpsang*psps%useylm*useylmgr1))
+ + + - +
- + + - +
- + - + ]
3921 : :
3922 : : ! Continue to initialize the Hamiltonian at k+q
3923 [ + + ]: 17872 : kpoint(:)=kpt_rbz(:,ikpt)
3924 [ + + ]: 17872 : kpq(:)=kpoint(:)+dtset%qptn(1:3)
3925 : :
3926 [ - + + - : 13404 : ABI_MALLOC(doccde_k,(nband_k))
+ - + - -
+ - + ]
3927 [ - + + - : 8936 : ABI_MALLOC(doccde_kq,(nband_k))
- + - + ]
3928 [ - + + - : 8936 : ABI_MALLOC(eig0_k,(nband_k))
- + - + ]
3929 [ - + + - : 8936 : ABI_MALLOC(eig0_kq,(nband_k))
- + - + ]
3930 [ + - - + : 13404 : ABI_MALLOC(eig1_k,(2*nband_k**2))
+ - + - +
- - + -
+ ]
3931 [ - + + - : 8936 : ABI_MALLOC(fe1fixed_k,(nband_k))
- + - + ]
3932 [ - + + - : 8936 : ABI_MALLOC(fe1norm_k,(nband_k))
- + - + ]
3933 [ - + + - : 8936 : ABI_MALLOC(occ_k,(nband_k))
- + - + ]
3934 [ - + + - : 8936 : ABI_MALLOC(occ_kq,(nband_k))
- + - + ]
3935 [ - + + - : 17872 : ABI_MALLOC(rocceig,(nband_k,nband_k))
- + + - +
- + - - +
- + ]
3936 : :
3937 [ + + ]: 623524 : eig1_k(:)=zero
3938 [ + + ]: 38762 : eig0_k(:)=eigen0(1+bdtot_index:nband_k+bdtot_index)
3939 [ + + ]: 38762 : eig0_kq(:)=eigenq(1+bdtot_index:nband_k+bdtot_index)
3940 [ + + ]: 38762 : occ_k(:)=occ_rbz(1+bdtot_index:nband_k+bdtot_index)
3941 [ + + ]: 38762 : occ_kq(:)=occkq(1+bdtot_index:nband_k+bdtot_index)
3942 [ + + ]: 38762 : doccde_k(:)=doccde_rbz(1+bdtot_index:nband_k+bdtot_index)
3943 [ + + ]: 38762 : doccde_kq(:)=docckqde(1+bdtot_index:nband_k+bdtot_index)
3944 : :
3945 : : ! For each pair of active bands (m,n), generates the ratios
3946 : : ! rocceig(m,n)=(occ_kq(m)-occ_k(n))/(eig0_kq(m)-eig0_k(n))
3947 : : ! and decide to which band to attribute it.
3948 : : call occeig(doccde_k,doccde_kq,eig0_k,eig0_kq,nband_k,&
3949 : 4468 : & dtset%occopt,occ_k,occ_kq,rocceig)
3950 : :
3951 : : ! Get plane-wave coeffs and related data at k
3952 [ + + + + ]: 2068404 : kg_k(:,1:npw_k)=kg(:,1+ikg:npw_k+ikg)
3953 [ + + ]: 4468 : if (psps%useylm==1) then
3954 [ + + ]: 2175 : do ilm=1,psps%mpsang*psps%mpsang
3955 [ + + ]: 651707 : ylm_k(1:npw_k,ilm)=ylm(1+ikg:npw_k+ikg,ilm)
3956 : : end do
3957 : : end if
3958 : :
3959 : : ! Get plane-wave coeffs and related data at k+q
3960 [ + + + + ]: 2068404 : kg1_k(:,1:npw1_k)=kg1(:,1+ikg1:npw1_k+ikg1)
3961 [ + + ]: 4468 : if (psps%useylm==1) then
3962 [ + + ]: 2175 : do ilm=1,psps%mpsang*psps%mpsang
3963 [ + + ]: 651707 : ylm1_k(1:npw1_k,ilm)=ylm1(1+ikg1:npw1_k+ikg1,ilm)
3964 : : end do
3965 [ + + ]: 435 : if (useylmgr1==1) then
3966 [ + + ]: 1350 : do ilm=1,psps%mpsang*psps%mpsang
3967 [ + + ]: 4590 : do ii=1,3
3968 [ + + ]: 1181952 : ylmgr1_k(1:npw1_k,ii,ilm)=ylmgr1(1+ikg1:npw1_k+ikg1,ii,ilm)
3969 : : end do
3970 : : end do
3971 : : end if
3972 : : end if
3973 : :
3974 : : ! Set up the ground-state Hamiltonian, and some parts of the 1st-order Hamiltonian
3975 : :
3976 : : ! Compute (k+G) vectors
3977 [ + - + + ]: 4468 : nkpg=0;if(ipert>=1.and.ipert<=natom) nkpg=3*dtset%nloalg(3)
3978 [ - + + - : 17872 : ABI_MALLOC(kpg_k,(npw_k,nkpg))
+ + + - +
- + + - +
- + - + ]
3979 [ + + ]: 4468 : if (nkpg>0) then
3980 : 165 : call mkkpg(kg_k,kpg_k,kpoint,nkpg,npw_k)
3981 : : end if
3982 : :
3983 : : ! Compute (k+q+G) vectors
3984 [ + - + + ]: 4468 : nkpg1=0;if(ipert>=1.and.ipert<=natom) nkpg1=3*dtset%nloalg(3)
3985 [ - + + - : 17872 : ABI_MALLOC(kpg1_k,(npw1_k,nkpg1))
+ + + - +
- + + - +
- + - + ]
3986 [ + + ]: 4468 : if (nkpg1>0) then
3987 : 165 : call mkkpg(kg1_k,kpg1_k,kpq,nkpg1,npw1_k)
3988 : : end if
3989 : :
3990 : : ! ===== Preparation of non-local contributions
3991 : :
3992 [ + + ]: 4468 : dimffnlk=0;if (ipert<=natom) dimffnlk=1
3993 [ - + + - : 26808 : ABI_MALLOC(ffnlk,(npw_k,dimffnlk,psps%lmnmax,dtset%ntypat))
+ + + - -
+ + - - +
+ - + - +
+ - + - +
- + ]
3994 : :
3995 : : ! Compute nonlocal form factors ffnlk at (k+G)
3996 [ + + ]: 4468 : if (ipert<=natom ) then
3997 : 2693 : ider=0;idir0=0
3998 : : call mkffnl(psps%dimekb,dimffnlk,psps%ekb,ffnlk,psps%ffspl,&
3999 : : & gmet,gprimd,ider,idir0,psps%indlmn,kg_k,kpg_k,kpoint,psps%lmnmax,&
4000 : : & psps%lnmax,psps%mpsang,psps%mqgrid_ff,nkpg,npw_k,dtset%ntypat,&
4001 : 2693 : & psps%pspso,psps%qgrid_ff,rmet,psps%usepaw,psps%useylm,ylm_k,ylmgr_dum)
4002 : : end if
4003 : :
4004 : : ! Compute nonlocal form factors ffnl1 at (k+q+G)
4005 : : !-- Atomic displacement perturbation
4006 [ + + ]: 4468 : if (ipert<=natom) then
4007 : 2693 : ider=0;idir0=0
4008 : : !-- Strain perturbation
4009 [ + + + + ]: 1775 : else if (ipert==natom+3.or.ipert==natom+4) then
4010 [ + + ]: 1743 : if (ipert==natom+3) istr=idir
4011 [ + + ]: 1743 : if (ipert==natom+4) istr=idir+3
4012 : 1743 : ider=1;idir0=-istr
4013 [ - + - - : 32 : else if (ipert==natom+5.or.ipert==natom+6.or.(ipert>natom+11.and.ipert<=2*natom+11)) then !SPr deb rfmagn
- - - - ]
4014 : 32 : ider=0;idir0=0
4015 : : end if
4016 [ + + - + ]: 4468 : dimffnl1=1+ider;if (ider==1.and.idir0==0) dimffnl1=dimffnl1+2*psps%useylm
4017 [ - + + - : 26808 : ABI_MALLOC(ffnl1,(npw1_k,dimffnl1,psps%lmnmax,dtset%ntypat))
- + + - -
+ + - - +
+ - + - +
- - + - +
- + ]
4018 : : call mkffnl(psps%dimekb,dimffnl1,psps%ekb,ffnl1,psps%ffspl,gmet,gprimd,ider,idir0,&
4019 : : & psps%indlmn,kg1_k,kpg1_k,kpq,psps%lmnmax,psps%lnmax,psps%mpsang,psps%mqgrid_ff,nkpg1,&
4020 : 4468 : & npw1_k,dtset%ntypat,psps%pspso,psps%qgrid_ff,rmet,psps%usepaw,psps%useylm,ylm1_k,ylmgr1_k)
4021 : :
4022 : : ! ===== Preparation of kinetic contributions
4023 : :
4024 [ - + + - : 13404 : ABI_MALLOC(dkinpw,(npw_k))
+ - + - -
+ - + -
+ ]
4025 [ - + + - : 13404 : ABI_MALLOC(kinpw1,(npw1_k))
+ - + - -
+ - + -
+ ]
4026 : :
4027 : : ! Compute the derivative of the kinetic operator vs strain in dkinpw
4028 [ + + + + ]: 4468 : if (ipert==natom+3.or.ipert==natom+4) then
4029 [ + + ]: 1743 : if (ipert==natom+3) istr=idir
4030 [ + + ]: 1743 : if (ipert==natom+4) istr=idir+3
4031 : : call kpgstr(dkinpw,dtset%ecut,dtset%ecutsm,dtset%effmass_free,gmet,gprimd,istr,&
4032 : 1743 : & kg_k,kpoint,npw_k)
4033 : : end if
4034 : :
4035 : : ! Compute (1/2) (2 Pi)**2 (k+q+G)**2:
4036 : : ! call mkkin(dtset%ecut,dtset%ecutsm,dtset%effmass_free,gmet,kg1_k,kinpw1,kpq,npw1_k)
4037 : 4468 : call mkkin(dtset%ecut,dtset%ecutsm,dtset%effmass_free,gmet,kg1_k,kinpw1,kpq,npw1_k,0,0)
4038 : :
4039 : : ! ===== Load the k/k+q dependent parts of the Hamiltonian
4040 : :
4041 : : ! Load k-dependent part in the Hamiltonian datastructure
4042 [ - + + - : 17872 : ABI_MALLOC(ph3d,(2,npw_k,gs_hamkq%matblk))
- + + - +
- + - - +
- + - + ]
4043 : : call gs_hamkq%load_k(kpt_k=kpoint,npw_k=npw_k,istwf_k=istwf_k,kg_k=kg_k,kpg_k=kpg_k,&
4044 : 4468 : & ph3d_k=ph3d,compute_ph3d=.true.,compute_gbound=.true.)
4045 [ + + + + ]: 22340 : if (size(ffnlk)>0) then
4046 : 2693 : call gs_hamkq%load_k(ffnl_k=ffnlk)
4047 : : else
4048 : 1775 : call gs_hamkq%load_k(ffnl_k=ffnl1)
4049 : : end if
4050 : :
4051 : : ! Load k+q-dependent part in the Hamiltonian datastructure
4052 : : ! Note: istwf_k is imposed to 1 for RF calculations (should use istwf_kq instead)
4053 : : call gs_hamkq%load_kprime(kpt_kp=kpq,npw_kp=npw1_k,istwf_kp=istwf_k,&
4054 : : & kinpw_kp=kinpw1,kg_kp=kg1_k,kpg_kp=kpg1_k,ffnl_kp=ffnl1,&
4055 : 4468 : & compute_gbound=.true.)
4056 [ - + ]: 4468 : if (qne0) then
4057 [ # # # # : 0 : ABI_MALLOC(ph3d1,(2,npw1_k,gs_hamkq%matblk))
# # # # #
# # # # #
# # # # ]
4058 : 0 : call gs_hamkq%load_kprime(ph3d_kp=ph3d1,compute_ph3d=.true.)
4059 : : end if
4060 : :
4061 : : ! Load k-dependent part in the 1st-order Hamiltonian datastructure
4062 : 4468 : call rf_hamkq%load_k(npw_k=npw_k,dkinpw_k=dkinpw)
4063 : :
4064 : : ! Compute fixed contributions to 1st-order Fermi energy
4065 : : ! and Fermi level charge density
4066 [ + + + + ]: 73056 : fe1fixed_k(:)=zero ; fe1norm_k(:)=zero
4067 : :
4068 : : ! Note that dfpt_wfkfermi is called with kpoint, while kpt is used inside dfpt_wfkfermi
4069 [ + - ]: 4468 : if (nspden/=4) then
4070 : : call dfpt_wfkfermi(cg,cgq,cplex,cprj,cprjq,dtfil,eig0_k,eig1_k,fe1fixed_k,&
4071 : : & fe1norm_k,gs_hamkq,ibg,ibgq,icg,icgq,idir,ikpt,ipert,isppol,dtset%kptopt,mband_mem,&
4072 : : & mcgq,mcprjq,mkmem,mpi_enreg,mpw,nband_k,ncpgr,npw_k,npw1_k,dtset%nspinor,nsppol,occ_k,&
4073 [ - + ]: 4468 : & pawrhoijfermi_unsym,prtvol,rf_hamkq,rhoaug,rocceig,wtk_k)
4074 : : else
4075 : : call dfpt_wfkfermi(cg,cgq,cplex,cprj,cprjq,dtfil,eig0_k,eig1_k,fe1fixed_k,&
4076 : : & fe1norm_k,gs_hamkq,ibg,ibgq,icg,icgq,idir,ikpt,ipert,isppol,dtset%kptopt,mband_mem,&
4077 : : & mcgq,mcprjq,mkmem,mpi_enreg,mpw,nband_k,ncpgr,npw_k,npw1_k,dtset%nspinor,nsppol,occ_k,&
4078 [ # # ]: 0 : & pawrhoijfermi_unsym,prtvol,rf_hamkq,rhoaug4,rocceig,wtk_k)
4079 : : end if
4080 : : ! Free temporary storage
4081 [ - + ]: 4468 : ABI_FREE(kpg_k)
4082 [ - + ]: 4468 : ABI_FREE(kpg1_k)
4083 [ - + ]: 4468 : ABI_FREE(dkinpw)
4084 [ - + ]: 4468 : ABI_FREE(ffnlk)
4085 [ - + ]: 4468 : ABI_FREE(ffnl1)
4086 [ - + ]: 4468 : ABI_FREE(kinpw1)
4087 [ - + ]: 4468 : ABI_FREE(doccde_k)
4088 [ - + ]: 4468 : ABI_FREE(doccde_kq)
4089 [ - + ]: 4468 : ABI_FREE(eig0_k)
4090 [ - + ]: 4468 : ABI_FREE(eig0_kq)
4091 [ - + ]: 4468 : ABI_FREE(occ_kq)
4092 [ - + ]: 4468 : ABI_FREE(rocceig)
4093 [ - + ]: 4468 : ABI_FREE(ylm_k)
4094 [ - + ]: 4468 : ABI_FREE(ylm1_k)
4095 [ - + ]: 4468 : ABI_FREE(ylmgr1_k)
4096 [ - + ]: 4468 : ABI_FREE(ph3d)
4097 [ - + ]: 4468 : ABI_SFREE(ph3d1)
4098 : :
4099 : : ! Save eigenvalues (hartree)
4100 [ + + ]: 623524 : eigen1 (1+bd2tot_index : 2*nband_k**2+bd2tot_index) = eig1_k(:)
4101 : :
4102 : : ! Accumulate sum over k points for 1st-order Fermi energy components
4103 [ + + ]: 38762 : do iband=1,nband_k
4104 : 34294 : fe1fixed=fe1fixed+wtk_k*occ_k(iband)*fe1fixed_k(iband)
4105 : 38762 : fe1norm=fe1norm+wtk_k*occ_k(iband)*fe1norm_k(iband)
4106 : : end do
4107 : :
4108 [ - + ]: 4468 : ABI_FREE(eig1_k)
4109 [ - + ]: 4468 : ABI_FREE(occ_k)
4110 [ - + ]: 4468 : ABI_FREE(fe1fixed_k)
4111 [ - + ]: 4468 : ABI_FREE(fe1norm_k)
4112 : :
4113 : : ! Keep track of total number of bands
4114 : : ! (all k points so far, even for k points not treated by me)
4115 : 4468 : bdtot_index=bdtot_index+nband_k
4116 : 4468 : bd2tot_index=bd2tot_index+2*nband_k**2
4117 : :
4118 : 4468 : nband_me = proc_distrb_nband(mpi_enreg%proc_distrb,ikpt,nband_k,isppol,me)
4119 : : ! Shift array memory
4120 [ + - ]: 4468 : if (mkmem/=0) then
4121 : 4468 : ibg=ibg+nband_me
4122 : 4468 : icg=icg+npw_k*dtset%nspinor*nband_me
4123 : 4468 : ikg=ikg+npw_k
4124 : : end if
4125 [ + - ]: 4468 : if (mkqmem/=0) then
4126 : 4468 : ibgq=ibgq+dtset%nspinor*nband_me
4127 : 4468 : icgq=icgq+npw1_k*dtset%nspinor*nband_me
4128 : : end if
4129 [ + - ]: 4676 : if (mk1mem/=0) then
4130 : 4468 : ikg1=ikg1+npw1_k
4131 : : end if
4132 : :
4133 : : ! End big k point loop
4134 : : end do
4135 : :
4136 : 208 : call timab(125,2,tsec)
4137 : :
4138 : : ! Transfer density on augmented fft grid to normal fft grid in real space
4139 : : ! Also take into account the spin.
4140 [ + - ]: 400 : if (nspden/=4) then
4141 [ + + ]: 208 : if (psps%usepaw==0) then
4142 : 93 : call fftpac(isppol,mpi_enreg,nspden,cplex*n1,n2,n3,cplex*n4,n5,n6,dtset%ngfft,rhorfermi,rhoaug,1)
4143 : : else
4144 : 115 : call fftpac(isppol,mpi_enreg,nspden,cplex*n1,n2,n3,cplex*n4,n5,n6,dtset%ngfft,rhowfr ,rhoaug,1)
4145 : : end if
4146 : : else
4147 [ # # ]: 0 : if (psps%usepaw==0) then
4148 [ # # ]: 0 : do ispden=1,4
4149 : 0 : call fftpac(ispden,mpi_enreg,nspden,cplex*n1,n2,n3,cplex*n4,n5,n6,dtset%ngfft,rhorfermi,rhoaug4(:,:,:,ispden),1)
4150 : : end do
4151 : : end if
4152 : : end if
4153 : :
4154 : : end do ! End loop over spins
4155 : :
4156 : : !More memory cleaning
4157 : 192 : call gs_hamkq%free()
4158 : 192 : call rf_hamkq%free()
4159 [ + + ]: 192 : if(psps%usepaw==1) then
4160 : 115 : call paw_ij_free(paw_ij1fr)
4161 [ + - + + : 371 : ABI_FREE(paw_ij1fr)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + ]
4162 : : end if
4163 [ + - ]: 192 : if (nspden/=4) then
4164 [ - + ]: 192 : ABI_FREE(rhoaug)
4165 : : else
4166 [ # # ]: 0 : ABI_FREE(rhoaug4)
4167 : : end if
4168 [ - + ]: 192 : ABI_FREE(kg_k)
4169 [ - + ]: 192 : ABI_FREE(kg1_k)
4170 : :
4171 : 192 : call timab(124,2,tsec)
4172 : :
4173 : : !=== MPI communications ==================
4174 : : if(xmpi_paral==1)then
4175 : 192 : call timab(129,1,tsec)
4176 : :
4177 : : ! Identify MPI buffer size
4178 : 192 : buffer_size=2
4179 [ - + - + ]: 192 : ABI_MALLOC(buffer1,(buffer_size))
4180 : :
4181 : : ! Pack fe1fixed, fe1norm
4182 : 192 : indx = 0
4183 : 192 : buffer1(indx+1)=fe1fixed
4184 : 192 : buffer1(indx+2)=fe1norm
4185 : 192 : indx=indx+2
4186 : : if(indx<buffer_size)buffer1(indx+1:buffer_size)=zero
4187 : :
4188 : : ! Build sum of everything
4189 : 192 : call timab(48,1,tsec)
4190 : 192 : call xmpi_sum(buffer1,buffer_size,spaceworld,ierr)
4191 : 192 : call timab(48,2,tsec)
4192 : :
4193 : : ! Unpack the final result
4194 : 192 : indx=0
4195 : 192 : fe1fixed=buffer1(indx+1) ; fe1norm =buffer1(indx+2)
4196 : 192 : ABI_FREE(buffer1)
4197 : :
4198 : 192 : call timab(48,1,tsec)
4199 : 192 : buffer_size=mbd2kpsp
4200 : 192 : call xmpi_sum(eigen1,buffer_size,spaceworld,ierr)
4201 : 192 : call timab(48,2,tsec)
4202 : :
4203 [ + + ]: 192 : if (psps%usepaw==0) then
4204 : 77 : call timab(48,1,tsec)
4205 : 77 : buffer_size = cplex*nfftf
4206 : : ! TODO: there should be a primitive for a 2d array here, but the compiler does not seem to find it.
4207 : : ! would simplify the call to xmpi_sum
4208 [ + + ]: 170 : do isppol=1, nspden
4209 : 170 : call xmpi_sum(rhorfermi(:,isppol),buffer_size,spaceworld,ierr)
4210 : : end do
4211 : 77 : call timab(48,2,tsec)
4212 : : else
4213 : 115 : call timab(48,1,tsec)
4214 : 115 : buffer_size = cplex*dtset%nfft
4215 [ + + ]: 230 : do isppol=1, nspden
4216 : 230 : call xmpi_sum(rhowfr(:,isppol),buffer_size,spaceworld,ierr)
4217 : : end do
4218 : 115 : call timab(48,2,tsec)
4219 : : end if
4220 : :
4221 : : ! Accumulate PAW occupancies
4222 [ + + ]: 192 : if (psps%usepaw==1) then
4223 : 115 : call pawrhoij_mpisum_unpacked(pawrhoijfermi_unsym,spaceworld)
4224 : : end if
4225 : :
4226 : 384 : call timab(129,2,tsec)
4227 : : end if ! if kpt parallel
4228 : : !=== End communications ==================
4229 : :
4230 : 192 : call timab(127,1,tsec)
4231 : :
4232 : : !Normalize the fixed part of fermie1
4233 [ + + ]: 192 : invfe1norm = zero ; if (abs(fe1norm) > tol10) invfe1norm=one/fe1norm
4234 : 192 : fe1fixed=fe1fixed*invfe1norm
4235 : :
4236 : :
4237 [ - + ]: 192 : if(nspden==4) then
4238 : : ! FR SPr symrhg will manage correctly this rearrangement
4239 [ # # ]: 0 : rhorfermi(:,2)=rhorfermi(:,2)+(rhorfermi(:,1)+rhorfermi(:,4)) !(n+mx)
4240 [ # # ]: 0 : rhorfermi(:,3)=rhorfermi(:,3)+(rhorfermi(:,1)+rhorfermi(:,4)) !(n+my)
4241 : 0 : call timab(17,2,tsec)
4242 : : end if
4243 : :
4244 : : !Symmetrize the density
4245 : : !In order to have the symrhg working in parallel on FFT coefficients, the size
4246 : : !of irzzon1 and phnons1 should be set to nfftot. Therefore, nsym\=1 does not work.
4247 : : !We also have the spin-up density, symmetrized, in rhorfermi(:,2).
4248 [ - + + - : 576 : ABI_MALLOC(rhogfermi,(2,dtset%nfft))
+ - + - -
+ - + ]
4249 [ + + ]: 192 : if (psps%usepaw==0) then
4250 : : call symrhg(cplex,gprimd,irrzon1,mpi_enreg,dtset%nfft,dtset%nfft,dtset%ngfft,nspden,&
4251 : 77 : & nsppol,nsym1,phnons1,rhogfermi,rhorfermi,rprimd,symaf1,symrl1,tnons1)
4252 : : else
4253 : : call symrhg(cplex,gprimd,irrzon1,mpi_enreg,dtset%nfft,dtset%nfft,dtset%ngfft,nspden,&
4254 : 115 : & nsppol,nsym1,phnons1,rhogfermi,rhowfr,rprimd,symaf1,symrl1,tnons1)
4255 : : end if
4256 : :
4257 : : !PAW: Build new rhoij quantities then symetrize them
4258 : : !Compute and add the compensation density to rhowfr to get the total density
4259 [ + + ]: 192 : if (psps%usepaw == 1) then
4260 [ + + + + ]: 345 : if (size(nhatfermi)>0) then
4261 : : call pawmkrho(1,arg,cplex,gprimd,0,indsy1,0,mpi_enreg,&
4262 : : & my_natom,natom,nspden,nsym1,dtset%ntypat,dtset%paral_kgb,pawang,pawfgr,&
4263 : : & pawfgrtab,-10001,pawrhoijfermi,pawrhoijfermi_unsym,pawtab,dtset%qptn,&
4264 : : & rhogfermi,rhowfr,rhorfermi,rprimd,symaf1,symrc1,dtset%typat,ucvol,&
4265 [ - + - - : 17 : & dtset%usewvl,xred,pawang_sym=pawang1,pawnhat=nhatfermi)
- - - - -
+ - - -
- ]
4266 : : else
4267 : : call pawmkrho(1,arg,cplex,gprimd,0,indsy1,0,mpi_enreg,&
4268 : : & my_natom,natom,nspden,nsym1,dtset%ntypat,dtset%paral_kgb,pawang,pawfgr,&
4269 : : & pawfgrtab,-10001,pawrhoijfermi,pawrhoijfermi_unsym,pawtab,dtset%qptn,&
4270 : : & rhogfermi,rhowfr,rhorfermi,rprimd,symaf1,symrc1,dtset%typat,ucvol,&
4271 : 98 : & dtset%usewvl,xred,pawang_sym=pawang1)
4272 : : end if
4273 [ - + ]: 115 : ABI_FREE(rhowfr)
4274 : 115 : call pawrhoij_free_unpacked(pawrhoijfermi_unsym)
4275 [ + + ]: 115 : if (paral_atom) then
4276 : 60 : call pawrhoij_free(pawrhoijfermi_unsym)
4277 [ - + ]: 60 : ABI_FREE(pawrhoijfermi_unsym)
4278 : : end if
4279 : : end if
4280 [ - + ]: 192 : ABI_FREE(rhogfermi)
4281 : :
4282 : : !Normalize the Fermi level charge density (and associated PAW occupancies)
4283 [ + + + + ]: 1447914 : rhorfermi(:,:)=invfe1norm*rhorfermi(:,:)
4284 [ + + ]: 192 : if (psps%usepaw==1) then
4285 [ + + + + : 138386 : if (size(nhatfermi)>0) nhatfermi(:,:)=invfe1norm*nhatfermi(:,:)
+ + + + ]
4286 [ + + ]: 371 : do iatom=1,my_natom
4287 [ + + ]: 627 : do ispden=1,nspden
4288 [ + + ]: 692 : do ilmn=1,pawrhoijfermi(iatom)%nrhoijsel
4289 : : pawrhoijfermi(iatom)%rhoijp(ilmn,ispden)=&
4290 : 436 : & pawrhoijfermi(iatom)%rhoijp(ilmn,ispden)*invfe1norm
4291 : : end do
4292 : : end do
4293 : : end do
4294 : : end if
4295 : :
4296 : 192 : call timab(127,2,tsec)
4297 : 192 : call timab(121,2,tsec)
4298 : :
4299 : : ABI_NVTX_END_RANGE()
4300 : : DBG_EXIT('COLL')
4301 : :
4302 [ + + - + : 384 : end subroutine dfpt_rhofermi
- + - + -
+ - + - +
- + - + -
+ - + - +
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + ]
4303 : : !!***
4304 : :
4305 : : !!****f* ABINIT/dfpt_wfkfermi
4306 : : !! NAME
4307 : : !! dfpt_wfkfermi
4308 : : !!
4309 : : !! FUNCTION
4310 : : !! This routine computes the partial Fermi-level density at a given k-point,
4311 : : !! and the fixed contribution to the 1st-order Fermi energy (nonlocal and kinetic)
4312 : : !!
4313 : : !! INPUTS
4314 : : !! cg(2,mpw*nspinor*mband_mem*mkmem*nsppol)=planewave coefficients of wavefunctions
4315 : : !! cgq(2,mcgq)=array for planewave coefficients of wavefunctions.
4316 : : !! cplex=1 if rhoaug is real, 2 if rhoaug is complex
4317 : : !! cprj(natom,nspinor*mband_mem*mkmem*nsppol*usecprj)= wave functions at k
4318 : : !! projected with non-local projectors: cprj=<p_i|Cnk>
4319 : : !! cprjq(natom,nspinor*mband_mem*mkqmem*nsppol*usecprj)= wave functions at k+q
4320 : : !! projected with non-local projectors: cprjq=<p_i|Cnk+q>
4321 : : !! dtfil <type(datafiles_type)>=variables related to files
4322 : : !! eig0_k(nband_k)=GS eigenvalues at k (hartree)
4323 : : !! gs_hamkq <type(gs_hamiltonian_type)>=all data for the Hamiltonian at k+q
4324 : : !! ibg=shift to be applied on the location of data in the array cprj
4325 : : !! ibgq=shift to be applied on the location of data in the array cprjq
4326 : : !! icg=shift to be applied on the location of data in the array cg
4327 : : !! icgq=shift to be applied on the location of data in the array cgq
4328 : : !! idir=direction of the current perturbation
4329 : : !! ikpt=number of the k-point
4330 : : !! ipert=type of the perturbation
4331 : : !! isppol=1 for unpolarized, 2 for spin-polarized
4332 : : !! kptopt=option for the generation of k points
4333 : : !! mband_mem=maximum number of bands on this cpu
4334 : : !! mcgq=second dimension of the cgq array
4335 : : !! mcprjq=second dimension of the cprjq array
4336 : : !! mkmem =number of k points treated by this node.
4337 : : !! mpi_enreg=information about MPI parallelization
4338 : : !! mpw=maximum dimensioned size of npw or wfs at k
4339 : : !! nband_k=number of bands at this k point for that spin polarization
4340 : : !! ncpgr=number of gradients stored in cprj array (cprj=<p_i|Cnk>)
4341 : : !! npw_k=number of plane waves at this k point
4342 : : !! npw1_k=number of plane waves at this k+q point
4343 : : !! nspinor=number of spinorial components of the wavefunctions
4344 : : !! nsppol=1 for unpolarized, 2 for spin-polarized
4345 : : !! occ_k(nband_k)=occupation number for each band (usually 2) for each k.
4346 : : !! prtvol=control print volume and debugging output
4347 : : !! rf_hamkq <type(gs_hamiltonian_type)>=all data for the 1st-order Hamiltonian at k,q
4348 : : !! rhoaug(cplex*n4,n5,n6)= density in electrons/bohr**3,
4349 : : !! on the augmented fft grid. (cumulative, so input as well as output)
4350 : : !! rocceig(nband_k,nband_k)= (occ_kq(m)-occ_k(n))/(eig0_kq(m)-eig0_k(n)),
4351 : : !! if this ratio has been attributed to the band n (second argument), zero otherwise
4352 : : !! wtk_k=weight assigned to the k point.
4353 : : !!
4354 : : !! OUTPUT
4355 : : !! eig1_k(2*nband_k**2)=first-order eigenvalues (hartree)
4356 : : !! fe1fixed_k(nband_k)=contribution to 1st-order Fermi energy
4357 : : !! from changes of occupation from all bands at this k point.
4358 : : !! fe1norm_k(nband_k)=contribution to normalization for above
4359 : : !! rhoaug(cplex*n4,n5,n6)= Fermi-level density in electrons/bohr**3,
4360 : : !! on the augmented fft grid. (cumulative, so input as well as output).
4361 : : !! ==== if (gs_hamkq%usepaw==1) ====
4362 : : !! pawrhoijfermi(natom) <type(pawrhoij_type)>= paw rhoij occupancies
4363 : : !! at Fermi level (cumulative, so input as well as output)
4364 : : !!
4365 : : !! SOURCE
4366 : :
4367 : 4468 : subroutine dfpt_wfkfermi(cg,cgq,cplex,cprj,cprjq,&
4368 : 4468 : & dtfil,eig0_k,eig1_k,fe1fixed_k,fe1norm_k,gs_hamkq,&
4369 : : & ibg,ibgq,icg,icgq,idir,ikpt,ipert,isppol,&
4370 : : & kptopt,mband_mem,mcgq,mcprjq,mkmem,mpi_enreg,mpw,nband_k,ncpgr,&
4371 : 4468 : & npw_k,npw1_k,nspinor,nsppol,occ_k,pawrhoijfermi,prtvol,&
4372 : 4468 : & rf_hamkq,rhoaug,rocceig,wtk_k)
4373 : :
4374 : : !Arguments ------------------------------------
4375 : : !scalars
4376 : : integer,intent(in) :: cplex,ibg,ibgq,icg,icgq,idir,ikpt
4377 : : integer,intent(in) :: ipert,isppol,kptopt,mcgq,mcprjq,mkmem,mpw,ncpgr
4378 : : integer,intent(in) :: mband_mem
4379 : : integer,intent(in) :: npw1_k,nspinor,nsppol,prtvol
4380 : : integer,intent(inout) :: nband_k,npw_k
4381 : : real(dp),intent(in) :: wtk_k
4382 : : type(MPI_type),intent(in) :: mpi_enreg
4383 : : type(datafiles_type),intent(in) :: dtfil
4384 : : type(gs_hamiltonian_type),intent(inout) :: gs_hamkq
4385 : : type(rf_hamiltonian_type),intent(inout) :: rf_hamkq
4386 : : !arrays
4387 : : real(dp),intent(in) :: cg(2,mpw*nspinor*mband_mem*mkmem*nsppol),cgq(2,mcgq)
4388 : : real(dp),intent(in) :: eig0_k(nband_k),occ_k(nband_k),rocceig(nband_k,nband_k)
4389 : : real(dp),intent(inout) :: rhoaug(cplex*gs_hamkq%n4,gs_hamkq%n5,gs_hamkq%n6,gs_hamkq%nvloc)
4390 : : real(dp),intent(inout) :: eig1_k(2*nband_k**2)
4391 : : real(dp),intent(out) :: fe1fixed_k(nband_k)
4392 : : real(dp),intent(out) :: fe1norm_k(nband_k)
4393 : : !TODO distribute cprj over bands
4394 : : type(pawcprj_type),intent(in) :: cprj(gs_hamkq%natom,nspinor*mband_mem*mkmem*nsppol*gs_hamkq%usecprj)
4395 : : type(pawcprj_type),intent(in) :: cprjq(gs_hamkq%natom,mcprjq)
4396 : : type(pawrhoij_type),intent(inout) :: pawrhoijfermi(gs_hamkq%natom*gs_hamkq%usepaw)
4397 : :
4398 : : !Local variables-------------------------------
4399 : : !scalars
4400 : : integer,parameter :: level=18
4401 : : integer :: berryopt,iband,ii,indx,iorder_cprj
4402 : : integer :: iband_me, nband_me
4403 : : integer :: ipw,me,nkpt_max,optlocal,optnl,opt_accrho,opt_corr
4404 : : integer :: opt_gvnlx1,sij_opt,tim_fourwf,tim_getgh1c,usevnl
4405 : : real(dp) :: dotr(1),lambda,wtband
4406 : : character(len=500) :: msg
4407 : : !arrays
4408 : : real(dp) :: dum_grad_berry(1,1),dum_gvnlx1(1,1),dum_gs1(1,1),tsec(2)
4409 : 4468 : real(dp),allocatable :: cwave0(:,:),cwaveq(:,:),gh1(:,:)
4410 : 4468 : type(pawcprj_type),allocatable :: cwaveprj0(:,:),cwaveprjq(:,:),cwaveprj_tmp(:,:)
4411 : : ! *********************************************************************
4412 : :
4413 : : DBG_ENTER('COLL')
4414 : : ABI_NVTX_START_RANGE(NVTX_DFPT_WFKFERMI)
4415 : :
4416 : : !Check arguments validity
4417 : : if (ipert>gs_hamkq%natom.and.ipert/=gs_hamkq%natom+3.and.ipert/=gs_hamkq%natom+4 &
4418 [ + + + + : 4468 : & .and.ipert/=gs_hamkq%natom+5.and.ipert/=gs_hamkq%natom+6 .and. &
+ + - + -
- - - -
- ]
4419 : : & (ipert>gs_hamkq%natom+11.and.ipert<=2*gs_hamkq%natom+11)) then !SPr rfmagn deb
4420 : 0 : ABI_BUG('wrong ipert argument !')
4421 : : end if
4422 [ - + ]: 4468 : if (cplex/=1) then
4423 : 0 : ABI_BUG('wrong cplex/=1 argument !')
4424 : : end if
4425 : :
4426 : : !Debugging statements
4427 [ - + ]: 4468 : if(prtvol==-level)then
4428 [ # # # # ]: 0 : write(msg,'(80a,a,a)') ('=',ii=1,80),ch10,'dfpt_wfkfermi : enter'
4429 : 0 : call wrtout(std_out,msg,'PERS')
4430 : : end if
4431 : 4468 : nkpt_max=50;if(xmpi_paral==1)nkpt_max=-1
4432 : :
4433 [ + + - + ]: 4468 : if(prtvol>2 .or. ikpt<=nkpt_max)then
4434 : 443 : write(msg, '(a,a,i5,2x,a,3f9.5,2x,a)' ) ch10,&
4435 : 886 : & ' Non-SCF iterations; k pt #',ikpt,'k=',gs_hamkq%kpt_k(:),' band residuals:'
4436 : 443 : call wrtout(std_out,msg,'PERS')
4437 : : end if
4438 : :
4439 : : !Retrieve parallelism data
4440 : 4468 : me=mpi_enreg%me_kpt
4441 : : !Initializations and allocations
4442 : :
4443 [ - + + - : 13404 : ABI_MALLOC(gh1,(2,npw1_k*nspinor))
+ - + - -
+ - + ]
4444 [ - + + - : 13404 : ABI_MALLOC(cwave0,(2,npw_k*nspinor))
+ - + - -
+ - + ]
4445 [ - + + - : 8936 : ABI_MALLOC(cwaveq,(2,npw1_k*nspinor))
- + - + ]
4446 [ + + ]: 623524 : iorder_cprj=0 ; eig1_k(:)=zero
4447 [ + + ]: 4468 : if (gs_hamkq%usepaw==1.and.gs_hamkq%usecprj==1) then
4448 [ - + + - : 3691 : ABI_MALLOC(cwaveprj0,(gs_hamkq%natom,nspinor))
- + + - +
- + - - +
- + - + +
+ + + ]
4449 [ - + + - : 3691 : ABI_MALLOC(cwaveprjq,(gs_hamkq%natom,nspinor))
- + + - +
- + - - +
- + + + +
+ ]
4450 : 435 : call pawcprj_alloc(cwaveprj0,1,gs_hamkq%dimcprj)
4451 : 435 : call pawcprj_alloc(cwaveprjq,0,gs_hamkq%dimcprj)
4452 : : else
4453 [ - + - + ]: 4033 : ABI_MALLOC(cwaveprj0,(0,0))
4454 [ - + ]: 4033 : ABI_MALLOC(cwaveprjq,(0,0))
4455 : : end if
4456 : : !Arguments of getgh1c routine (want only (NL+kin) frozen H(1))
4457 : 4468 : berryopt=0;usevnl=0;sij_opt=-gs_hamkq%usepaw;tim_getgh1c=3
4458 : 4468 : optlocal=0;optnl=1;opt_gvnlx1=0
4459 [ + + ]: 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
4460 [ - + ]: 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
4461 [ - + - - ]: 4468 : if(ipert>gs_hamkq%natom+11.and.ipert<=2*gs_hamkq%natom+11) optnl=0;
4462 : : !if(ipert==gs_hamkq%natom+5) optlocal=0; ! 1st order LOCAL potential present
4463 : :
4464 : : !Arguments of the dfpt_accrho routine
4465 : 4468 : tim_fourwf=5 ; opt_accrho=1 ; opt_corr=0
4466 : : !Null potentially unassigned output variables
4467 [ + + + + ]: 73056 : fe1fixed_k(:)=zero; fe1norm_k(:)=zero
4468 : :
4469 : : !Read the npw and kg records of wf files
4470 : 4468 : call timab(139,1,tsec)
4471 : :
4472 : : !Loop over bands
4473 : 4468 : iband_me = 0
4474 : 4468 : nband_me = proc_distrb_nband(mpi_enreg%proc_distrb,ikpt,nband_k,isppol,me)
4475 [ + + ]: 38762 : do iband=1,nband_k
4476 : :
4477 : : ! Skip bands not treated by current proc
4478 [ + - ]: 34294 : if(mpi_enreg%proc_distrb(ikpt, iband,isppol)/=me) cycle
4479 : 34294 : iband_me = iband_me + 1
4480 : :
4481 : : ! Select occupied bands
4482 [ + + + + ]: 38762 : if(abs(occ_k(iband))>tol8.and.abs(rocceig(iband,iband))>tol8)then
4483 : :
4484 : 6938 : wtband=rocceig(iband,iband)/occ_k(iband)
4485 : : ! Get ground-state wavefunctions at k
4486 [ + + ]: 890755 : do ipw=1,npw_k*nspinor
4487 : 883817 : cwave0(1,ipw)=cg(1,ipw+(iband_me-1)*npw_k*nspinor+icg)
4488 : 890755 : cwave0(2,ipw)=cg(2,ipw+(iband_me-1)*npw_k*nspinor+icg)
4489 : : end do
4490 : :
4491 [ + + ]: 6938 : if (gs_hamkq%usepaw==1.and.gs_hamkq%usecprj==1) then
4492 : : ! Read PAW ground state projected WF (cprj)
4493 : : ! cprj is already distributed in band and k, just get the corresponding cprj in cwaveprj0
4494 : : call pawcprj_get(gs_hamkq%atindx1,cwaveprj0,cprj,gs_hamkq%natom,iband_me,ibg,ikpt,iorder_cprj,&
4495 : : & isppol,mband_mem,mkmem,gs_hamkq%natom,1,nband_me,nspinor,nsppol,dtfil%unpaw,&
4496 : : !& mpicomm=mpi_enreg%comm_kpt,proc_distrb=mpi_enreg%proc_distrb,&
4497 : 52 : & icpgr=idir,ncpgr=ncpgr)
4498 : : end if
4499 : :
4500 : : ! Read ground-state wavefunctions at k+q
4501 : 6938 : indx=npw1_k*nspinor*(iband_me-1)+icgq
4502 [ + + + + ]: 2658389 : cwaveq(:,1:npw_k*nspinor)=wtband*cgq(:,1+indx:npw_k*nspinor+indx)
4503 [ + + ]: 6938 : if (gs_hamkq%usepaw==1.and.gs_hamkq%usecprj==1) then
4504 : : ! Read PAW ground state projected WF (cprj)
4505 : 52 : indx=nspinor*(iband_me-1)+ibgq
4506 : : ! TODO: cprj distributed -> iband_me
4507 : : !indx=nspinor*(iband-1)+ibgq
4508 : 52 : call pawcprj_copy(cprjq(:,1+indx:nspinor+indx),cwaveprjq)
4509 : 52 : call pawcprj_axpby(zero,wtband,cwaveprj_tmp,cwaveprjq)
4510 : : end if
4511 : :
4512 : : ! Apply H^(1)-Esp.S^(1) to Psi^(0) (H(^1)=only (NL+kin) frozen part)
4513 : 6938 : lambda=eig0_k(iband)
4514 : : call getgh1c(berryopt,cwave0,cwaveprj0,gh1,dum_grad_berry,dum_gs1,gs_hamkq,dum_gvnlx1,&
4515 : : & idir,ipert,(/lambda/),mpi_enreg,1,optlocal,optnl,opt_gvnlx1,rf_hamkq,sij_opt,&
4516 [ + + ]: 13876 : & tim_getgh1c,usevnl)
4517 : : ! Compute Eig1=<Psi^(0)|H^(1)-Eps.S^(1)|Psi(0)>
4518 : : call dotprod_g(dotr(1),lambda,gs_hamkq%istwf_k,npw_k*nspinor,1,cwave0,gh1,mpi_enreg%me_g0, &
4519 : 6938 : & mpi_enreg%comm_spinorfft)
4520 : 6938 : indx=2*iband-1+(iband-1)*2*nband_k
4521 : 6938 : eig1_k(indx)=dotr(1)
4522 : : ! Compute the fixed contribution to the 1st-order Fermi energy
4523 : 6938 : fe1fixed_k(iband)=two*wtband*eig1_k(indx)
4524 : 6938 : fe1norm_k(iband) =two*wtband
4525 : :
4526 : : ! Accumulate contribution to density and PAW occupation matrix
4527 : :
4528 : : call dfpt_accrho(cplex,cwave0,cwaveq,cwaveq,cwaveprj0,cwaveprjq,dotr(1),&
4529 : : gs_hamkq,iband,0,0,isppol,kptopt,mpi_enreg,1,gs_hamkq%natom,nband_k,ncpgr,&
4530 : : npw_k,npw1_k,nspinor,occ_k,opt_accrho,pawrhoijfermi,rhoaug,tim_fourwf,&
4531 : 6938 : opt_corr,wtk_k)
4532 : : end if ! End of non-zero occupation and rocceig
4533 : :
4534 : : end do ! End loop over bands
4535 : :
4536 : 4468 : call timab(139,2,tsec)
4537 : 4468 : call timab(130,1,tsec)
4538 : :
4539 [ - + ]: 4468 : ABI_FREE(cwave0)
4540 [ - + ]: 4468 : ABI_FREE(cwaveq)
4541 [ - + ]: 4468 : ABI_FREE(gh1)
4542 [ + + ]: 4468 : if (gs_hamkq%usepaw==1.and.gs_hamkq%usecprj==1) then
4543 : 435 : call pawcprj_free(cwaveprj0)
4544 : 435 : call pawcprj_free(cwaveprjq)
4545 : : end if
4546 [ + - + + : 5984 : ABI_FREE(cwaveprj0)
- + - + -
+ ]
4547 [ + - + + : 5984 : ABI_FREE(cwaveprjq)
- + - + -
+ ]
4548 : :
4549 : : !Structured debugging : if prtvol=-level, stop here.
4550 [ - + ]: 4468 : if(prtvol==-level)then
4551 : 0 : write(msg,'(a,a1,a,i2,a)')' fermie3 : exit prtvol=-',level,', debugging mode => stop '
4552 : 0 : ABI_ERROR(msg)
4553 : : end if
4554 : :
4555 : 4468 : call timab(130,2,tsec)
4556 : :
4557 : : ABI_NVTX_END_RANGE()
4558 : : DBG_EXIT('COLL')
4559 : :
4560 [ - + - - : 4468 : end subroutine dfpt_wfkfermi
- - - - ]
4561 : : !!***
4562 : :
4563 : : !!****f* ABINIT/dfpt_vtrial1_mq
4564 : : !! NAME
4565 : : !! dfpt_vtrial1_mq
4566 : : !!
4567 : : !! FUNCTION
4568 : : !! This routine computes the self-consistent potential at (-q,-omega).
4569 : : !!
4570 : : !! INPUTS
4571 : : !!
4572 : : !! OUTPUT
4573 : : !!
4574 : : !! SOURCE
4575 : :
4576 : 91 : subroutine dfpt_vtrial1_mq(cplex,nfftf,nspden,nvresid1,nvresid1_mq,vtrial1,vtrial1_mq)
4577 : :
4578 : : !Arguments ------------------------------------
4579 : : !scalars
4580 : : integer,intent(in) :: cplex,nfftf,nspden
4581 : :
4582 : : !arrays
4583 : : real(dp),intent(in) :: nvresid1(cplex*nfftf,nspden),vtrial1(cplex*nfftf,nspden)
4584 : : real(dp),intent(out) :: nvresid1_mq(cplex*nfftf,nspden),vtrial1_mq(cplex*nfftf,nspden)
4585 : :
4586 : : !Local variables-------------------------------
4587 : : !scalars
4588 : : integer :: ifft
4589 : : !arrays
4590 : :
4591 : : ! *********************************************************************
4592 : :
4593 : : DBG_ENTER('COLL')
4594 : :
4595 : : !TODO: proper fft parallelization...
4596 [ + + ]: 655451 : do ifft=1,nfftf
4597 : 655360 : vtrial1_mq(2*ifft-1,1)=+vtrial1(2*ifft-1,1)
4598 : 655360 : vtrial1_mq(2*ifft ,1)=-vtrial1(2*ifft ,1)
4599 : 655360 : nvresid1_mq(2*ifft-1,1)=+nvresid1(2*ifft-1,1)
4600 : 655451 : nvresid1_mq(2*ifft ,1)=-nvresid1(2*ifft ,1)
4601 : : end do
4602 [ + - ]: 91 : if (nspden >= 2) then
4603 [ + + ]: 655451 : do ifft=1,nfftf
4604 : 655360 : vtrial1_mq(2*ifft-1,2)=+vtrial1(2*ifft-1,2)
4605 : 655360 : vtrial1_mq(2*ifft ,2)=-vtrial1(2*ifft ,2)
4606 : 655360 : nvresid1_mq(2*ifft-1,2)=+nvresid1(2*ifft-1,2)
4607 : 655451 : nvresid1_mq(2*ifft ,2)=-nvresid1(2*ifft ,2)
4608 : : end do
4609 : : end if
4610 [ + - ]: 91 : if (nspden > 2) then
4611 [ + + ]: 655451 : do ifft=1,nfftf
4612 : 655360 : vtrial1_mq(2*ifft-1,3)= vtrial1(2*ifft ,4) !Re[V^12]
4613 : 655360 : vtrial1_mq(2*ifft ,3)= vtrial1(2*ifft-1,4) !Im[V^12],see definition of v(:,4) cplex=2 case
4614 : 655360 : vtrial1_mq(2*ifft ,4)= vtrial1(2*ifft-1,3) !Re[V^21]=Re[V^12]
4615 : 655360 : vtrial1_mq(2*ifft-1,4)= vtrial1(2*ifft ,3) !Re[V^21]=Re[V^12]
4616 : 655360 : nvresid1_mq(2*ifft-1,3)= nvresid1(2*ifft ,4) !Re[V^12]
4617 : 655360 : nvresid1_mq(2*ifft ,3)= nvresid1(2*ifft-1,4) !Im[V^12],see definition of v(:,4) cplex=2 case
4618 : 655360 : nvresid1_mq(2*ifft ,4)= nvresid1(2*ifft-1,3) !Re[V^21]=Re[V^12]
4619 : 655451 : nvresid1_mq(2*ifft-1,4)= nvresid1(2*ifft ,3) !Re[V^21]=Re[V^12]
4620 : : end do
4621 : : end if
4622 : :
4623 : : DBG_EXIT('COLL')
4624 : :
4625 : 91 : end subroutine dfpt_vtrial1_mq
4626 : : !!***
4627 : :
4628 : : end module m_dfpt_scfcv
4629 : : !!***
|
