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 4684 : subroutine dfpt_scfcv(atindx,blkflg,cg,cgq,cg1,cg1_active,cplex,cprj,cprjq,cpus,&
282 2342 : & dielt,dim_eig2rf,doccde_rbz,docckqde,dtfil,dtset,&
283 2342 : & d2bbb,d2lo,d2nl,d2ovl,eberry,edocc,eeig0,eew,efrhar,efrkin,efrloc,efrnl,efrx1,efrx2,&
284 2342 : & 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 4684 : & fermie,gh0c1_set,gh1c_set,hdr,idir,indkpt1,&
287 2342 : & indsy1,initialized,ipert,irrzon1,istwfk_rbz,&
288 2342 : & kg,kg1,kpt_rbz,kxc,mband_mem_rbz,mgfftf,mkmem,mkqmem,mk1mem,&
289 2342 : & mpert,mpi_enreg,mpw,mpw1,mpw1_mq,my_natom,nattyp,nband_rbz,ncpgr,&
290 2342 : & nfftf,ngfftf,nhat,nkpt,nkpt_rbz,nkxc,npwarr,npwar1,nspden,&
291 2342 : & nsym1,n3xccc,occkq,occ_rbz,&
292 2342 : & paw_an,paw_ij,pawang,pawang1,pawfgr,pawfgrtab,pawrad,pawrhoij,pawrhoij1,pawtab,&
293 4684 : & pertcase,phnons1,ph1d,ph1df,&
294 2342 : & prtbbb,psps,qphon,resid,residm,rhog,rhog1,&
295 2342 : & rhor,rhor1,rprimd,symaf1,symrc1,symrl1,tnons1,&
296 2342 : & usecprj,useylmgr,useylmgr1,usevxctau,ddk_f,vpsp1,vtrial,vxc,vxctau,&
297 4684 : & wtk_rbz,xccc3d1,xred,ylm,ylm1,ylmgr,ylmgr1,zeff,conv_retcode,&
298 : & kramers_deg,&
299 4684 : & 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 2342 : & 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 2342 : type(efield_type) :: dtefield
430 : type(paw_energies_type) :: paw1_energies
431 : !arrays
432 : integer :: ngfftmix(18)
433 2342 : integer,allocatable :: dimcprj(:),pwindall(:,:,:)
434 2342 : 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 4684 : real(dp) :: rhomag(2,nspden),rmet(3,3),tollist(12),tsec(2)
438 : real(dp) :: zeff_red(3),zeff_bar(3,3)
439 7026 : real(dp) :: intgden(cplex,dtset%nspden,dtset%natom),dentot(dtset%nspden)
440 4684 : 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 2342 : real(dp),allocatable :: d2bbb_mq(:,:,:,:,:,:),d2lo_mq(:,:,:,:,:),d2nl_mq(:,:,:,:,:)
443 2342 : real(dp),allocatable :: d2bbb_pq(:,:,:,:,:,:),d2lo_pq(:,:,:,:,:),d2nl_pq(:,:,:,:,:)
444 2342 : real(dp),allocatable :: dielinv(:,:,:,:,:)
445 2342 : real(dp),allocatable :: fcart(:,:),nhat1(:,:),nhat1gr(:,:,:),nhatfermi(:,:),nvresid1(:,:),nvresid2(:,:)
446 2342 : real(dp),allocatable :: qmat(:,:,:,:,:,:),resid2(:),rhog2(:,:),rhor2(:,:),rhorfermi(:,:)
447 2342 : real(dp),allocatable :: susmat(:,:,:,:,:),vectornd(:,:,:),vhartr1(:),vxc1(:,:)
448 2342 : real(dp),allocatable :: vhartr1_tmp(:,:)
449 2342 : real(dp),allocatable,target :: vtrial1(:,:),vtrial2(:,:)
450 2342 : real(dp),allocatable :: vtrial1_mq(:,:),rhorfermi_mq(:,:)
451 2342 : real(dp),allocatable :: nvresid1_mq(:,:)
452 2342 : real(dp),pointer :: vtrial1_tmp(:,:)
453 2342 : type(pawcprj_type),allocatable :: cprj1(:,:)
454 2342 : type(paw_an_type),allocatable :: paw_an1(:)
455 2342 : type(paw_ij_type),allocatable :: paw_ij1(:)
456 2342 : type(pawrhoij_type),allocatable :: pawrhoijfermi(:)
457 : ! *********************************************************************
458 : DBG_ENTER("COLL")
459 :
460 2342 : 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 2342 : call timab(120,1,tsec)
466 2342 : call timab(154,1,tsec)
467 :
468 : ! intel 18 really needs this to be initialized
469 2342 : maxfor = zero
470 :
471 : ! enable time limit handler if not done in callers.
472 2342 : if (enable_timelimit_in(MY_NAME) == MY_NAME) then
473 2342 : 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 2342 : spaceComm=mpi_enreg%comm_cell
478 2342 : me=mpi_enreg%me_kpt
479 2342 : paral_atom=(my_natom/=dtset%natom)
480 2342 : my_atmtab=>mpi_enreg%my_atmtab
481 :
482 : !Save some variables from dataset definition
483 2342 : ecut=dtset%ecut
484 2342 : ecutf=ecut;if (psps%usepaw==1) ecutf=dtset%pawecutdg
485 2342 : iprcel=dtset%iprcel
486 2342 : tollist(1)=dtset%tolmxf;tollist(2)=dtset%tolwfr
487 2342 : tollist(3)=dtset%toldff;tollist(4)=dtset%toldfe
488 2342 : tollist(6)=dtset%tolvrs;tollist(7)=dtset%tolrff
489 2342 : tollist(9)=dtset%toldmag
490 9368 : nfftotf=product(ngfftf(1:3))
491 2342 : nstep=dtset%nstep
492 2342 : iscf_mod=dtset%iscf
493 2342 : iscf10_mod=mod(iscf_mod,10)
494 :
495 2342 : 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 1618 : & (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 2342 : 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 2342 : 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 2342 : call metric(gmet,gprimd,-1,rmet,rprimd,ucvol)
511 :
512 : !Compute large sphere cut-off gsqcut
513 2342 : qphon2(:)=zero;if (psps%usepaw==1) qphon2(:)=qphon(:)
514 2342 : call getcut(boxcut,ecutf,gmet,gsqcut,dtset%iboxcut,std_out,qphon2,ngfftf)
515 :
516 : !Some variables need to be initialized/nullify at start
517 2342 : quit=0 ; dbl_nnsclo=0 ; elast=zero; conv_retcode = -1
518 2342 : optres=merge(0,1,abs(iscf_mod)<10)
519 2342 : nmxc=(dtset%usepaw==1.and.mod(abs(dtset%usepawu),10)==4)
520 2342 : usexcnhat=0
521 : !This might be taken away later
522 2342 : edocc=zero ; eeig0=zero ; ehart01=zero ; ehart1=zero ; ek0=zero ; ek1=zero
523 2342 : eloc0=zero ; elpsp1=zero ; end0=zero; end1=zero;
524 2342 : enl0=zero ; enl1=zero ; eovl1=zero; evxctau0=zero; evxctau1=zero; exc1=zero
525 2342 : deltae=zero ; fermie1=zero ; epaw1=zero ; eberry=zero ; elmag1=zero
526 2342 : elast_mq=zero ; emagpen1=zero
527 2342 : dbl_nnsclo_mq=0
528 : !This might be taken away later
529 2342 : edocc_mq=zero ; eeig0_mq=zero ; ehart01_mq=zero ; ehart1_mq=zero ; ek0_mq=zero ; ek1_mq=zero
530 2342 : eloc0_mq=zero ; elpsp1_mq=zero ; enl0_mq=zero ; enl1_mq=zero ;
531 2342 : end0_mq=zero; end1_mq=zero; eovl1_mq=zero; evxctau0_mq=zero; evxctau1_mq=zero; exc1_mq=zero
532 2342 : deltae_mq=zero ; fermie1_mq=zero ; epaw1_mq=zero ; eberry_mq=zero ; elmag1_mq=zero
533 2342 : 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 2342 : choice=1 ; prtfor=0 ; diffor=zero ; res2=zero
539 2342 : maxmag=zero;difmag=zero
540 21331 : intgden=zero
541 7026 : ABI_MALLOC(fcart,(3,dtset%natom))
542 :
543 : !At present, no double loop
544 2342 : 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 2342 : & tollist,psps%usepaw,vxcavg,wtk_rbz,xred,conv_retcode)
553 :
554 : !Allocations/initializations for PAW only
555 2342 : if(psps%usepaw==1) then
556 1127 : usexcnhat=maxval(pawtab(:)%usexcnhat)
557 397 : use_nhat_gga=(dtset%xclevel==2.and.dtset%pawnhatxc>0.and.usexcnhat>0)
558 : ! 1st-order compensation density
559 1588 : ABI_MALLOC(nhat1,(cplex*nfftf,dtset%nspden))
560 10252715 : nhat1=zero
561 : ! Projections of 1-st order WF on nl projectors
562 243120 : ABI_MALLOC(cprj1,(dtset%natom,dtset%nspinor*mband_mem_rbz*mk1mem*dtset%nsppol*usecprj))
563 397 : if (usecprj==1.and.mk1mem/=0) then
564 : !cprj ordered by atom-type
565 1191 : ABI_MALLOC(dimcprj,(dtset%natom))
566 397 : call pawcprj_getdim(dimcprj,dtset%natom,nattyp,dtset%ntypat,dtset%typat,pawtab,'O')
567 397 : call pawcprj_alloc(cprj1,0,dimcprj)
568 397 : ABI_FREE(dimcprj)
569 : end if
570 : ! 1st-order arrays/variables related to the PAW spheres
571 1963 : ABI_MALLOC(paw_an1,(my_natom))
572 1963 : ABI_MALLOC(paw_ij1,(my_natom))
573 397 : call paw_an_nullify(paw_an1)
574 397 : call paw_ij_nullify(paw_ij1)
575 :
576 397 : has_dijfr=0;if (ipert/=dtset%natom+1.and.ipert/=dtset%natom+10) has_dijfr=1
577 397 : 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 397 : & 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 397 : & 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 7026 : ABI_MALLOC(vhartr1,(cplex*nfftf))
594 9368 : ABI_MALLOC(vtrial1,(cplex*nfftf,nspden))
595 2342 : 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 9368 : ABI_MALLOC(vxc1,(cplex*nfftf,nspden*(1-usexcnhat))) ! Not always needed
612 2342 : 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 2342 : if (iscf_mod>0.or.iscf_mod==-3) then
617 8872 : ABI_MALLOC(nvresid1,(cplex*nfftf,dtset%nspden))
618 2218 : if (nstep==0) nvresid1=zero
619 2218 : 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 2218 : 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 2342 : 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 2342 : 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 2342 : & 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 2333 : ABI_MALLOC(pwindall,(0,0,0))
710 2333 : 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 2342 : with_vectornd = 0
715 : ! nuclear dipoles only work with the DDK response function
716 23638 : if ( (ANY(ABS(dtset%nucdipmom(:,:))>tol8)) .AND. (ipert.EQ.dtset%natom+1) ) with_vectornd = 1
717 : ABI_SFREE(vectornd)
718 11710 : ABI_MALLOC(vectornd,(with_vectornd*nfftf,dtset%nspden,3))
719 2342 : if(with_vectornd .EQ. 1) then
720 : call make_vectornd(1,gsqcut,psps%usepaw,mpi_enreg,dtset%natom,nfftf,&
721 48 : & ngfftf,dtset%nspden,dtset%nucdipmom,rprimd,vectornd,xred)
722 : endif
723 :
724 : ! Set the value of omega for a finite-frequency calculation
725 2342 : omega=dtset%rfomega
726 2342 : eta=dtset%rfeta
727 2342 : 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 2342 : 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 2342 : quitsum_request = xmpi_request_null; timelimit_exit = 0
751 :
752 : ABI_NVTX_START_RANGE(NVTX_DFPT_SCF)
753 18864 : do istep=1,max(1,nstep)
754 :
755 : ! Handle time limit condition.
756 18684 : if (istep == 1) prev = abi_wtime()
757 18684 : if (istep > 1) then
758 16342 : now = abi_wtime()
759 16342 : wtime_step = now - prev
760 16342 : prev = now
761 16342 : call wrtout(std_out,sjoin(" dfpt_scfcv: previous iteration took ",sec2str(wtime_step)))
762 :
763 16342 : 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 18684 : 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 2342 : if (psps%usepaw==1) then
789 397 : optfr=0
790 397 : idir_paw1 = idir
791 397 : 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 397 : & mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom)
798 :
799 397 : if ((iscf_mod>=0.or.usexcnhat==0).and.(dtset%pawstgylm/=0)) then
800 334 : 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 334 : & 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 2342 : nhat1grdim=0
811 2342 : ABI_MALLOC(nhat1gr,(0,0,0))
812 2342 : 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 2342 : 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 2342 : & 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 2342 : 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 2342 : 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 18684 : if (psps%usepaw==1)then
897 : ! Computation of "on-site" 2nd-order energy, first-order potentials, first-order densities
898 3496 : nzlmopt=0;if (istep==2.and.dtset%pawnzlm>0) nzlmopt=-1
899 3496 : if (istep>2) nzlmopt=dtset%pawnzlm
900 3496 : call paw_an_reset_flags(paw_an1) ! Force the recomputation of on-site potentials
901 3496 : call paw_ij_reset_flags(paw_ij1,self_consistent=.true.) ! Force the recomputation of Dij
902 3496 : 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 3496 : & comm_atom=mpi_enreg%comm_atom,mpi_atmtab=mpi_enreg%my_atmtab)
908 3496 : epaw1=paw1_energies%epaw
909 :
910 : ! First-order Dij computation
911 3496 : call timab(561,1,tsec)
912 3496 : 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 819 : 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 3496 : & mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom,spinaxis=dtset%spinaxis)
927 3496 : 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 3496 : & qphon=qphon)
935 3496 : 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 18684 : 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 18684 : 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 18684 : 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 18684 : 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 18684 : & eta=eta,omega=omega) !optional arguments for finite-w calculation
988 :
989 18684 : 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 18684 : & 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 18684 : 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 18560 : 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 18560 : 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 18560 : if (kramers_deg.and.(ipert<dtset%natom+10.or.(ipert>dtset%natom+11.and.ipert<=2*dtset%natom+11))) then
1125 18301 : 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 18301 : & dtset%qgbt,dtset%use_gbt)
1131 : end if
1132 :
1133 18560 : 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 20902 : if (iscf_mod<10) then
1147 :
1148 : ! PAW: has to compute here the "on-site" 2nd-order energy
1149 18560 : if (psps%usepaw==1) then
1150 3496 : nzlmopt=0;if (istep==1.and.dtset%pawnzlm>0) nzlmopt=-1
1151 3496 : if (istep>1) nzlmopt=dtset%pawnzlm
1152 3496 : call paw_an_reset_flags(paw_an1) ! Force the recomputation of on-site potentials
1153 3496 : 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 3496 : & ucvol,psps%znuclpsp,dtset%spinaxis,mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom)
1159 3496 : epaw1=paw1_energies%epaw
1160 : end if
1161 :
1162 18560 : 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 18560 : & 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 18560 : 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 18560 : call timab(152,1,tsec)
1180 18560 : 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 18560 : 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 18560 : & tollist,psps%usepaw,vxcavg,wtk_rbz,xred,conv_retcode)
1198 : ! endif
1199 18560 : call timab(152,2,tsec)
1200 :
1201 : ! If criteria in scprqt say to quit, then exit the loop over istep
1202 18560 : quit_sum=quit
1203 18560 : call xmpi_sum(quit_sum,spaceComm,ierr)
1204 18560 : 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 16522 : 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 2342 : call xmpi_wait(quitsum_request,ierr)
1229 2342 : 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 2342 : 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 2342 : if (iscf_mod>0.or.iscf_mod==-3) then
1303 2218 : ABI_FREE(nvresid1)
1304 2218 : 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 2342 : 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 9368 : & ipert==dtset%natom+10.or.ipert==dtset%natom+11) then
1343 370 : call ddk_f(1)%close()
1344 : end if
1345 2342 : 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 2342 : 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 2342 : if (iscf_mod>0.and.nstep>0) then
1355 1600 : call abi_mixing_deallocate(mix)
1356 : end if
1357 2342 : 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 2342 : ABI_SFREE(rhorfermi)
1362 2342 : ABI_SFREE(rhorfermi_mq)
1363 2342 : ABI_SFREE(nhatfermi)
1364 2342 : if(allocated(pawrhoijfermi)) then
1365 192 : call pawrhoij_free(pawrhoijfermi)
1366 448 : ABI_FREE(pawrhoijfermi)
1367 : end if
1368 2342 : if(psps%usepaw==1) then
1369 397 : if (mk1mem/=0.and.usecprj==1) then
1370 397 : call pawcprj_free(cprj1)
1371 : end if
1372 1169 : do iatom=1,my_natom
1373 772 : if (pawfgrtab(iatom)%nhatfr_allocated>0) then
1374 377 : ABI_FREE(pawfgrtab(iatom)%nhatfr)
1375 : end if
1376 1169 : pawfgrtab(iatom)%nhatfr_allocated=0
1377 : end do
1378 397 : 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 161206 : ABI_FREE(cprj1)
1388 2342 : ABI_FREE(nhat1gr)
1389 :
1390 2342 : call timab(160,2,tsec)
1391 2342 : call timab(150,1,tsec)
1392 :
1393 2342 : 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 2342 : if (ipert<dtset%natom+10.or.ipert>dtset%natom+11) then
1419 2163 : 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 347 : & 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 2342 : call timab(150,2,tsec)
1485 2342 : 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 2342 : & 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 2342 : 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 2342 : & tollist,psps%usepaw,vxcavg,wtk_rbz,xred,conv_retcode)
1520 :
1521 : !Update the content of the header (evolving variables)
1522 151792 : 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 2342 : & 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 2342 : 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 2342 : 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 2342 : if (iwrite_fftdatar(mpi_enreg)) then
1568 2050 : if (dtset%prtden>0) then
1569 1838 : rdwrpaw=0
1570 1838 : 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 1838 : 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 2050 : if (dtset%prtpot > 0) then
1581 2003 : rdwrpaw=0
1582 2003 : 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 2003 : 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 2003 : if (mpi_enreg%me_g0 == 1) then
1590 2003 : if (dtset%iomode == IO_MODE_ETSF) then
1591 2003 : NCF_CHECK(nctk_open_modify(ncid, nctk_ncify(fi1o), xmpi_comm_self))
1592 2003 : ncerr = nctk_def_one_array(ncid, nctkarr_t('rhog1_g0', "dp", "two"), varid=varid)
1593 2003 : NCF_CHECK(ncerr)
1594 2003 : NCF_CHECK(nctk_set_datamode(ncid))
1595 2003 : NCF_CHECK(nf90_put_var(ncid, varid, rhog1(:,1)))
1596 2003 : 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 2050 : 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 2050 : 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 2342 : 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 2342 : ABI_FREE(fcart)
1656 2342 : ABI_FREE(vtrial1)
1657 2342 : 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 2342 : ABI_FREE(vhartr1)
1667 2342 : ABI_FREE(vxc1)
1668 2342 : ABI_FREE(pwindall)
1669 2342 : 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 2342 : ABI_SFREE(vectornd)
1677 :
1678 2342 : if(psps%usepaw==1) then
1679 397 : call paw_an_free(paw_an1)
1680 397 : call paw_ij_free(paw_ij1)
1681 : end if
1682 3114 : ABI_FREE(paw_an1)
1683 3114 : ABI_FREE(paw_ij1)
1684 2342 : ABI_FREE(nhat1)
1685 :
1686 2342 : call timab(160,2,tsec)
1687 2342 : call timab(120,2,tsec)
1688 :
1689 : DBG_EXIT("COLL")
1690 :
1691 9390 : 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 18640 : 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 18640 : if (optene==1) then
1771 0 : ABI_BUG('Double-counting scheme not yet allowed!')
1772 : end if
1773 :
1774 18640 : if (optene>-1) then
1775 :
1776 : ! Compute 2nd-order variational energy by direct scheme
1777 18640 : if (optene==0) then
1778 :
1779 : ! Atomic displ. perturbation
1780 18640 : if ( ipert>=1 .and. ipert<=natom ) then
1781 11388 : evar=ek0+edocc+eeig0+eloc0+enl0+ehart1+exc1+enl1+epaw1+elpsp1+emagpen1
1782 :
1783 7252 : else if (ipert==natom+1) then
1784 3350 : 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 18640 : deltae=evar-elast
1809 18640 : elast=evar
1810 :
1811 : ! Compute 2nd-order total energy by direct scheme
1812 18640 : if (optene==0) then
1813 18640 : 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 18543 : if (ipert/=natom+10 .and. ipert/=natom+11) then
1821 18364 : 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 18640 : 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 : !!***
|
