Branch data Line data Source code
1 : : !!****m* ABINIT/m_sigma_driver
2 : : !! NAME
3 : : !! m_sigma_driver
4 : : !!
5 : : !! FUNCTION
6 : : !! Calculate the matrix elements of the self-energy operator.
7 : : !!
8 : : !! COPYRIGHT
9 : : !! Copyright (C) 1999-2026 ABINIT group (MG, GMR, VO, LR, RWG, MT)
10 : : !! This file is distributed under the terms of the
11 : : !! GNU General Public License, see ~abinit/COPYING
12 : : !! or http://www.gnu.org/copyleft/gpl.txt .
13 : : !!
14 : : !! SOURCE
15 : :
16 : : #if defined HAVE_CONFIG_H
17 : : #include "config.h"
18 : : #endif
19 : :
20 : : #include "abi_common.h"
21 : :
22 : : module m_sigma_driver
23 : :
24 : : use defs_basis
25 : : use m_gwdefs
26 : : use defs_wvltypes
27 : : use m_xmpi
28 : : use m_xomp
29 : : use m_errors
30 : : use m_abicore
31 : : use m_abi_mixing
32 : : use m_kxc
33 : : use m_distribfft
34 : : use netcdf
35 : : use m_nctk
36 : : use libxc_functionals
37 : : use m_dtfil
38 : : use m_cgtools
39 : :
40 : : use defs_datatypes, only : pseudopotential_type
41 : : use defs_abitypes, only : MPI_type
42 : : use m_time, only : timab
43 : : use m_numeric_tools, only : imax_loc
44 : : use m_fstrings, only : strcat, sjoin, itoa, basename, ktoa, ltoa
45 : : use m_hide_blas, only : xdotc
46 : : use m_io_tools, only : open_file, file_exists, iomode_from_fname
47 : : use m_mpinfo, only : destroy_mpi_enreg, initmpi_seq
48 : : use m_pstat, only : pstat_proc
49 : : use m_dtset, only : dataset_type
50 : : use m_hdr, only : hdr_type
51 : : use m_crystal, only : crystal_t
52 : : use m_geometry, only : normv, mkrdim, metric
53 : : use m_fftcore, only : print_ngfft
54 : : use m_fft_mesh, only : get_gfft, setmesh
55 : : use m_fft, only : fourdp
56 : : use m_ioarr, only : fftdatar_write, read_rhor
57 : : use m_ebands, only : ebands_t, gaps_t
58 : : use m_energies, only : energies_type
59 : : use m_bz_mesh, only : kmesh_t, littlegroup_t, littlegroup_free, isamek, get_ng0sh
60 : : use m_gsphere, only : gsphere_t, merge_and_sort_kg, setshells
61 : : use m_kg, only : getph, getcut
62 : : use m_xcdata, only : get_xclevel
63 : : use m_wfd, only : wfdgw_t, wfdgw_copy, test_charge, wave_t
64 : : use m_vcoul, only : vcoul_t
65 : : use m_qparticles, only : wrqps, rdqps, rdgw, show_QP, updt_m_ks_to_qp
66 : : use m_screening, only : epsm1_t
67 : : use m_ppmodel, only : ppmodel_t
68 : : use m_sigma, only : sigma_t, write_sigma_header
69 : : use m_dyson_solver, only : solve_dyson
70 : : use m_esymm, only : esymm_t, esymm_free
71 : : use m_melemts, only : melflags_t, melements_t
72 : : use m_pawang, only : pawang_type
73 : : use m_pawrad, only : pawrad_type
74 : : use m_pawtab, only : pawtab_type, pawtab_print, pawtab_get_lsize
75 : : use m_paw_an, only : paw_an_type, paw_an_init, paw_an_free, paw_an_nullify
76 : : use m_paw_ij, only : paw_ij_type, paw_ij_init, paw_ij_free, paw_ij_nullify, paw_ij_print
77 : : use m_pawfgrtab, only : pawfgrtab_type, pawfgrtab_init, pawfgrtab_free, pawfgrtab_print
78 : : use m_pawrhoij, only : pawrhoij_type, pawrhoij_alloc, pawrhoij_copy, pawrhoij_free, &
79 : : pawrhoij_inquire_dim, pawrhoij_symrhoij, pawrhoij_unpack
80 : : use m_pawcprj, only : pawcprj_type, pawcprj_alloc, pawcprj_free, paw_overlap
81 : : use m_pawdij, only : pawdij, symdij_all
82 : : use m_pawfgr, only : pawfgr_type, pawfgr_init, pawfgr_destroy
83 : : use m_paw_pwaves_lmn,only : paw_pwaves_lmn_t, paw_pwaves_lmn_init, paw_pwaves_lmn_free
84 : : use m_pawpwij, only : pawpwff_t, pawpwff_init, pawpwff_free
85 : : use m_paw_slater, only : paw_mkdijexc_core, paw_dijhf
86 : : use m_paw_dmft, only : paw_dmft_type
87 : : use m_paw_sphharm, only : setsym_ylm
88 : : use m_paw_mkrho, only : denfgr
89 : : use m_paw_nhat, only : nhatgrid, pawmknhat
90 : : use m_paw_tools, only : chkpawovlp, pawprt
91 : : use m_paw_denpot, only : pawdenpot
92 : : use m_paw_init, only : pawinit, paw_gencond
93 : : use m_pawpsp, only : pawpsp_check_corefile
94 : : use m_classify_bands,only : classify_bands
95 : : use m_wfk, only : wfk_read_eigenvalues
96 : : use m_io_kss, only : make_gvec_kss
97 : : use m_vhxc_me, only : calc_vhxc_me
98 : : use m_cohsex, only : cohsex_me
99 : : use m_sigx, only : calc_sigx_me
100 : : use m_sigc, only : calc_sigc_me
101 : : use m_setvtr, only : setvtr
102 : : use m_mkrho, only : prtrhomxmn
103 : : use m_pspini, only : pspini
104 : : use m_calc_ucrpa, only : calc_ucrpa
105 : : use m_prep_calc_ucrpa,only : prep_calc_ucrpa
106 : : use m_paw_correlations,only : pawpuxinit
107 : : use m_spacepar, only : hartre
108 : : use m_gwrdm, only : calc_rdmx,calc_rdmc,natoccs,update_hdr_bst,print_tot_occ,get_chkprdm,&
109 : : print_chkprdm,change_matrix,print_total_energy,print_band_energies,quadrature_sigma_cw
110 : : use m_plowannier, only : operwan_realspace_type,plowannier_type,init_plowannier,get_plowannier,&
111 : : fullbz_plowannier,init_operwan_realspace,reduce_operwan_realspace,&
112 : : destroy_operwan_realspace,destroy_plowannier,zero_operwan_realspace
113 : : use minimax_grids, only : gx_minimax_grid
114 : :
115 : : implicit none
116 : :
117 : : private
118 : : !!***
119 : :
120 : : public :: sigma
121 : : !!***
122 : :
123 : : contains
124 : : !!***
125 : :
126 : : !!****f* m_sigma_driver/sigma
127 : : !! NAME
128 : : !! sigma
129 : : !!
130 : : !! FUNCTION
131 : : !! Calculate the matrix elements of the self-energy operator.
132 : : !!
133 : : !! INPUTS
134 : : !! acell(3)=length scales of primitive translations (bohr)
135 : : !! codvsn=code version
136 : : !! Dtfil<type(datafiles_type)>=variables related to files
137 : : !! Dtset<type(dataset_type)>=all input variables for this dataset
138 : : !! Pawang<type(pawang_type)>=paw angular mesh and related data
139 : : !! Pawrad(ntypat*usepaw)<type(pawrad_type)>=paw radial mesh and related data
140 : : !! Pawtab(ntypat*usepaw)<type(pawtab_type)>=paw tabulated starting data
141 : : !! Psps<type(pseudopotential_type)>=variables related to pseudopotentials
142 : : !! Before entering the first time in sigma, a significant part of Psps has been initialized :
143 : : !! the integers dimekb,lmnmax,lnmax,mpssang,mpssoang,mpsso,mgrid,ntypat,n1xccc,usepaw,useylm,
144 : : !! and the arrays dimensioned to npsp. All the remaining components of Psps are to be initialized in
145 : : !! the call to pspini. The next time the code enters screening, Psps might be identical to the
146 : : !! one of the previous Dtset, in which case, no reinitialisation is scheduled in pspini.F90.
147 : : !! rprim(3,3)=dimensionless real space primitive translations
148 : : !!
149 : : !! OUTPUT
150 : : !! Output is written on the main abinit output file. Some results are stored in external files
151 : : !!
152 : : !! NOTES
153 : : !!
154 : : !! ON THE USE OF FFT GRIDS:
155 : : !! =================
156 : : !! In case of PAW:
157 : : !! ---------------
158 : : !! Two FFT grids are used:
159 : : !! - A "coarse" FFT grid (defined by ecut) for the application of the Hamiltonian on the plane waves basis.
160 : : !! It is defined by nfft, ngfft, mgfft, ...
161 : : !! Hamiltonian, wave-functions, density related to WFs (rhor here), ... are expressed on this grid.
162 : : !! - A "fine" FFT grid (defined) by ecutdg) for the computation of the density inside PAW spheres.
163 : : !! It is defined by nfftf, ngfftf, mgfftf, ... Total density, potentials, ... are expressed on this grid.
164 : : !! In case of norm-conserving:
165 : : !! ---------------------------
166 : : !! - Only the usual FFT grid (defined by ecut) is used. It is defined by nfft, ngfft, mgfft, ...
167 : : !! For compatibility reasons, (nfftf,ngfftf,mgfftf) are set equal to (nfft,ngfft,mgfft) in that case.
168 : : !!
169 : : !! SOURCE
170 : :
171 : 201 : subroutine sigma(acell,codvsn,Dtfil,Dtset,Pawang,Pawrad,Pawtab,Psps,rprim)
172 : :
173 : : !Arguments ------------------------------------
174 : : !scalars
175 : : character(len=8),intent(in) :: codvsn
176 : : type(Datafiles_type),intent(in) :: Dtfil
177 : : type(Dataset_type),intent(inout) :: Dtset
178 : : type(Pawang_type),intent(inout) :: Pawang
179 : : type(Pseudopotential_type),intent(inout) :: Psps
180 : : !arrays
181 : : real(dp),intent(in) :: acell(3),rprim(3,3)
182 : : type(Pawrad_type),intent(inout) :: Pawrad(Psps%ntypat*Psps%usepaw)
183 : : type(Pawtab_type),intent(inout) :: Pawtab(Psps%ntypat*Psps%usepaw)
184 : :
185 : : !Local variables-------------------------------
186 : : !scalars
187 : : integer,parameter :: tim_fourdp5 = 5, master = 0, cplex1 = 1, ipert0 = 0, idir0 = 0, optrhoij1 = 1, ndat1 = 1
188 : : integer :: approx_type,b1gw,b2gw,cplex,cplex_dij,cplex_rhoij !,band
189 : : integer :: dim_kxcg,gwcalctyp,gnt_option,has_dijU,has_dijso,iab,bmin,bmax,irr_idx1,irr_idx2
190 : : integer :: iat,ib,ib1,ib2,ic,id_required,ider,ii,ik,ierr,ount
191 : : integer :: ik_bz,ikcalc,ik_ibz,ikxc,npw_k,omp_ncpus,pwx,ibz
192 : : integer :: isp,is_idx,istep,itypat,itypatcor,izero,jj,first_band,last_band
193 : : integer :: ks_iv,lcor,lmn2_size_max,mband,my_nband
194 : : integer :: mgfftf,mod10,moved_atm_inside,moved_rhor,n3xccc !,mgfft
195 : : integer :: nbsc,ndij,ndim,nfftf,nfftf_tot,nkcalc,gwc_nfft,gwc_nfftot,gwx_nfft,gwx_nfftot
196 : : integer :: ngrvdw,nhatgrdim,nkxc,nkxc1,nprocs,nscf,nspden_rhoij,nzlmopt,optene
197 : : integer :: optcut,optgr0,optgr1,optgr2,option,option_test,option_dij,optrad,psp_gencond
198 : : integer :: my_rank,rhoxsp_method,comm,use_aerhor,use_umklp,usexcnhat
199 : : integer :: ioe0j,spin,io,jb,nomega_sigc, gw1rdm,x1rdm
200 : : integer :: temp_unt,ncid
201 : : integer :: work_size,nstates_per_proc,my_nbks !, jb_qp,ib_ks,ks_irr
202 : : real(dp) :: compch_fft,compch_sph,r_s,rhoav,alpha
203 : : real(dp) :: drude_plsmf,my_plsmf,ecore,ecut_eff,ecutdg_eff,ehartree
204 : : real(dp) :: etot_sd,etot_mbb,evextnl_energy,ex_energy,gsqcutc_eff,gsqcutf_eff,gsqcut_shp,norm,old_fermie
205 : : real(dp) :: eh_energy,ekin_energy,evext_energy,den_int,coef_hyb,exc_mbb_energy,tol_empty
206 : : real(dp) :: ucvol,vxcavg,vxcavg_qp,el_temp
207 : : real(dp) :: gwc_gsq,gwx_gsq,gw_gsq, gsqcut,boxcut,ecutf
208 : : real(dp) :: eff,mempercpu_mb,max_wfsmem_mb,nonscal_mem,ug_mem,ur_mem,cprj_mem
209 : : complex(dp) :: max_degw,cdummy
210 : : logical :: rdm_update,readchkprdm,prtchkprdm
211 : : logical :: use_paw_aeur,dbg_mode,pole_screening,call_pawinit,is_dfpt=.false.
212 : : character(len=500) :: msg
213 : : character(len=fnlen) :: wfk_fname,pawden_fname,gw1rdm_fname
214 [ + + + + : 5226 : type(kmesh_t) :: Kmesh,Qmesh
+ + + + ]
215 : 402 : type(ebands_t) :: ks_ebands, qp_ebands
216 [ + + + + : 12864 : type(vcoul_t) :: Vcp, Vcp_ks, Vcp_full
+ + + + +
+ + + + +
+ + + + +
+ + + + +
+ + + + +
+ ]
217 [ + + + + : 10452 : type(crystal_t) :: Cryst
+ + + + +
+ + + + +
+ + + + ]
218 : : type(Energies_type) :: KS_energies,QP_energies
219 [ + + ]: 804 : type(epsm1_t) :: epsm1
220 : 201 : type(gsphere_t) :: Gsph_Max,Gsph_x,Gsph_c
221 : 201 : type(hdr_type) :: Hdr_wfk,Hdr_sigma,Hdr_rhor,hdr_sc
222 : : type(melflags_t) :: KS_mflags,QP_mflags
223 : 603 : type(melements_t) :: KS_me, QP_me, GW1RDM_me
224 : 201 : type(MPI_type) :: MPI_enreg_seq
225 : 201 : type(paw_dmft_type) :: Paw_dmft
226 : : type(pawfgr_type) :: Pawfgr
227 : 201 : type(ppmodel_t) :: PPm
228 : 201 : type(sigparams_t) :: Sigp
229 : 201 : type(sigma_t) :: Sr
230 : 201 : type(wfdgw_t),target :: Wfd, Wfdf, Wfd_nato_master
231 : : type(wfdgw_t),pointer :: Wfd_nato_all
232 : : type(wave_t),pointer :: wave
233 : 201 : type(wvl_data) :: Wvl
234 : : !arrays
235 : : integer :: gwc_ngfft(18),ngfftc(18),ngfftf(18),gwx_ngfft(18), units(2)
236 : 201 : integer,allocatable :: sigmak_todo(:)
237 : 201 : integer,allocatable :: nq_spl(:),nlmn_atm(:),my_spins(:)
238 : 402 : integer,allocatable :: tmp_gfft(:,:),ks_vbik(:,:),nband(:,:),l_size_atm(:),qp_vbik(:,:)
239 : 402 : integer,allocatable :: tmp_kstab(:,:,:),ks_irreptab(:,:,:),qp_irreptab(:,:,:),my_band_list(:)
240 : : real(dp),parameter :: k0(3) = zero
241 : : real(dp) :: gmet(3,3),gprimd(3,3),rmet(3,3),rprimd(3,3),strsxc(6),tsec(2)
242 : 603 : real(dp),allocatable :: weights(:),nat_occs(:,:),gw_rhor(:,:),gw_rhog(:,:),gw_vhartr(:)
243 : 402 : real(dp),allocatable :: grchempottn(:,:),grewtn(:,:),grvdw(:,:),qmax(:)
244 : 201 : real(dp),allocatable :: ks_nhat(:,:),ks_nhatgr(:,:,:),ks_rhog(:,:)
245 : 201 : real(dp),allocatable :: ks_rhor(:,:),ks_vhartr(:),ks_vtrial(:,:),ks_vxc(:,:), ks_taur(:,:)
246 : 402 : real(dp),allocatable :: kxc(:,:),qp_kxc(:,:),ph1d(:,:),ph1df(:,:)
247 : 402 : real(dp),allocatable :: prev_rhor(:,:),prev_taur(:,:),qp_nhat(:,:)
248 : 201 : real(dp),allocatable :: qp_nhatgr(:,:,:),qp_rhog(:,:),qp_rhor_paw(:,:)
249 : 201 : real(dp),allocatable :: qp_rhor_n_one(:,:),qp_rhor_nt_one(:,:)
250 : 201 : real(dp),allocatable :: qp_rhor(:,:),qp_vhartr(:),qp_vtrial(:,:),qp_vxc(:,:)
251 : 402 : real(dp),allocatable :: qp_taur(:,:),igwene(:,:,:)
252 : 402 : real(dp),allocatable :: vpsp(:),xccc3d(:),dijexc_core(:,:,:),dij_hf(:,:,:)
253 : 201 : real(dp),allocatable :: nl_bks(:,:,:)
254 : 201 : real(dp),allocatable :: ks_aepaw_rhor(:,:) !,ks_n_one_rhor(:,:),ks_nt_one_rhor(:,:), osoc_bks(:, :, :)
255 : 201 : real(dp),pointer :: eig_sc(:,:,:)
256 : : complex(dp) :: ovlp(2)
257 : 402 : complex(dp),allocatable :: ctmp(:,:),hbare(:,:,:,:)
258 : 201 : complex(dp),target,allocatable :: sigcme(:,:,:,:,:)
259 : 402 : complex(dp),allocatable :: hdft(:,:,:,:),htmp(:,:,:,:),uks2qp(:,:)
260 : 603 : complex(dp),allocatable :: xrdm_k_full(:,:,:), rdm_k(:,:), pot_k(:,:), nateigv(:,:,:,:), old_ks_purex(:,:), new_hartr(:,:)
261 : 402 : complex(gwp),allocatable :: kxcg(:,:),fxc_ADA(:,:,:)
262 : 201 : complex(gwp),contiguous, pointer :: ug1(:)
263 : 402 : complex(dp),allocatable :: sigcme_k(:,:,:,:), rhot1_q_m(:,:,:,:,:,:,:), M1_q_m(:,:,:,:,:,:,:)
264 : 201 : logical,allocatable :: bks_mask(:,:,:),keep_ur(:,:,:),bmask(:), bdm_mask(:,:,:),bdm2_mask(:,:,:)
265 : 201 : type(esymm_t),target,allocatable :: KS_sym(:,:)
266 : 201 : type(esymm_t),pointer :: QP_sym(:,:)
267 : 201 : type(pawcprj_type),allocatable :: Cp1(:,:) !,Cp2(:,:)
268 : 201 : type(littlegroup_t),allocatable :: Ltg_k(:)
269 : 402 : type(Paw_an_type),allocatable :: KS_paw_an(:),QP_paw_an(:)
270 : 402 : type(Paw_ij_type),allocatable :: KS_paw_ij(:),QP_paw_ij(:)
271 : 201 : type(Pawfgrtab_type),allocatable :: Pawfgrtab(:)
272 : 402 : type(Pawrhoij_type),allocatable :: KS_Pawrhoij(:),QP_pawrhoij(:),prev_Pawrhoij(:),tmp_pawrhoij(:)
273 : 201 : type(pawpwff_t),allocatable :: Paw_pwff(:)
274 : 201 : type(paw_pwaves_lmn_t),allocatable :: Paw_onsite(:)
275 : 201 : type(plowannier_type) :: wanbz,wanibz,wanibz_in
276 : 201 : type(operwan_realspace_type), allocatable :: rhot1(:,:)
277 : : !************************************************************************
278 : :
279 : : DBG_ENTER('COLL')
280 : :
281 : 201 : call timab(401,1,tsec) ! sigma(Total)
282 : 201 : call timab(402,1,tsec) ! sigma(Init1)
283 [ + + ]: 603 : units = [std_out, ab_out]
284 : :
285 : : write(msg,'(7a)')&
286 : 201 : ' SIGMA: Calculation of the GW corrections ',ch10,ch10,&
287 : 201 : ' Based on a program developped by R.W. Godby, V. Olevano, G. Onida, and L. Reining.',ch10,&
288 : 402 : ' Incorporated in ABINIT by V. Olevano, G.-M. Rignanese, and M. Torrent.'
289 : 201 : call wrtout(units, msg)
290 : :
291 [ - + ]: 201 : if(dtset%ucrpa>0) then
292 : 0 : write(msg,'(6a)')ch10,' cRPA Calculation: Calculation of the screened Coulomb interaction (ucrpa/=0) ',ch10
293 : 0 : call wrtout(units, msg)
294 : : end if
295 : :
296 : : #if defined HAVE_GW_DPC
297 : : if (gwp /= 8) then
298 : : write(msg,'(6a)')ch10,&
299 : : 'Number of bytes for double precision complex /=8 ',ch10,&
300 : : 'Cannot continue due to kind mismatch in BLAS library ',ch10,&
301 : : 'Some BLAS interfaces are not generated by abilint '
302 : : ABI_ERROR(msg)
303 : : end if
304 : 201 : write(msg,'(a,i2,a)')'.Using double precision arithmetic ; gwpc = ',gwp,ch10
305 : : #else
306 : : write(msg,'(a,i2,a)')'.Using single precision arithmetic ; gwpc = ',gwp,ch10
307 : : #endif
308 : 201 : call wrtout(units, msg)
309 : :
310 : 201 : tol_empty=0.01 ! Initialize the tolerance used to decide if a band is empty (passed to m_sigx.F90)
311 : 201 : gwcalctyp=Dtset%gwcalctyp
312 : 201 : gw1rdm=Dtset%gw1rdm ! Input variable to decide if updates to the 1-RDM must be performed
313 : 201 : x1rdm=Dtset%x1rdm ! Input variable to use pure exchange correction on the 1-RDM ( Sigma_x - Vxc )
314 : 201 : rdm_update=(gwcalctyp==21 .and. gw1rdm>0) ! Input variable to decide whether to update GW density matrix
315 : 201 : readchkprdm=(Dtset%irdchkprdm==1) ! Input variable to decide if checkpoint files must be read
316 : 201 : prtchkprdm=(Dtset%prtchkprdm==1) ! Input variable to decide if checkpoint files must be written
317 : :
318 : 201 : mod10 =MOD(Dtset%gwcalctyp,10)
319 : :
320 : : ! Perform some additional checks for hybrid functional calculations
321 [ + + ]: 201 : if (mod10 == 5) then
322 : : !if (Dtset%ixc_sigma<0 .and. .not.libxc_functionals_check()) then
323 : : ! ABI_ERROR('Hybrid functional calculations require the compilation with LIBXC library')
324 : : !end if
325 : : !XG 20171116 : I do not agree with this condition, as one might like to do a one-shot hybrid functional calculation
326 : : !on top of a LDA/GGA calculation ... give the power (and risks) to the user !
327 : : !if(gwcalctyp<10) then
328 : : ! ABI_ERROR('gwcalctyp requires the update of energies and/or wavefunctions when performing hybrid XC calculations')
329 : : !end if
330 [ - + ]: 35 : if (Dtset%usepaw == 1) then
331 : 0 : ABI_ERROR('PAW version of hybrid functional calculations is not implemented')
332 : : end if
333 : : end if
334 : :
335 : : !=== Initialize MPI variables, and parallelization level ===
336 : : ! gwpara: 1--> parallelism over k-points, 2--> parallelism over bands.
337 : : ! In case of gwpara==1 memory is not parallelized.
338 : : ! If gwpara==2, bands are divided among processors but each proc has all the states where GW corrections are required.
339 : 201 : comm = xmpi_world; my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm)
340 : :
341 [ + + ]: 201 : if (my_rank == master) then
342 : 173 : wfk_fname = dtfil%fnamewffk
343 [ - + ]: 173 : if (nctk_try_fort_or_ncfile(wfk_fname, msg) /= 0) then
344 : 0 : ABI_ERROR(msg)
345 : : end if
346 : : end if
347 : 201 : call xmpi_bcast(wfk_fname, master, comm, ierr)
348 : :
349 : : ! === Some variables need to be initialized/nullify at start ===
350 : 201 : usexcnhat = 0
351 : 201 : call KS_energies%init()
352 : 201 : call mkrdim(acell, rprim, rprimd)
353 : 201 : call metric(gmet,gprimd,ab_out,rmet,rprimd,ucvol)
354 : : !
355 : : ! === Define FFT grid(s) sizes ===
356 : : ! Be careful! This mesh is only used for densities, potentials and the matrix elements of v_Hxc. It is NOT the
357 : : ! (usually coarser) GW FFT mesh employed for the oscillator matrix elements that is defined in setmesh.F90.
358 : : ! See also NOTES in the comments at the beginning of this file.
359 : : ! NOTE: This mesh is defined in invars2m using ecutwfn, in GW Dtset%ecut is forced to be equal to Dtset%ecutwfn.
360 : :
361 : : call pawfgr_init(Pawfgr, Dtset, mgfftf, nfftf, ecut_eff, ecutdg_eff, ngfftc, ngfftf, &
362 : 201 : gsqcutc_eff=gsqcutc_eff, gsqcutf_eff=gsqcutf_eff, gmet=gmet, k0=k0)
363 : :
364 : : ! Fake MPI_type for the sequential part.
365 : 201 : call initmpi_seq(MPI_enreg_seq)
366 : 201 : call MPI_enreg_seq%distribfft%init_seq('c',ngfftc(2),ngfftc(3),'all')
367 : 201 : call MPI_enreg_seq%distribfft%init_seq('f',ngfftf(2),ngfftf(3),'all')
368 : :
369 [ + + ]: 402 : call print_ngfft([std_out], ngfftf, header='Dense FFT mesh used for densities and potentials')
370 [ + + ]: 804 : nfftf_tot=PRODUCT(ngfftf(1:3))
371 : :
372 : : ! ===========================================
373 : : ! === Open and read pseudopotential files ===
374 : : ! ===========================================
375 : 201 : call pspini(dtset, dtfil, ecore, psp_gencond, gsqcutc_eff, gsqcutf_eff, pawrad, pawtab, psps, cryst%rprimd, comm_mpi=comm)
376 : :
377 : 201 : call timab(402,2,tsec) ! Init1
378 : : !
379 : : ! ==================================================
380 : : ! ==== Initialize Sigp, epsm1 and basic objects ====
381 : : ! ==================================================
382 : : ! Sigp is completely initialized here.
383 : : ! epsm1 is only initialized with dimensions, (SCR|SUSC) file is read in epsm1%mkdump
384 : 201 : call timab(403,1,tsec) ! setup_sigma
385 : :
386 : : call setup_sigma(codvsn,wfk_fname,acell,rprim,Dtset,Dtfil,Psps,Pawtab,&
387 : 201 : gwx_ngfft,gwc_ngfft,Hdr_wfk,Hdr_sigma,Cryst,Kmesh,Qmesh,ks_ebands,Gsph_Max,Gsph_x,Gsph_c,Vcp,epsm1,Sigp,comm)
388 : :
389 : 201 : call pstat_proc%print(_PSTAT_ARGS_)
390 : :
391 : 201 : call timab(403,2,tsec) ! setup_sigma
392 : 201 : call timab(402,1,tsec) ! Init1
393 : :
394 [ - + ]: 201 : if (nprocs > Sigp%nbnds) then
395 : 0 : write(msg,"(2(a,i0))")"The number of MPI procs: ", nprocs, " is greater than nband: ", sigp%nbnds
396 : 0 : ABI_ERROR(msg)
397 : : end if
398 : :
399 : 201 : pole_screening = .FALSE.
400 [ - + ]: 201 : if (epsm1%fform==2002) then
401 : 0 : pole_screening = .TRUE.
402 : 0 : ABI_WARNING(' EXPERIMENTAL - Using a pole-fit screening!')
403 : : end if
404 : :
405 [ + + ]: 402 : call print_ngfft([std_out], gwc_ngfft, header='FFT mesh for oscillator strengths used for Sigma_c')
406 [ + + ]: 402 : call print_ngfft([std_out], gwx_ngfft, header='FFT mesh for oscillator strengths used for Sigma_x')
407 : :
408 : 201 : b1gw = Sigp%minbdgw; b2gw = Sigp%maxbdgw
409 : :
410 [ + + ]: 804 : gwc_nfftot=PRODUCT(gwc_ngfft(1:3))
411 : : gwc_nfft =gwc_nfftot !no FFT //
412 : :
413 : : gwx_nfftot=PRODUCT(gwx_ngfft(1:3))
414 : : gwx_nfft =gwx_nfftot !no FFT //
415 : :
416 : : ! TRYING TO RECREATE AN "ABINIT ENVIRONMENT"
417 : 201 : KS_energies%e_corepsp=ecore/Cryst%ucvol
418 : :
419 : : ! === Calculate KS occupation numbers and ks_vbk(nkibz,nsppol) ====
420 : : ! * ks_vbk gives the (valence|last Fermi band) index for each k and spin.
421 : : ! * spinmagntarget is passed to fermi.F90 to fix the problem with newocc in case of magnetic metals
422 [ - + + - : 804 : ABI_MALLOC(ks_vbik, (ks_ebands%nkpt, ks_ebands%nsppol))
- + + - +
- + - - +
- + ]
423 [ - + + - : 603 : ABI_MALLOC(qp_vbik, (ks_ebands%nkpt, ks_ebands%nsppol))
- + + - -
+ - + ]
424 : :
425 : : !call ks_ebands%update_occ(Dtset%spinmagntarget,prtvol=0)
426 : 201 : ks_vbik(:,:) = ks_ebands%get_valence_idx()
427 : :
428 : : ! ============================
429 : : ! ==== PAW initialization ====
430 : : ! ============================
431 [ + + ]: 201 : if (dtset%usepaw == 1) then
432 : 5 : call chkpawovlp(cryst%natom, cryst%ntypat, dtset%pawovlp, pawtab, cryst%rmet, cryst%typat, cryst%xred)
433 : :
434 : 5 : cplex_dij = dtset%nspinor; cplex = 1; ndij = 1
435 : :
436 [ - + + - : 46 : ABI_MALLOC(ks_pawrhoij, (cryst%natom))
+ - + - -
+ - + - +
+ + + - -
+ - + - +
- + - + -
+ ]
437 : : call pawrhoij_inquire_dim(cplex_rhoij=cplex_rhoij, nspden_rhoij=nspden_rhoij, &
438 : 5 : nspden=dtset%nspden, spnorb=dtset%pawspnorb, cpxocc=dtset%pawcpxocc)
439 : 5 : call pawrhoij_alloc(ks_pawrhoij, cplex_rhoij, nspden_rhoij, dtset%nspinor, dtset%nsppol, cryst%typat, pawtab=pawtab)
440 : :
441 : : ! Test if we have to call pawinit
442 [ + - + - : 5 : gnt_option = 1; if (dtset%pawxcdev == 2 .or. (dtset%pawxcdev == 1 .and. dtset%positron /= 0)) gnt_option = 2
- + ]
443 : 5 : call paw_gencond(dtset, gnt_option, "test", call_pawinit)
444 : :
445 [ + - - + ]: 5 : if (psp_gencond == 1 .or. call_pawinit) then
446 : 0 : call timab(553, 1, tsec)
447 : 0 : gsqcut_shp = two * abs(dtset%diecut) * dtset%dilatmx**2 / pi**2
448 : : call pawinit(dtset%effmass_free, gnt_option, gsqcut_shp, zero, dtset%pawlcutd, dtset%pawlmix, &
449 : : psps%mpsang, dtset%pawnphi, cryst%nsym, dtset%pawntheta, pawang, pawrad, &
450 : 0 : dtset%pawspnorb, pawtab, dtset%pawxcdev, dtset%ixc, dtset%usepotzero)
451 : 0 : call timab(553,2,tsec)
452 : :
453 : : ! Update internal values
454 : 0 : call paw_gencond(dtset, gnt_option, "save", call_pawinit)
455 : : else
456 [ - + - - ]: 5 : if (pawtab(1)%has_kij ==1) pawtab(1:cryst%ntypat)%has_kij = 2
457 [ - + - - ]: 5 : if (pawtab(1)%has_nabla==1) pawtab(1:cryst%ntypat)%has_nabla = 2
458 : : end if
459 : :
460 [ + + ]: 13 : psps%n1xccc = maxval(pawtab(1:cryst%ntypat)%usetcore)
461 : :
462 : : ! Initialize optional flags in Pawtab to zero
463 : : ! Cannot be done in Pawinit since the routine is called only if some parts are changed
464 [ + + ]: 13 : pawtab(:)%has_nabla = 0
465 [ + + ]: 13 : pawtab(:)%lamb_shielding = zero
466 : :
467 : 5 : call setsym_ylm(gprimd, pawang%l_max-1, cryst%nsym, dtset%pawprtvol, cryst%rprimd, cryst%symrec, pawang%zarot)
468 : :
469 : : ! Initialize and compute data for DFT+U
470 : 5 : Paw_dmft%use_dmft=Dtset%usedmft
471 : : call pawpuxinit(Dtset%dmatpuopt,Dtset%exchmix,Dtset%f4of2_sla,Dtset%f6of2_sla,&
472 : : is_dfpt,Dtset%jpawu,Dtset%lexexch,Dtset%lpawu,dtset%nspinor,Cryst%ntypat,dtset%optdcmagpawu,Pawang,Dtset%pawprtvol,&
473 : 5 : Pawrad,Pawtab,Dtset%upawu,Dtset%usedmft,Dtset%useexexch,Dtset%usepawu,dtset%ucrpa)
474 : :
475 [ + - ]: 5 : if (my_rank == master) call pawtab_print(Pawtab)
476 : :
477 : : ! Get Pawrhoij from the header of the WFK file.
478 : 5 : call pawrhoij_copy(Hdr_wfk%pawrhoij, KS_Pawrhoij)
479 : :
480 : : ! Evaluate form factor of radial part of phi.phj - tphi.tphj.
481 : : ! The q-grid must contain the FFT mesh used for sigma_c and the G-sphere for the exchange part.
482 : : ! We use the FFT mesh for sigma_c since COHSEX and the extrapolar method require oscillator
483 : : ! strengths on the FFT mesh.
484 [ - + + - : 15 : ABI_MALLOC(tmp_gfft,(3, gwc_nfftot))
+ - + - -
+ - + ]
485 : 5 : call get_gfft(gwc_ngfft, k0, gmet, gwc_gsq, tmp_gfft)
486 [ - + ]: 5 : ABI_FREE(tmp_gfft)
487 : :
488 : : ! Set up q-grid, make qmax 20% larger than largest expected.
489 [ - + + - : 15 : ABI_MALLOC(nq_spl, (Psps%ntypat))
+ - + - -
+ - + ]
490 [ - + + - : 15 : ABI_MALLOC(qmax, (Psps%ntypat))
+ - + - -
+ - + ]
491 : 5 : gwx_gsq = Dtset%ecutsigx / (two*pi**2)
492 : 5 : gw_gsq = max(gwx_gsq, gwc_gsq)
493 [ + + ]: 13 : qmax = sqrt(gw_gsq)*1.2d0
494 [ + + ]: 13 : nq_spl = Psps%mqgrid_ff
495 : : ! write(std_out,*)"using nq_spl",nq_spl,"qmax=",qmax
496 : :
497 : 5 : rhoxsp_method = 1 ! Arnaud-Alouani (default in sigma)
498 : : !rhoxsp_method = 2 ! Shiskin-Kresse
499 [ - + ]: 5 : if (dtset%pawoptosc /= 0) rhoxsp_method = dtset%pawoptosc
500 : :
501 [ - + + - : 83 : ABI_MALLOC(paw_pwff, (psps%ntypat))
+ - + - -
+ - + - +
+ + + + +
+ + - - +
- + ]
502 : 5 : call pawpwff_init(paw_pwff, rhoxsp_method, nq_spl, qmax, gmet, pawrad, pawtab, psps)
503 : :
504 [ - + ]: 5 : ABI_FREE(nq_spl)
505 [ - + ]: 5 : ABI_FREE(qmax)
506 : :
507 : : ! Variables/arrays related to the fine FFT grid
508 [ - + + - : 169497 : ABI_CALLOC(ks_nhat, (nfftf, Dtset%nspden))
- + + - +
- + - - +
- + + + +
+ ]
509 : :
510 [ - + + - : 46 : ABI_MALLOC(pawfgrtab, (cryst%natom))
+ - + - -
+ - + - +
+ + + - -
+ - + - +
- + - + -
+ - + -
+ ]
511 : 5 : call pawtab_get_lsize(pawtab, l_size_atm, cryst%natom, cryst%typat)
512 : :
513 : 5 : cplex = 1
514 : 5 : call pawfgrtab_init(Pawfgrtab,cplex,l_size_atm,Dtset%nspden,Dtset%typat)
515 [ - + ]: 5 : ABI_FREE(l_size_atm)
516 : 5 : compch_fft=greatest_real
517 [ + + ]: 13 : usexcnhat = MAXVAL(Pawtab(:)%usexcnhat)
518 : : ! * 0 if Vloc in atomic data is Vbare (Blochl's formulation)
519 : : ! * 1 if Vloc in atomic data is VH(tnzc) (Kresse's formulation)
520 : 5 : call wrtout(std_out, sjoin(' using usexcnhat: ', itoa(usexcnhat)))
521 : : !
522 : : ! Identify parts of the rectangular grid where the density has to be calculated ===
523 : 5 : optcut = 0; optgr0 = Dtset%pawstgylm; optgr1 = 0; optgr2 = 0; optrad = 1 - Dtset%pawstgylm
524 [ - + ]: 5 : if (Dtset%pawcross==1) optrad=1
525 [ - + - - ]: 5 : if (Dtset%xclevel==2.and.usexcnhat>0) optgr1=Dtset%pawstgylm
526 : :
527 : : call nhatgrid(Cryst%atindx1, gmet, Cryst%natom, Cryst%natom, Cryst%nattyp, ngfftf, Cryst%ntypat,&
528 : 5 : optcut, optgr0, optgr1, optgr2, optrad, Pawfgrtab, Pawtab, Cryst%rprimd, Cryst%typat, Cryst%ucvol, Cryst%xred)
529 : :
530 : 20 : call pawfgrtab_print(Pawfgrtab,Cryst%natom,unit=std_out,prtvol=Dtset%pawprtvol)
531 : :
532 : : else
533 [ - + - + ]: 196 : ABI_MALLOC(Paw_pwff, (0))
534 [ - + - + ]: 196 : ABI_MALLOC(Pawfgrtab, (0))
535 : : end if ! End of PAW Initialization
536 : :
537 : : ! Consistency check and additional stuff done only for GW with PAW.
538 [ - + - + ]: 201 : ABI_MALLOC(Paw_onsite, (0))
539 : :
540 [ + + ]: 201 : if (Dtset%usepaw == 1) then
541 [ - + ]: 5 : if (Dtset%ecutwfn < Dtset%ecut) then
542 : : write(msg,"(3a)")&
543 : 0 : " It is highly recommended to use ecutwfn = ecut for GW calculations with PAW since ",ch10,&
544 : 0 : " an excessive truncation of the planewave basis set can lead to unphysical results."
545 : 0 : ABI_WARNING(msg)
546 : : end if
547 : :
548 [ - + ]: 5 : ABI_CHECK(Dtset%useexexch == 0, "LEXX not yet implemented in GW")
549 [ - + ]: 5 : ABI_CHECK(Paw_dmft%use_dmft == 0, "DMFT + GW not available")
550 : :
551 : : ! Optionally read core orbitals from file and calculate $ \<\phi_i|Sigma_x^\core|\phi_j\> $ for the HF decoupling.
552 [ + + ]: 5 : if (Sigp%use_sigxcore == 1) then
553 [ + + ]: 2 : lmn2_size_max=MAXVAL(Pawtab(:)%lmn2_size)
554 [ - + + - : 5 : ABI_MALLOC(dijexc_core,(cplex_dij*lmn2_size_max,ndij,Cryst%ntypat))
- + + - -
+ + - + -
+ - - + -
+ - + ]
555 : :
556 : 1 : call paw_mkdijexc_core(ndij,cplex_dij,lmn2_size_max,Cryst,Pawtab,Pawrad,dijexc_core,Dtset%prtvol,Psps%filpsp)
557 : : end if ! HF decoupling
558 : :
559 [ - + ]: 5 : if (Dtset%pawcross==1) then
560 [ # # # # : 0 : ABI_SFREE(Paw_onsite)
# # # # #
# # # # #
# # ]
561 [ # # # # : 0 : ABI_MALLOC(Paw_onsite,(Cryst%natom))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
562 : : call paw_pwaves_lmn_init(Paw_onsite,Cryst%natom,Cryst%natom,Cryst%ntypat, &
563 : 0 : Cryst%rprimd,Cryst%xcart,Pawtab,Pawrad,Pawfgrtab)
564 : : end if
565 : : end if
566 : :
567 : : ! Allocate these arrays anyway, since they are passed to subroutines.
568 [ + + ]: 201 : if (.not.allocated(ks_nhat)) then
569 [ - + + - : 392 : ABI_MALLOC(ks_nhat, (nfftf, 0))
- + - + -
+ ]
570 : : end if
571 [ + + ]: 201 : if (.not.allocated(dijexc_core)) then
572 [ - + - + ]: 200 : ABI_MALLOC(dijexc_core, (1, 1, 0))
573 : : end if
574 : :
575 : : ! ==================================================
576 : : ! ==== Read KS band structure from the KSS file ====
577 : : ! ==================================================
578 : : !
579 : : ! Initialize Wfd, allocate wavefunctions and precalculate tables to do the FFT using the coarse gwc_ngfft.
580 : 201 : mband=Sigp%nbnds
581 [ - + + - : 1005 : ABI_MALLOC(bks_mask, (mband, Kmesh%nibz, Sigp%nsppol))
- + + - -
+ + - + -
+ - - + -
+ ]
582 [ - + + - : 804 : ABI_MALLOC(keep_ur , (mband, Kmesh%nibz, Sigp%nsppol))
- + + - -
+ + - - +
- + ]
583 [ + + + + : 61415 : keep_ur=.FALSE.; bks_mask=.FALSE.
+ + + + +
+ + + ]
584 : :
585 [ + + ]: 201 : if (rdm_update) then
586 [ - + + - : 20 : ABI_MALLOC(bdm_mask, (mband, Kmesh%nibz, Sigp%nsppol))
- + + - -
+ + - - +
- + ]
587 [ + + + + : 280 : bdm_mask=.FALSE.
+ + ]
588 [ + - ]: 5 : if (my_rank==master) then
589 [ + + + + : 280 : bdm_mask=.TRUE.
+ + ]
590 : : end if
591 [ - + + - : 20 : ABI_MALLOC(bdm2_mask, (mband,Kmesh%nibz,Sigp%nsppol))
- + + - -
+ + - - +
- + ]
592 [ + + + + : 280 : bdm2_mask=.FALSE.
+ + ]
593 : : end if
594 [ - + + - : 804 : ABI_MALLOC(nband,(Kmesh%nibz, Sigp%nsppol))
- + + - +
- + - - +
- + ]
595 [ + + + + ]: 1638 : nband=mband
596 : :
597 : : ! autoparal section
598 [ - + ]: 201 : if (dtset%max_ncpus/=0) then
599 : 0 : ount =ab_out
600 : : ! Temporary table needed to estimate memory
601 [ # # # # : 0 : ABI_MALLOC(nlmn_atm,(Cryst%natom))
# # # # #
# # # ]
602 [ # # ]: 0 : if (Dtset%usepaw==1) then
603 [ # # ]: 0 : do iat=1,Cryst%natom
604 : 0 : nlmn_atm(iat)=Pawtab(Cryst%typat(iat))%lmn_size
605 : : end do
606 : : end if
607 : :
608 : 0 : write(ount,'(a)')"--- !Autoparal"
609 : 0 : write(ount,"(a)")'#Autoparal section for Sigma runs.'
610 : 0 : write(ount,"(a)") "info:"
611 : 0 : write(ount,"(a,i0)")" autoparal: ",dtset%autoparal
612 : 0 : write(ount,"(a,i0)")" max_ncpus: ",dtset%max_ncpus
613 : 0 : write(ount,"(a,i0)")" gwpara: ",dtset%gwpara
614 : 0 : write(ount,"(a,i0)")" nkpt: ",dtset%nkpt
615 : 0 : write(ount,"(a,i0)")" nsppol: ",dtset%nsppol
616 : 0 : write(ount,"(a,i0)")" nspinor: ",dtset%nspinor
617 : 0 : write(ount,"(a,i0)")" nbnds: ",Sigp%nbnds
618 : :
619 : 0 : work_size = mband * Kmesh%nibz * Sigp%nsppol
620 : :
621 : : ! Non-scalable memory in Mb i.e. memory that is not distribute with MPI.
622 : 0 : nonscal_mem = (two*gwp*epsm1%npwe**2*epsm1%nomega*(epsm1%mqmem+1)*b2Mb) * 1.1_dp
623 : :
624 : : ! List of configurations.
625 : : ! Assuming an OpenMP implementation with perfect speedup!
626 : 0 : write(ount,"(a)")"configurations:"
627 [ # # ]: 0 : do ii=1,dtset%max_ncpus
628 : 0 : nstates_per_proc = 0
629 : 0 : eff = HUGE(one)
630 : 0 : max_wfsmem_mb = zero
631 : :
632 [ # # ]: 0 : do my_rank=0,ii-1
633 [ # # ]: 0 : call sigma_bksmask(Dtset,Sigp,Kmesh,my_rank,ii,my_spins,bks_mask,keep_ur,ierr)
634 [ # # ]: 0 : ABI_FREE(my_spins)
635 [ # # ]: 0 : if (ierr /= 0) exit
636 [ # # # # : 0 : my_nbks = COUNT(bks_mask)
# # # # ]
637 : 0 : nstates_per_proc = MAX(nstates_per_proc, my_nbks)
638 : 0 : eff = MIN(eff, (one * work_size) / (ii * nstates_per_proc))
639 : :
640 : : ! Memory needed for Fourier components ug.
641 : 0 : ug_mem = two*gwp*Dtset%nspinor*Sigp%npwwfn*my_nbks*b2Mb
642 : : ! Memory needed for real space ur (use gwc_nfft, instead of gwx_nfft)
643 [ # # # # : 0 : ur_mem = two*gwp*Dtset%nspinor*gwc_nfft*COUNT(keep_ur)*b2Mb
# # # # ]
644 : : ! Memory needed for PAW projections Cprj
645 : 0 : cprj_mem = zero
646 [ # # # # ]: 0 : if (Dtset%usepaw==1) cprj_mem = dp*Dtset%nspinor*SUM(nlmn_atm)*my_nbks*b2Mb
647 : 0 : max_wfsmem_mb = MAX(max_wfsmem_mb, ug_mem + ur_mem + cprj_mem)
648 : : end do
649 [ # # ]: 0 : if (ierr /= 0) cycle
650 : :
651 : : ! Add the non-scalable part and increase by 10% to account for other datastructures.
652 : 0 : mempercpu_mb = (max_wfsmem_mb + nonscal_mem) * 1.1_dp
653 [ # # ]: 0 : do omp_ncpus=1,xomp_get_max_threads()
654 : 0 : write(ount,"(a,i0)")" - tot_ncpus: ",ii * omp_ncpus
655 : 0 : write(ount,"(a,i0)")" mpi_ncpus: ",ii
656 : 0 : write(ount,"(a,i0)")" omp_ncpus: ",omp_ncpus
657 : 0 : write(ount,"(a,f12.9)")" efficiency: ",eff
658 : 0 : write(ount,"(a,f12.2)")" mem_per_cpu: ",mempercpu_mb
659 : : end do
660 : : end do
661 : 0 : write(ount,'(a)')"..."
662 : :
663 [ # # ]: 0 : ABI_FREE(nlmn_atm)
664 : 0 : ABI_ERROR_NODUMP("aborting now")
665 : :
666 : : else
667 [ - + ]: 201 : call sigma_bksmask(Dtset,Sigp,Kmesh,my_rank,nprocs,my_spins,bks_mask,keep_ur,ierr)
668 [ - + ]: 201 : ABI_CHECK(ierr==0, "Error in sigma_bksmask")
669 : : end if
670 : :
671 : : ! Each core stores the wavefunctions where GW corrections are required.
672 [ + + ]: 406 : do isp=1,SIZE(my_spins)
673 : 205 : spin = my_spins(isp)
674 [ + + ]: 1053 : do ikcalc=1,Sigp%nkptgw
675 : 647 : ik_ibz=Kmesh%tab(Sigp%kptgw2bz(ikcalc)) ! Irred k-point for GW
676 : 647 : ii=Sigp%minbnd(ikcalc,spin); jj=Sigp%maxbnd(ikcalc,spin)
677 [ + + ]: 6098 : bks_mask(ii:jj,ik_ibz,spin) = .TRUE.
678 [ + + + + ]: 6154 : if (MODULO(Dtset%gwmem,10)==1) keep_ur(ii:jj,ik_ibz,spin)=.TRUE.
679 : : end do
680 : : end do
681 : :
682 [ - + ]: 201 : ABI_FREE(my_spins)
683 : :
684 : : call wfd%init(Cryst,Pawtab,Psps,keep_ur,mband,nband,Kmesh%nibz,Sigp%nsppol,bks_mask,&
685 : : Dtset%nspden,Dtset%nspinor,Dtset%ecutwfn,Dtset%ecutsm,Dtset%dilatmx,Hdr_wfk%istwfk,Kmesh%ibz,gwc_ngfft,&
686 : 201 : Dtset%nloalg,Dtset%prtvol,Dtset%pawprtvol,comm,use_fnl_dir0der0=(Dtset%gw1rdm==2))
687 : :
688 : : ! MRM: also initialize the Wfd_nato_master for GW 1-RDM if required.
689 : : ! Warning, this should be replaced by copy but copy fails due to bands being allocated in different manners.
690 : : ! FIXME: Do it in the future!
691 [ + + ]: 201 : if (rdm_update) then
692 [ + - + - : 285 : bdm2_mask=bks_mask ! As bks_mask is going to be removed, save it in bdm2_mask to use it in Evext_nl
+ - - + -
- + + + +
+ + ]
693 : : call Wfd_nato_master%init(Cryst,Pawtab,Psps,keep_ur,mband,nband,Kmesh%nibz,Sigp%nsppol,bdm_mask,&
694 : : Dtset%nspden,Dtset%nspinor,Dtset%ecutwfn,Dtset%ecutsm,Dtset%dilatmx,Hdr_wfk%istwfk,Kmesh%ibz,gwc_ngfft,&
695 : 5 : Dtset%nloalg,Dtset%prtvol,Dtset%pawprtvol,xmpi_comm_self)!comm) ! MPI_COMM_SELF
696 : 5 : call Wfd_nato_master%read_wfk(wfk_fname,iomode_from_fname(wfk_fname))
697 : : end if
698 : :
699 : 201 : call timab(402,2,tsec) ! sigma(Init1)
700 : 201 : call timab(404,1,tsec) ! rdkss
701 : :
702 : 201 : call wfd%read_wfk(wfk_fname, iomode_from_fname(wfk_fname))
703 : : ! This test has been disabled (too expensive!)
704 : : if (.False.) call wfd%test_ortho(Cryst,Pawtab,unit=ab_out,mode_paral="COLL")
705 : :
706 : : ! FD check of GWPT: the matrix elements of Sigma and V_xc are taken between the frozen states of SC_WFK.
707 : : ! userie 456: the energies in G0 are those of SC_WFK too. userie 458: those of the WFK file (GWPT with userra 1).
708 [ + - + - : 201 : if (Dtset%pawcross==1 .or. dtset%userie == 456 .or. dtset%userie == 458) then
- + ]
709 : : call Wfdf%init(Cryst,Pawtab,Psps,keep_ur,mband,nband,Kmesh%nibz,Sigp%nsppol,bks_mask,&
710 : : Dtset%nspden,Dtset%nspinor,dtset%ecutwfn,Dtset%ecutsm,Dtset%dilatmx,Hdr_wfk%istwfk,Kmesh%ibz,gwc_ngfft,&
711 : 0 : Dtset%nloalg,Dtset%prtvol,Dtset%pawprtvol,comm)
712 [ # # ]: 0 : if (dtset%userie == 456 .or. dtset%userie == 458) then
713 : 0 : call wrtout(std_out, "Reading states from supercell WFK file")
714 : 0 : call wfdf%read_wfk("SC_WFK", iomode_from_fname("SC_WFK"))
715 : : else
716 : 0 : call wfdgw_copy(Wfd, Wfdf)
717 : : end if
718 : 0 : call wfdf%change_ngfft(Cryst, Psps, ngfftf)
719 [ # # ]: 0 : if (dtset%userie == 456 .or. dtset%userie == 458) call wfdf%print(units, "UNPERTURBED WFDF for GWTPT")
720 : : end if
721 : :
722 : 201 : call pstat_proc%print(_PSTAT_ARGS_)
723 : 201 : call timab(404,2,tsec) ! rdkss
724 : 201 : call timab(405,1,tsec) ! Init2
725 : :
726 [ - + ]: 201 : ABI_FREE(bks_mask)
727 [ - + ]: 201 : ABI_FREE(nband)
728 [ - + ]: 201 : ABI_FREE(keep_ur)
729 : :
730 : : ! ==============================================================
731 : : ! ==== Find little group of the k-points for GW corrections ====
732 : : ! ==============================================================
733 : : ! The little group is used only if symsigma == 1
734 : : ! If use_umklp == 1 then symmetries requiring an umklapp to preserve k_gw are included as well.
735 [ - + + - : 1242 : ABI_MALLOC(Ltg_k, (Sigp%nkptgw))
+ - + - -
+ - + + +
+ - - + -
+ - + - +
- + - + -
+ - + - +
- + - + ]
736 : 201 : use_umklp = 1
737 [ + + ]: 840 : do ikcalc=1,Sigp%nkptgw
738 [ + + ]: 840 : if (Sigp%symsigma /= 0) call Ltg_k(ikcalc)%init(Sigp%kptgw(:,ikcalc), Qmesh%nbz, Qmesh%bz, Cryst, use_umklp, npwe=0)
739 : : end do
740 : :
741 : : ! Compute structure factor phases and large sphere cut-off
742 [ + - - + : 603 : ABI_MALLOC(ph1d,(2, 3 * (2 * Dtset%mgfft + 1) * Cryst%natom))
+ - + - +
- - + - +
- + ]
743 [ + - - + : 603 : ABI_MALLOC(ph1df,(2, 3 * (2 * mgfftf + 1) * Cryst%natom))
+ - + - +
- - + - +
- + ]
744 : :
745 : 201 : call getph(Cryst%atindx,Cryst%natom,ngfftc(1),ngfftc(2),ngfftc(3),ph1d,Cryst%xred)
746 : :
747 [ + + + + ]: 201 : if (Psps%usepaw == 1.and. Pawfgr%usefinegrid == 1) then
748 : 2 : call getph(Cryst%atindx,Cryst%natom,ngfftf(1),ngfftf(2),ngfftf(3),ph1df,Cryst%xred)
749 : : else
750 [ + + + + ]: 170362 : ph1df(:,:)=ph1d(:,:)
751 : : end if
752 : :
753 : : !===================================================================================
754 : : !==== Classify the GW wavefunctions according to the irreducible representation ====
755 : : !===================================================================================
756 : : !* Warning still under development.
757 : : !* Only for SCGW.
758 : : !bmin=Sigp%minbdgw; bmax=Sigp%maxbdgw
759 : :
760 [ - + + - : 2241 : ABI_MALLOC(KS_sym,(Wfd%nkibz,Wfd%nsppol))
- + + - +
- + - - +
- + + + +
+ + - - +
- + - + -
+ - + - +
- + - + -
- - - - +
- + - + -
- - - - -
- + - - -
- - - - +
- - - - -
- ]
761 : :
762 [ + + - + ]: 201 : if (Sigp%symsigma==1.and.gwcalctyp>=20) then
763 : : ! call check_zarot(Gsph_c%ng,Cryst,gwc_ngfft,Gsph_c%gvec,Psps,Pawang,Gsph_c%rottb,Gsph_c%rottbm1)
764 : 0 : use_paw_aeur=.FALSE. ! should pass ngfftf but the dense mesh is not forced to be symmetric
765 [ # # ]: 0 : do spin=1,Wfd%nsppol
766 [ # # ]: 0 : do ikcalc=1,Sigp%nkptgw
767 : 0 : ik_ibz = Kmesh%tab(Sigp%kptgw2bz(ikcalc))
768 : 0 : first_band = Sigp%minbnd(ikcalc,spin)
769 : 0 : last_band = Sigp%maxbnd(ikcalc,spin)
770 : : call classify_bands(Wfd,use_paw_aeur,first_band,last_band,ik_ibz,spin,Wfd%ngfft,Cryst,ks_ebands,Pawtab,Pawrad,Pawang,Psps,&
771 : 0 : Dtset%tolsym,KS_sym(ik_ibz,spin))
772 : : end do
773 : : end do
774 : : ! Recreate the Sig_ij tables taking advantage of the classification of the bands.
775 : 0 : call sigma_tables(Sigp,Kmesh, esymm=KS_sym)
776 : : end if
777 : :
778 : 201 : call timab(405,2,tsec) ! Init2
779 : 201 : call timab(406,1,tsec) ! make_vhxc
780 : :
781 : : !===========================
782 : : !=== COMPUTE THE DENSITY ===
783 : : !===========================
784 : : ! Evaluate the planewave part (complete charge in case of NC pseudos).
785 [ - + + - : 804 : ABI_MALLOC(ks_rhor, (nfftf, dtset%nspden))
- + + - +
- + - - +
- + ]
786 [ - + + - : 804 : ABI_MALLOC(ks_taur, (nfftf, dtset%nspden * dtset%usekden))
+ - - - +
- - + - +
- + ]
787 : :
788 : 201 : call wfd%mkrho(cryst, psps, ks_ebands, ngfftf, nfftf, ks_rhor)
789 : :
790 [ + + + - : 201 : if ((rdm_update .and. Dtset%prtden /= 0) .and. Wfd%my_rank == master) then
+ - ]
791 : : ! Print initial (KS) density file as read (useful to compare DEN files, cubes, etc.)
792 : 5 : gw1rdm_fname = trim(dtfil%fnameabo_ks_den) ! and used on Sigma grids
793 : : call fftdatar_write("density",gw1rdm_fname,dtset%iomode,hdr_sigma,&
794 : 5 : Cryst,ngfftf,cplex1,nfftf,dtset%nspden,ks_rhor,mpi_enreg_seq,ebands=ks_ebands)
795 : : end if
796 : :
797 [ - + ]: 201 : if (Dtset%usekden == 1) call wfd%mkrho(cryst, psps, ks_ebands, ngfftf, nfftf, ks_taur, optcalc=1)
798 : :
799 : : !========================================
800 : : !==== Additional computation for PAW ====
801 : : !========================================
802 : 201 : nhatgrdim = 0
803 [ + + ]: 201 : if (Dtset%usepaw==1) then
804 : : ! Get electronic temperature from dtset
805 [ - + - - : 5 : el_temp=merge(dtset%tphysel,dtset%tsmear,dtset%tphysel>tol8.and.dtset%occopt/=3.and.dtset%occopt/=9)
- - ]
806 : : ! Calculate the compensation charge nhat.
807 [ - + ]: 5 : if (Dtset%xclevel==2) nhatgrdim = usexcnhat * Dtset%pawnhatxc
808 : 5 : cplex = 1; ider = 2 * nhatgrdim; izero = 0
809 [ - + ]: 5 : if (nhatgrdim > 0) then
810 [ # # # # : 0 : ABI_MALLOC(ks_nhatgr,(nfftf,Dtset%nspden,3*nhatgrdim))
# # # # #
# # # # #
# # # # #
# # # ]
811 : : end if
812 [ + - ]: 5 : if (nhatgrdim == 0) then
813 [ - + - + ]: 5 : ABI_MALLOC(ks_nhatgr,(0,0,0))
814 : : end if
815 : :
816 : : call pawmknhat(compch_fft,cplex,ider,idir0,ipert0,izero,Cryst%gprimd,&
817 : : Cryst%natom,Cryst%natom,nfftf,ngfftf,nhatgrdim,Dtset%nspden,Cryst%ntypat,Pawang,&
818 : : Pawfgrtab,ks_nhatgr,ks_nhat,KS_Pawrhoij,KS_Pawrhoij,Pawtab,k0,Cryst%rprimd,&
819 : 5 : Cryst%ucvol,dtset%usewvl,Cryst%xred)
820 : :
821 : : ! === Evaluate onsite energies, potentials, densities ===
822 : : ! * Initialize variables/arrays related to the PAW spheres.
823 : : ! * Initialize also lmselect (index of non-zero LM-moments of densities).
824 [ - + + - : 46 : ABI_MALLOC(KS_paw_ij, (Cryst%natom))
+ - + - -
+ - + - +
+ + + - -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ ]
825 [ - + ]: 5 : has_dijso = Dtset%pawspnorb; has_dijU = merge(0, 1, Dtset%usepawu == 0)
826 : :
827 : 5 : call paw_ij_nullify(KS_paw_ij)
828 : : call paw_ij_init(KS_paw_ij,cplex,Dtset%nspinor,Dtset%nsppol,&
829 : : Dtset%nspden,Dtset%pawspnorb,Cryst%natom,Cryst%ntypat,Cryst%typat,Pawtab,&
830 : : has_dij=1,has_dijhartree=1,has_dijhat=1,has_dijxc=1,has_dijxc_hat=1,has_dijxc_val=1,&
831 : 5 : has_dijso=has_dijso,has_dijU=has_dijU,has_exexch_pot=1,has_pawu_occ=1)
832 : :
833 : 5 : nkxc1 = 0
834 [ - + + - : 46 : ABI_MALLOC(KS_paw_an, (Cryst%natom))
+ - + - -
+ - + - +
+ + + - -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + ]
835 : 5 : call paw_an_nullify(KS_paw_an)
836 : : call paw_an_init(KS_paw_an,Cryst%natom,Cryst%ntypat,nkxc1,0,Dtset%nspden,&
837 : 5 : cplex,Dtset%pawxcdev,Cryst%typat,Pawang,Pawtab,has_vxc=1,has_vxcval=1)
838 : :
839 : : ! Calculate onsite vxc with and without core charge.
840 : 5 : nzlmopt=-1; option=0; compch_sph=greatest_real
841 : : call pawdenpot(compch_sph,el_temp,Cryst%gprimd,ipert0,Dtset%ixc,Cryst%natom,Cryst%natom,Dtset%nspden,&
842 : : Cryst%ntypat,Dtset%nucdipmom,nzlmopt,option,KS_Paw_an,KS_Paw_an,KS_energies%paw,KS_paw_ij,&
843 : : Pawang,Dtset%pawprtvol,Pawrad,KS_Pawrhoij,Dtset%pawspnorb,Pawtab,Dtset%pawxcdev,&
844 : 5 : Dtset%spnorbscl,Dtset%xclevel,Dtset%xc_denpos,Dtset%xc_taupos,Cryst%xred,Cryst%ucvol,Psps%znuclpsp,Dtset%spinaxis)
845 : :
846 : : else
847 [ - + - + ]: 196 : ABI_MALLOC(ks_nhatgr, (0, 0, 0))
848 [ - + - + ]: 196 : ABI_MALLOC(KS_paw_ij, (0))
849 [ - + - + ]: 196 : ABI_MALLOC(KS_paw_an, (0))
850 : : end if ! PAW
851 : :
852 : : call test_charge(nfftf,ks_ebands%nelect,Dtset%nspden,ks_rhor,Cryst%ucvol,&
853 : 201 : Dtset%usepaw,usexcnhat,Pawfgr%usefinegrid,compch_sph,compch_fft,drude_plsmf)
854 : :
855 : : ! For PAW, add the compensation charge on the FFT mesh, then get rho(G).
856 [ + + - + : 169683 : if (Dtset%usepaw==1) ks_rhor = ks_rhor + ks_nhat
+ + + + ]
857 : :
858 : 201 : call prtrhomxmn(std_out,MPI_enreg_seq,nfftf,ngfftf,Dtset%nspden,1,ks_rhor,ucvol=ucvol)
859 [ - + ]: 201 : if (Dtset%usekden==1) call prtrhomxmn(std_out,MPI_enreg_seq,nfftf,ngfftf,Dtset%nspden,1,ks_taur,optrhor=1,ucvol=ucvol)
860 : :
861 : : ! FFT n(r) --> n(g)
862 [ - + + - : 603 : ABI_MALLOC(ks_rhog, (2, nfftf))
+ - + - -
+ - + ]
863 : 201 : call fourdp(1, ks_rhog, ks_rhor(:,1),-1, MPI_enreg_seq, nfftf, 1, ngfftf, tim_fourdp5)
864 : :
865 : : ! The following steps have been gathered in the setvtr routine:
866 : : ! - get Ewald energy and Ewald forces
867 : : ! - compute local ionic pseudopotential vpsp
868 : : ! - eventually compute 3D core electron density xccc3d
869 : : ! - eventually compute vxc and vhartr
870 : : ! - set up ks_vtrial
871 : : !
872 : : !*******************************************************************
873 : : !**** NOTE THAT HERE Vxc CONTAINS THE CORE-DENSITY CONTRIBUTION ****
874 : : !*******************************************************************
875 : :
876 : 201 : ngrvdw = 0
877 [ - + ]: 201 : ABI_MALLOC(grvdw, (3, ngrvdw))
878 [ - + + - : 603 : ABI_MALLOC(grchempottn, (3, Cryst%natom))
+ - + - -
+ - + ]
879 [ - + + - : 402 : ABI_MALLOC(grewtn, (3, Cryst%natom))
- + - + ]
880 : 201 : nkxc = 0
881 [ + + ]: 201 : if (Dtset%nspden == 1) nkxc = 2
882 [ + + ]: 201 : if (Dtset%nspden >= 2) nkxc = 3 ! check GGA and spinor, quite a messy part!!!
883 : : ! In case of MGGA, fxc and kxc are not available and we dont need them in sigma (for now ...)
884 [ + + - + ]: 201 : if (Dtset%ixc < 0 .and. libxc_functionals_ismgga()) nkxc = 0
885 [ + - ]: 201 : if (nkxc /= 0) then
886 [ - + + - : 804 : ABI_MALLOC(kxc, (nfftf, nkxc))
- + + - +
- + - - +
- + ]
887 : : end if
888 : :
889 [ + + ]: 201 : n3xccc = 0; if (Psps%n1xccc /= 0) n3xccc = nfftf
890 [ + + + - : 603 : ABI_MALLOC(xccc3d, (n3xccc))
+ - + + -
+ - + ]
891 [ - + + - : 603 : ABI_MALLOC(ks_vhartr, (nfftf))
+ - + - -
+ - + ]
892 [ - + + - : 804 : ABI_MALLOC(ks_vtrial, (nfftf, Dtset%nspden))
- + + - +
- + - - +
- + ]
893 [ - + + - : 402 : ABI_MALLOC(vpsp, (nfftf))
- + - + ]
894 [ - + + - : 603 : ABI_MALLOC(ks_vxc, (nfftf, Dtset%nspden))
- + + - -
+ - + -
+ ]
895 : :
896 : 201 : optene = 4; moved_atm_inside = 0; moved_rhor = 0; istep = 1
897 : :
898 : : call setvtr(Cryst%atindx1,Dtset,KS_energies,gmet,gprimd,grchempottn,grewtn,grvdw,gsqcutf_eff,&
899 : : istep,kxc,mgfftf,moved_atm_inside,moved_rhor,MPI_enreg_seq,&
900 : : Cryst%nattyp,nfftf,ngfftf,ngrvdw,ks_nhat,ks_nhatgr,nhatgrdim,nkxc,Cryst%ntypat,Psps%n1xccc,n3xccc,&
901 : : optene,Pawang,Pawrad,KS_Pawrhoij,Pawtab,ph1df,Psps,ks_rhog,ks_rhor,Cryst%rmet,Cryst%rprimd,strsxc,&
902 : 201 : Cryst%ucvol,usexcnhat,ks_vhartr,vpsp,ks_vtrial,ks_vxc,vxcavg,Wvl,xccc3d,Cryst%xred,taur=ks_taur)
903 : :
904 : : !============================
905 : : !==== Compute KS PAW Dij ====
906 : : !============================
907 [ + + ]: 201 : if (Dtset%usepaw == 1) then
908 : 5 : call timab(561,1,tsec)
909 : :
910 : : ! Calculate the unsymmetrized Dij.
911 : : call pawdij(cplex,Dtset%enunit,Cryst%gprimd,ipert0,&
912 : : Cryst%natom,Cryst%natom,nfftf,ngfftf(1)*ngfftf(2)*ngfftf(3),&
913 : : Dtset%nspden,Cryst%ntypat,KS_paw_an,KS_paw_ij,Pawang,Pawfgrtab,&
914 : : Dtset%pawprtvol,Pawrad,KS_Pawrhoij,Dtset%pawspnorb,Pawtab,Dtset%pawxcdev,&
915 : : k0,Dtset%spnorbscl,Cryst%ucvol,dtset%cellcharge(1),&
916 : : ks_vtrial,ks_vxc,Cryst%xred,Dtset%znucl,&
917 : 5 : nucdipmom=Dtset%nucdipmom,spinaxis=Dtset%spinaxis)
918 : :
919 : : ! Symmetrize KS Dij
920 : : call symdij_all(Cryst%gprimd,Cryst%indsym,ipert0,&
921 : : Cryst%natom,Cryst%natom,Cryst%nsym,Cryst%ntypat,KS_paw_ij,Pawang,&
922 : 5 : Dtset%pawprtvol,Pawtab,Cryst%rprimd,Cryst%symafm,Cryst%symrec)
923 : :
924 : : ! Output the pseudopotential strengths Dij and the augmentation occupancies Rhoij.
925 : 5 : call pawprt(Dtset,Cryst%natom,KS_paw_ij,KS_Pawrhoij,Pawtab)
926 : 5 : call timab(561,2,tsec)
927 : : end if
928 : :
929 : 201 : call timab(406,2,tsec) ! make_vhxc
930 : :
931 : : !=== Calculate Vxc(b1,b2,k,s)=<b1,k,s|v_{xc}|b2,k,s> for all the states included in GW ===
932 : : ! * This part is parallelized within wfd%comm since each node has all GW wavefunctions.
933 : : ! * Note that vH matrix elements are calculated using the true uncutted interaction.
934 : 201 : call timab(407,1,tsec) ! vHxc_me
935 : :
936 : 201 : call KS_mflags%reset()
937 [ + + ]: 201 : if (rdm_update) then
938 : 5 : KS_mflags%has_hbare=1
939 : 5 : KS_mflags%has_kinetic=1
940 : : end if
941 : 201 : KS_mflags%has_vhartree=1
942 : 201 : KS_mflags%has_vxc =1
943 : 201 : KS_mflags%has_vxcval =1
944 [ - + ]: 201 : if (Dtset%usepawu /= 0 ) KS_mflags%has_vu = 1
945 [ - + ]: 201 : if (Dtset%useexexch /= 0) KS_mflags%has_lexexch= 1
946 [ + + ]: 201 : if (Sigp%use_sigxcore == 1) KS_mflags%has_sxcore = 1
947 [ + + ]: 201 : if (gwcalctyp<10 ) KS_mflags%only_diago = 1 ! off-diagonal elements only for SC on wavefunctions.
948 : :
949 : : if (.FALSE.) then ! quick and dirty hack to test HF contribution.
950 : : ABI_WARNING("testing on-site HF")
951 : : lmn2_size_max=MAXVAL(Pawtab(:)%lmn2_size)
952 : : ABI_MALLOC(dij_hf,(cplex_dij*lmn2_size_max,ndij,Cryst%natom))
953 : : call paw_dijhf(ndij,cplex_dij,1,lmn2_size_max,Cryst%natom,Cryst%ntypat,Pawtab,Pawrad,Pawang,&
954 : : KS_Pawrhoij,dij_hf,Dtset%prtvol)
955 : :
956 : : do iat=1,Cryst%natom
957 : : itypat = Cryst%typat(iat)
958 : : ii = Pawtab(itypat)%lmn2_size
959 : : KS_Paw_ij(iat)%dijxc(:,:) = dij_hf(1:cplex_dij*ii,:,iat)
960 : : KS_Paw_ij(iat)%dijxc_hat(:,:) = zero
961 : : end do
962 : : ABI_FREE(dij_hf)
963 : :
964 : : !option_dij=3
965 : : !call symdij(Cryst%gprimd,Cryst%indsym,ipert0,&
966 : : !& Cryst%natom,Cryst%nsym,Cryst%ntypat,option_dij,&
967 : : !& KS_paw_ij,Pawang,Dtset%pawprtvol,Pawtab,Cryst%rprimd,&
968 : : !& Cryst%symafm,Cryst%symrec)
969 : : end if
970 : :
971 [ - + + - : 804 : ABI_MALLOC(tmp_kstab, (2, Wfd%nkibz, Wfd%nsppol))
- + + - +
- + - - +
- + ]
972 [ + + + + : 4102 : tmp_kstab=0
+ + ]
973 [ + + ]: 406 : do spin=1,Sigp%nsppol
974 [ + + ]: 1053 : do ikcalc=1,Sigp%nkptgw ! No spin dependent!
975 : 647 : ik_ibz = Kmesh%tab(Sigp%kptgw2bz(ikcalc))
976 : 647 : tmp_kstab(1, ik_ibz, spin) = Sigp%minbnd(ikcalc, spin)
977 : 852 : tmp_kstab(2, ik_ibz, spin) = Sigp%maxbnd(ikcalc, spin)
978 : : end do
979 : : end do
980 : :
981 [ - + ]: 201 : if (dtset%userie == 456 .or. dtset%userie == 458) then
982 : 0 : call wrtout(std_out, "Computing KS vxc matrix elements using supercell WFK file")
983 : : call calc_vhxc_me(Wfdf, KS_mflags, KS_me, Cryst, Dtset, nfftf, ngfftf, &
984 : : ks_vtrial, ks_vhartr, ks_vxc, Psps, Pawtab, KS_paw_an, Pawang, Pawfgrtab, KS_paw_ij, dijexc_core, &
985 : 0 : ks_rhor, usexcnhat, ks_nhat, ks_nhatgr, nhatgrdim, tmp_kstab, taur=ks_taur)
986 : : else
987 : :
988 : : call calc_vhxc_me(Wfd, KS_mflags, KS_me, Cryst, Dtset, nfftf, ngfftf, &
989 : : ks_vtrial, ks_vhartr, ks_vxc, Psps, Pawtab, KS_paw_an, Pawang, Pawfgrtab, KS_paw_ij, dijexc_core, &
990 : 201 : ks_rhor, usexcnhat, ks_nhat, ks_nhatgr, nhatgrdim, tmp_kstab, taur=ks_taur)
991 : : end if
992 [ - + ]: 201 : ABI_FREE(tmp_kstab)
993 : :
994 : : ! Set KS matrix elements connecting different irreps to zero. Do not touch unknown bands!.
995 [ + + - + ]: 201 : if (gwcalctyp >= 20 .and. Sigp%symsigma > 0) then
996 : 0 : bmin=Sigp%minbdgw; bmax=Sigp%maxbdgw
997 [ # # # # : 0 : ABI_MALLOC(ks_irreptab,(bmin:bmax,Kmesh%nibz,Sigp%nsppol))
# # # # #
# # # # #
# # # # #
# ]
998 [ # # # # : 0 : ks_irreptab=0
# # ]
999 [ # # ]: 0 : do spin=1,Sigp%nsppol
1000 [ # # ]: 0 : do ikcalc=1,Sigp%nkptgw
1001 : 0 : ik_ibz = Kmesh%tab(Sigp%kptgw2bz(ikcalc))
1002 : 0 : first_band = Sigp%minbnd(ikcalc,spin)
1003 : 0 : last_band = Sigp%maxbnd(ikcalc,spin)
1004 [ # # ]: 0 : if (.not. KS_sym(ik_ibz,spin)%failed()) then
1005 [ # # ]: 0 : ks_irreptab(first_band:last_band,ik_ibz,spin) = KS_sym(ik_ibz,spin)%b2irrep(first_band:last_band)
1006 : : !ks_irreptab(bmin:bmax,ik_ibz,spin) = KS_sym(ik_ibz,spin)%b2irrep(bmin:bmax)
1007 : : end if
1008 : : end do
1009 : : end do
1010 : 0 : call KS_me%zero(ks_irreptab)
1011 [ # # ]: 0 : ABI_FREE(ks_irreptab)
1012 : : end if
1013 : :
1014 : 201 : call KS_me%print(header="Matrix elements in the KS basis set", prtvol=Dtset%prtvol)
1015 : :
1016 : : ! If possible, calculate the EXX energy between the frozen core
1017 : : ! and the valence electrons using KS wavefunctions
1018 : : ! MG: Be careful here, since ex_energy is meaningful only if all occupied states are calculated.
1019 [ + + ]: 201 : if (KS_mflags%has_sxcore ==1) then
1020 : : ! TODO
1021 : : !ex_energy = mels_get_exene_core(KS_me,kmesh,ks_ebands)
1022 : 1 : ex_energy=zero
1023 [ + + ]: 2 : do spin=1,Sigp%nsppol
1024 [ + + ]: 21 : do ik=1,Kmesh%nibz
1025 [ + + ]: 153 : do ib=b1gw,b2gw
1026 [ + - ]: 152 : if (Sigp%nsig_ab==1) then
1027 : 133 : ex_energy = ex_energy + half*ks_ebands%occ(ib,ik,spin)*Kmesh%wt(ik)*KS_me%sxcore(ib,ib,ik,spin)
1028 : : else
1029 [ # # ]: 0 : ex_energy = ex_energy + half*ks_ebands%occ(ib,ik,spin)*Kmesh%wt(ik)*SUM(KS_me%sxcore(ib,ib,ik,:))
1030 : : end if
1031 : : end do
1032 : : end do
1033 : : end do
1034 : 1 : write(msg,'(a,2(es16.6,a))')' CORE Exchange energy with KS wavefunctions: ',ex_energy,' Ha ,',ex_energy*Ha_eV,' eV'
1035 : 1 : call wrtout(std_out, msg)
1036 : : end if
1037 : :
1038 : 201 : call timab(407,2,tsec) ! vHxc_me
1039 : 201 : call timab(408,1,tsec) ! hqp_init
1040 : :
1041 : : ! Do not break this coding!
1042 : : ! When gwcalctyp>10, the order of the bands can be exchanged after
1043 : : ! the diagonalization. Therefore, we have to correctly assign the matrix elements to the corresponding
1044 : : ! bands and we cannot skip the following even though it looks useless.
1045 [ + + ]: 201 : if (gwcalctyp >= 10) call wrtout(std_out, ch10//' *************** KS Energies *******************')
1046 : :
1047 : : !=== qp_ebands stores energies and occ. used for the calculation ===
1048 : : ! * Initialize qp_ebands with KS values.
1049 : : ! * In case of SC update qp_ebands using the QPS file.
1050 : 201 : call ks_ebands%copy(qp_ebands)
1051 : :
1052 [ - + + - : 804 : ABI_MALLOC(qp_rhor, (nfftf, Dtset%nspden))
- + + - +
- + - - +
- + ]
1053 [ - + + - : 804 : ABI_MALLOC(qp_taur, (nfftf, Dtset%nspden * Dtset%usekden))
+ - - - +
- - + - +
- + ]
1054 : 201 : QP_sym => KS_sym
1055 : :
1056 [ + + ]: 201 : if (gwcalctyp<10) then
1057 : : ! one-shot GW, just do a copy of the KS density.
1058 [ + - + - : 1095499 : qp_rhor=ks_rhor
- + - - +
+ + + ]
1059 [ - + - - : 125 : if(Dtset%usekden==1)qp_taur=ks_taur
- - - - -
- - - -
- ]
1060 : : QP_sym => KS_sym
1061 : : else
1062 : : ! Self-consistent GW.
1063 : : ! Read the unitary matrix and the QP energies of the previous step from the QPS file.
1064 : 76 : call QP_energies%init()
1065 : 76 : QP_energies%e_corepsp=ecore/Cryst%ucvol
1066 : :
1067 : : ! m_ks_to_qp(ib,jb,k,s) := <\psi_{ib,k,s}^{KS}|\psi_{jb,k,s}^{QP}>
1068 : : ! Initialize the QP amplitudes with KS wavefunctions.
1069 [ - + + - : 456 : ABI_MALLOC(Sr%m_ks_to_qp, (Sigp%nbnds, Sigp%nbnds, Kmesh%nibz, Sigp%nsppol))
- + + - -
+ + - - +
+ - + - +
- - + - +
- + ]
1070 [ + + + + : 73347 : Sr%m_ks_to_qp=czero
+ + + + ]
1071 [ + + ]: 986 : do ib=1,Sigp%nbnds
1072 [ + + + + ]: 7162 : Sr%m_ks_to_qp(ib,ib,:,:)=cone
1073 : : end do
1074 : :
1075 : : ! Now read m_ks_to_qp and update the energies in qp_ebands.
1076 : : ! TODO switch on the renormalization of n in sigma.
1077 [ - + + - : 304 : ABI_MALLOC(prev_rhor, (nfftf, Dtset%nspden))
- + + - +
- + - - +
- + ]
1078 [ - + + - : 304 : ABI_MALLOC(prev_taur, (nfftf, Dtset%nspden*Dtset%usekden))
+ - - - +
- - + - +
- + ]
1079 [ + - - - : 228 : ABI_MALLOC(prev_Pawrhoij, (Cryst%natom*Psps%usepaw))
+ - - + -
+ - + - +
- + - - -
- - - - -
- - - - -
- ]
1080 : :
1081 : : call rdqps(qp_ebands,Dtfil%fnameabi_qps,Dtset%usepaw,Dtset%nspden,1,nscf,&
1082 : 76 : nfftf,ngfftf,Cryst%ucvol,Cryst,Pawtab,MPI_enreg_seq,nbsc,Sr%m_ks_to_qp,prev_rhor,prev_Pawrhoij)
1083 : :
1084 : : !Find the irreps associated to the QP amplitudes starting from the analogous table for the KS states.
1085 : : !bmin=Sigp%minbdgw; bmax=Sigp%maxbdgw
1086 : : !allocate(qp_irreptab(bmin:bmax,Kmesh%nibz,Sigp%nsppol))
1087 : : !qp_irreptab=0
1088 : : !!qp_irreptab=ks_irreptab
1089 : :
1090 : : !do jb_qp=bmin,bmax
1091 : : !do ib_ks=bmin,bmax
1092 : : !if (ABS(Sr%m_ks_to_qp(ib_ks,jb_qp,ik_ibz,spin)) > tol12) then ! jb_qp has same the same character as ib_ks.
1093 : : !ks_irr = ks_irreptab(ib_ks,ib_ks,ik_ibz,spin)
1094 : : !qp_irreptab(jb_qp,jb_qp,ik_ibz,spin) = ks_irr
1095 : : !do ii=bmin,bmax
1096 : : !if (ks_irr == ks_irreptab(ii,ib_ks,ik_ibz,spin)) then
1097 : : !qp_irreptab(jb_qp,ii,ik_ibz,spin) = ks_irr
1098 : : !end if
1099 : : !end do
1100 : : !end if
1101 : : !end do
1102 : : !end do
1103 : :
1104 [ + + + - : 1163604 : if (nscf==0) prev_rhor=ks_rhor
+ - - + -
- + + +
+ ]
1105 [ + + - + : 76 : if (nscf==0 .and. Dtset%usekden==1) prev_taur=ks_taur
- - - - -
- - - - -
- - ]
1106 : :
1107 [ + + + + : 76 : if (nscf>0.and.gwcalctyp>=20.and. wfd%my_rank == master) then
+ + ]
1108 : : ! Print the unitary transformation on std_out.
1109 : 28 : call show_QP(qp_ebands,Sr%m_ks_to_qp,fromb=Sigp%minbdgw,tob=Sigp%maxbdgw,unit=std_out,tolmat=0.001_dp)
1110 : : end if
1111 : :
1112 : : ! Compute QP wfg as linear combination of KS states.
1113 : : ! * Wfd%ug is modified inside calc_wf_qp
1114 : : ! * For PAW, update also the on-site projections.
1115 : : ! * WARNING the first dimension of MPI_enreg MUST be Kmesh%nibz
1116 : : ! TODO here we should use nbsc instead of nbnds
1117 : :
1118 : 76 : call wfd%rotate(Cryst, Sr%m_ks_to_qp)
1119 : :
1120 : : ! Reinit the storage mode of Wfd as ug have been changed ===
1121 : : ! Update also the wavefunctions for GW corrections on each processor
1122 : 76 : call wfd%reset_ur_cprj()
1123 : :
1124 : : ! This test has been disabled (too expensive!)
1125 : : if (.False.) call wfd%test_ortho(Cryst, Pawtab, unit=std_out)
1126 : :
1127 : : ! Compute QP occupation numbers.
1128 : 76 : call wrtout(std_out,'sigma: calculating QP occupation numbers:')
1129 : 76 : call qp_ebands%update_occ(Dtset%spinmagntarget, prtvol=0)
1130 : 76 : qp_vbik(:,:) = qp_ebands%get_valence_idx()
1131 : :
1132 : : ! Calculate the irreducible representations of the new QP amplitdues.
1133 [ + + - + ]: 76 : if (Sigp%symsigma==1.and.gwcalctyp>=20) then
1134 [ # # # # : 0 : ABI_MALLOC(QP_sym,(Wfd%nkibz,Wfd%nsppol))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
1135 : 0 : use_paw_aeur=.FALSE. ! should pass ngfftf but the dense mesh is not forced to be symmetric
1136 [ # # ]: 0 : do spin=1,Wfd%nsppol
1137 [ # # ]: 0 : do ikcalc=1,Sigp%nkptgw
1138 : 0 : ik_ibz = Kmesh%tab(Sigp%kptgw2bz(ikcalc))
1139 : : ! Quick fix for SCGW+symm TODO fix properly!
1140 : 0 : first_band = Sigp%minbnd(ikcalc,spin)
1141 : 0 : last_band = Sigp%maxbnd(ikcalc,spin)
1142 : : ! first_band = MINVAL(Sigp%minbnd(:,spin))
1143 : : ! last_band = MAXVAL(Sigp%maxbnd(:,spin))
1144 : : ! call classify_bands(Wfd,use_paw_aeur,first_band,last_band,ik_ibz,spin,ngfftf,Cryst,qp_ebands,Pawtab,Pawrad,Pawang,Psps,&
1145 : : call classify_bands(Wfd,use_paw_aeur,first_band,last_band,ik_ibz,spin,Wfd%ngfft,Cryst,qp_ebands,Pawtab,Pawrad,Pawang,Psps,&
1146 : 0 : & Dtset%tolsym,QP_sym(ik_ibz,spin))
1147 : : end do
1148 : : end do
1149 : :
1150 : : ! Recreate the Sig_ij tables taking advantage of the classification of the bands.
1151 [ # # ]: 0 : call sigma_tables(Sigp, Kmesh, esymm=QP_sym)
1152 : : end if
1153 : :
1154 : : ! Compute QP density using the updated wfg.
1155 : 76 : call wfd%mkrho(cryst, psps, qp_ebands, ngfftf, nfftf, qp_rhor)
1156 [ - + ]: 76 : if (Dtset%usekden==1) call wfd%mkrho(cryst, psps, qp_ebands, ngfftf, nfftf, qp_taur, optcalc=1)
1157 : :
1158 : : ! ========================================
1159 : : ! ==== QP self-consistent GW with PAW ====
1160 : : ! ========================================
1161 [ - + ]: 76 : if (Dtset%usepaw==1) then
1162 [ # # # # : 0 : ABI_MALLOC(qp_nhat,(nfftf,Dtset%nspden))
# # # # #
# # # # #
# # ]
1163 [ # # ]: 0 : nhatgrdim=0; if (Dtset%xclevel==2) nhatgrdim=usexcnhat
1164 [ # # # # : 0 : ABI_MALLOC(qp_nhatgr,(nfftf,Dtset%nspden,3*nhatgrdim))
# # # # #
# # # # #
# # # # #
# # # #
# ]
1165 : :
1166 [ # # # # : 0 : ABI_MALLOC(QP_pawrhoij,(Cryst%natom))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
1167 [ # # # # : 0 : ABI_MALLOC(QP_paw_ij,(Cryst%natom))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
1168 [ # # # # : 0 : ABI_MALLOC(QP_paw_an,(Cryst%natom))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
1169 : :
1170 : : ! Calculate new QP quantities: nhat, nhatgr, rho_ij, paw_ij, and paw_an.
1171 : : call paw_qpscgw(Wfd,nscf,nfftf,ngfftf,Dtset,Cryst,Kmesh,Psps,qp_ebands,&
1172 : : Pawang,Pawrad,Pawtab,Pawfgrtab,prev_Pawrhoij,&
1173 : 0 : QP_pawrhoij,QP_paw_ij,QP_paw_an,QP_energies,qp_nhat,nhatgrdim,qp_nhatgr,compch_sph,compch_fft)
1174 : : else
1175 [ - + ]: 76 : ABI_MALLOC(qp_nhat, (0, 0))
1176 [ - + - + ]: 76 : ABI_MALLOC(qp_nhatgr, (0, 0, 0))
1177 [ - + - + ]: 76 : ABI_MALLOC(QP_pawrhoij, (0))
1178 [ - + - + ]: 76 : ABI_MALLOC(QP_paw_ij, (0))
1179 [ - + - + ]: 76 : ABI_MALLOC(QP_paw_an, (0))
1180 : : end if
1181 : :
1182 : : ! here I should renormalize the density
1183 : : call test_charge(nfftf,ks_ebands%nelect,Dtset%nspden,qp_rhor,Cryst%ucvol,&
1184 : 76 : Dtset%usepaw,usexcnhat,Pawfgr%usefinegrid,compch_sph,compch_fft,drude_plsmf)
1185 : :
1186 [ - + - - : 76 : if (Dtset%usepaw==1) qp_rhor(:,:)=qp_rhor(:,:)+qp_nhat(:,:) ! Add the "hat" term.
- - ]
1187 : :
1188 : 76 : call prtrhomxmn(std_out,MPI_enreg_seq,nfftf,ngfftf,Dtset%nspden,1,qp_rhor,ucvol=ucvol)
1189 [ - + ]: 76 : if (Dtset%usekden==1) then
1190 : 0 : call prtrhomxmn(std_out,MPI_enreg_seq,nfftf,ngfftf,Dtset%nspden,1,qp_taur,optrhor=1,ucvol=ucvol)
1191 : : end if
1192 : :
1193 : : ! Simple mixing of the PW density to damp oscillations in the Hartree potential.
1194 [ + + + + ]: 76 : if (nscf>0 .and. (ABS(Dtset%rhoqpmix-one)>tol12) ) then
1195 : 12 : write(msg,'(2a,f6.3)')ch10,' sigma: mixing QP densities using rhoqpmix= ',Dtset%rhoqpmix
1196 : 12 : call wrtout(std_out, msg)
1197 [ + - + - : 92260 : qp_rhor = prev_rhor + Dtset%rhoqpmix*(qp_rhor-prev_rhor)
- + - - +
+ + + ]
1198 [ - + - - : 12 : if(Dtset%usekden==1) qp_taur = prev_taur + Dtset%rhoqpmix*(qp_taur-prev_taur) ! mix taur.
- - - - -
- - - -
- ]
1199 : : end if
1200 : :
1201 [ - + ]: 76 : ABI_FREE(prev_rhor)
1202 [ - + ]: 76 : ABI_FREE(prev_taur)
1203 [ - + - - ]: 76 : if (Psps%usepaw==1.and.nscf>0) call pawrhoij_free(prev_pawrhoij)
1204 [ + - - + : 76 : ABI_FREE(prev_pawrhoij)
- - - - -
- - - - -
- - - + ]
1205 : :
1206 [ - + + - : 228 : ABI_MALLOC(qp_rhog,(2,nfftf))
+ - + - -
+ - + ]
1207 : 76 : call fourdp(1,qp_rhog,qp_rhor(:,1),-1,MPI_enreg_seq,nfftf,1,ngfftf,tim_fourdp5)
1208 : :
1209 : : ! ===========================================
1210 : : ! ==== Optional output of the QP density ====
1211 : : ! ===========================================
1212 [ + - + + ]: 76 : if (Dtset%prtden/=0 .and. wfd%my_rank == master) then
1213 : : call fftdatar_write("qp_rhor",dtfil%fnameabo_qp_den,dtset%iomode,hdr_sigma,&
1214 : 60 : cryst,ngfftf,cplex1,nfftf,dtset%nspden,qp_rhor,mpi_enreg_seq,ebands=qp_ebands)
1215 : : end if
1216 : :
1217 : : ! ===========================================
1218 : : ! === Optional output of the full QP density
1219 : : ! ===========================================
1220 [ - + - - ]: 76 : if (Wfd%usepaw==1.and.Dtset%prtden==2) then
1221 [ # # # # : 0 : ABI_MALLOC(qp_rhor_paw ,(nfftf,Wfd%nspden))
# # # # #
# # # # #
# # ]
1222 [ # # # # : 0 : ABI_MALLOC(qp_rhor_n_one ,(nfftf,Wfd%nspden))
# # # # #
# # # ]
1223 [ # # # # : 0 : ABI_MALLOC(qp_rhor_nt_one,(nfftf,Wfd%nspden))
# # # # #
# # # ]
1224 : :
1225 : : call denfgr(Cryst%atindx1,Cryst%gmet,comm,Cryst%natom,Cryst%natom,Cryst%nattyp,ngfftf,qp_nhat,&
1226 : : Wfd%nspinor,Wfd%nsppol,Wfd%nspden,Cryst%ntypat,Pawfgr,Pawrad,QP_pawrhoij,Pawtab,Dtset%prtvol,&
1227 : 0 : qp_rhor,qp_rhor_paw,qp_rhor_n_one,qp_rhor_nt_one,Cryst%rprimd,Cryst%typat,Cryst%ucvol,Cryst%xred)
1228 : :
1229 [ # # ]: 0 : ABI_FREE(qp_rhor_n_one)
1230 [ # # ]: 0 : ABI_FREE(qp_rhor_nt_one)
1231 : :
1232 [ # # ]: 0 : if (Dtset%prtvol > 9) then
1233 : : ! Print a normalisation check
1234 [ # # # # ]: 0 : norm = SUM(qp_rhor_paw(:,1))*Cryst%ucvol/PRODUCT(Pawfgr%ngfft(1:3))
1235 : 0 : write(msg,'(a,F8.4)') ' QUASIPARTICLE DENSITY CALCULATED - NORM OF DENSITY: ',norm
1236 : 0 : call wrtout(std_out, msg)
1237 : : end if
1238 : :
1239 : : ! Write the density to file
1240 [ # # ]: 0 : if (my_rank==master) then
1241 : : call fftdatar_write("qp_pawrhor",dtfil%fnameabo_qp_pawden,dtset%iomode,hdr_sigma,&
1242 : 0 : cryst,ngfftf,cplex1,nfftf,dtset%nspden,qp_rhor_paw,mpi_enreg_seq,ebands=qp_ebands)
1243 : : end if
1244 [ # # ]: 0 : ABI_FREE(qp_rhor_paw)
1245 : : end if
1246 : :
1247 : 76 : nkxc=0
1248 [ + + ]: 76 : if (Dtset%nspden==1) nkxc=2
1249 [ + + ]: 76 : if (Dtset%nspden>=2) nkxc=3 !check GGA and spinor that is messy !!!
1250 : : !In case of MGGA, fxc and kxc are not available and we dont need them for the screening part (for now ...)
1251 [ - + - - ]: 76 : if (Dtset%ixc<0.and.libxc_functionals_ismgga()) nkxc=0
1252 [ + - ]: 76 : if (nkxc/=0) then
1253 [ - + + - : 304 : ABI_MALLOC(qp_kxc,(nfftf,nkxc))
- + + - +
- + - - +
- + ]
1254 : : end if
1255 : :
1256 : : ! **** NOTE THAT Vxc CONTAINS THE CORE-DENSITY CONTRIBUTION ****
1257 [ + + ]: 76 : n3xccc=0; if (Psps%n1xccc/=0) n3xccc=nfftf
1258 [ - + + - : 228 : ABI_MALLOC(qp_vhartr, (nfftf))
+ - + - -
+ - + ]
1259 [ - + + - : 304 : ABI_MALLOC(qp_vtrial, (nfftf,Dtset%nspden))
- + + - +
- + - - +
- + ]
1260 [ - + + - : 228 : ABI_MALLOC(qp_vxc, (nfftf,Dtset%nspden))
- + + - -
+ - + -
+ ]
1261 : :
1262 : 76 : optene=4; moved_atm_inside=0; moved_rhor=0; istep=1
1263 : :
1264 : : call setvtr(Cryst%atindx1,Dtset,QP_energies,gmet,gprimd,grchempottn,grewtn,grvdw,gsqcutf_eff,&
1265 : : istep,qp_kxc,mgfftf,moved_atm_inside,moved_rhor,MPI_enreg_seq,&
1266 : : Cryst%nattyp,nfftf,ngfftf,ngrvdw,qp_nhat,qp_nhatgr,nhatgrdim,nkxc,Cryst%ntypat,Psps%n1xccc,n3xccc,&
1267 : : optene,Pawang,Pawrad,QP_pawrhoij,Pawtab,ph1df,Psps,qp_rhog,qp_rhor,Cryst%rmet,&
1268 : : Cryst%rprimd,strsxc,Cryst%ucvol,usexcnhat,qp_vhartr,vpsp,qp_vtrial,qp_vxc,vxcavg_qp,Wvl,&
1269 : 76 : xccc3d,Cryst%xred,taur=qp_taur)
1270 : :
1271 [ + - ]: 76 : ABI_SFREE(qp_kxc)
1272 : :
1273 [ - + ]: 76 : if (Dtset%usepaw==1) then
1274 : 0 : call timab(561,1,tsec)
1275 : :
1276 : : ! Compute QP Dij
1277 : : call pawdij(cplex,Dtset%enunit,Cryst%gprimd,ipert0,&
1278 : : Cryst%natom,Cryst%natom,nfftf,ngfftf(1)*ngfftf(2)*ngfftf(3),&
1279 : : Dtset%nspden,Cryst%ntypat,QP_paw_an,QP_paw_ij,Pawang,Pawfgrtab,&
1280 : : Dtset%pawprtvol,Pawrad,QP_pawrhoij,Dtset%pawspnorb,Pawtab,Dtset%pawxcdev,&
1281 : : k0,Dtset%spnorbscl,Cryst%ucvol,dtset%cellcharge(1),&
1282 : : qp_vtrial,qp_vxc,Cryst%xred,Dtset%znucl,&
1283 : 0 : nucdipmom=Dtset%nucdipmom,spinaxis=Dtset%spinaxis)
1284 : :
1285 : : ! Symmetrize total Dij
1286 : 0 : option_dij=0
1287 : :
1288 : : call symdij_all(Cryst%gprimd,Cryst%indsym,ipert0,&
1289 : : Cryst%natom,Cryst%natom,Cryst%nsym,Cryst%ntypat,&
1290 : : QP_paw_ij,Pawang,Dtset%pawprtvol,Pawtab,Cryst%rprimd,&
1291 : 0 : Cryst%symafm,Cryst%symrec)
1292 : :
1293 : : ! Output the QP pseudopotential strengths Dij and the augmentation occupancies Rhoij.
1294 : 0 : call pawprt(Dtset,Cryst%natom,QP_paw_ij,QP_Pawrhoij,Pawtab)
1295 : 0 : call timab(561,2,tsec)
1296 : : end if
1297 : :
1298 [ + + ]: 1967517 : ehartree=half*SUM(qp_rhor(:,1)*qp_vhartr(:))/DBLE(nfftf)*Cryst%ucvol
1299 : :
1300 [ + - + + ]: 6156 : write(msg,'(a,80a)')ch10,('-',ii=1,80)
1301 : 76 : call wrtout(ab_out,msg)
1302 : 76 : write(msg,'(5a,f9.4,3a,es21.14,2a,es21.14)')ch10,&
1303 : 76 : ' QP results after the unitary transformation in the KS subspace: ',ch10,ch10,&
1304 : 76 : ' Number of electrons = ',qp_rhog(1,1)*Cryst%ucvol,ch10,ch10,&
1305 : 76 : ' QP Band energy [Ha] = ',qp_ebands%get_bandenergy(),ch10,&
1306 : 152 : ' QP Hartree energy [Ha] = ',ehartree
1307 : 76 : call wrtout(ab_out,msg)
1308 [ + - + + ]: 6156 : write(msg,'(a,80a)')ch10,('-',ii=1,80)
1309 : 152 : call wrtout(ab_out,msg)
1310 : :
1311 : : ! TODO Since plasmonpole model 2-3-4 depend on the Fourier components of the density
1312 : : ! in case of self-consistency we might calculate here the ppm coefficients using qp_rhor
1313 : : end if ! gwcalctyp>=10
1314 : :
1315 : : ! KS hamiltonian: hdft(b1,b1,k,s)= <b1,k,s|H_s|b1,k,s>
1316 [ - + + - : 106123 : ABI_CALLOC(hdft, (b1gw:b2gw, b1gw:b2gw, Kmesh%nibz, Sigp%nsppol*Sigp%nsig_ab))
- + + - -
+ + - - +
+ - + - +
- - + - +
- + + + +
+ + + +
+ ]
1317 : :
1318 [ + + ]: 201 : if (Dtset%nspinor == 1) then
1319 [ + + ]: 392 : do spin=1,Sigp%nsppol
1320 [ + + ]: 1593 : do ik=1,Kmesh%nibz
1321 [ + + ]: 9781 : do ib=b1gw,b2gw
1322 : 9583 : hdft(ib, ib, ik, spin) = ks_ebands%eig(ib, ik, spin)
1323 : : end do
1324 : : end do
1325 : : end do
1326 : : else
1327 : : ! Spinorial case
1328 : : ! * Note that here vxc contains the contribution of the core.
1329 : : ! * Scale ovlp if orthonormalization is not satisfied as npwwfn might be < npwvec.
1330 : : ! TODO add spin-orbit case and gwpara 2
1331 [ - + + - : 21 : ABI_MALLOC(my_band_list, (wfd%mband))
+ - + - -
+ - + ]
1332 [ - + + - : 14 : ABI_MALLOC(bmask, (wfd%mband))
- + - + ]
1333 [ + + + + ]: 281 : bmask = .False.; bmask(b1gw:b2gw) = .True.
1334 : :
1335 [ - + ]: 7 : if (Wfd%usepaw == 1) then
1336 [ # # # # : 0 : ABI_MALLOC(Cp1,(Wfd%natom, Wfd%nspinor))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
1337 : 0 : call pawcprj_alloc(Cp1, 0, Wfd%nlmn_atm)
1338 : : end if
1339 : :
1340 [ + + ]: 14 : do spin=1,Sigp%nsppol
1341 [ + + ]: 45 : do ik_ibz=1,Kmesh%nibz
1342 : : ! Distribute bands in [b1gw, b2gw] range
1343 : 31 : call wfd%distribute_bands(ik_ibz, spin, my_nband, my_band_list, bmask=bmask)
1344 [ + - ]: 31 : if (my_nband == 0) cycle
1345 : 31 : npw_k = Wfd%npwarr(ik_ibz)
1346 [ + + ]: 440 : do ii=1,my_nband ! ib=b1gw,b2gw in sequential
1347 : 402 : ib = my_band_list(ii)
1348 [ - + ]: 402 : ABI_CHECK(wfd%get_wave_ptr(ib, ik_ibz, spin, wave, msg) == 0, msg)
1349 : 402 : ug1 => wave%ug
1350 : 402 : cdummy = xdotc(npw_k*Wfd%nspinor,ug1,1,ug1,1)
1351 : 402 : ovlp(1) = REAL(cdummy); ovlp(2) = AIMAG(cdummy)
1352 : :
1353 [ - + ]: 402 : if (Psps%usepaw==1) then
1354 : 0 : call wfd%get_cprj(ib,ik_ibz,spin,Cryst,Cp1,sorted=.FALSE.)
1355 [ # # ]: 0 : ovlp = ovlp + paw_overlap(Cp1,Cp1,Cryst%typat,Pawtab)
1356 : : end if
1357 : : ! write(std_out,*)ovlp(1),ovlp(2)
1358 : 402 : norm=DBLE(ovlp(1)+ovlp(2))
1359 : 402 : ovlp(1)=DBLE(ovlp(1)/norm); ovlp(2)=DBLE(ovlp(2)/norm) ! ovlp(2)=cone-ovlp(1)
1360 : 402 : hdft(ib,ib,ik_ibz,1) = ks_ebands%eig(ib,ik_ibz,1)*ovlp(1) - KS_me%vxc(ib,ib,ik_ibz,3)
1361 : 402 : hdft(ib,ib,ik_ibz,2) = ks_ebands%eig(ib,ik_ibz,1)*ovlp(2) - KS_me%vxc(ib,ib,ik_ibz,4)
1362 : 402 : hdft(ib,ib,ik_ibz,3) = KS_me%vxc(ib,ib,ik_ibz,3)
1363 : 433 : hdft(ib,ib,ik_ibz,4) = KS_me%vxc(ib,ib,ik_ibz,4)
1364 : : end do
1365 : : end do
1366 : : end do
1367 : :
1368 : 7 : call xmpi_sum(hdft, wfd%comm, ierr)
1369 : :
1370 [ - + ]: 7 : ABI_FREE(my_band_list)
1371 [ - + ]: 7 : ABI_FREE(bmask)
1372 [ - + ]: 14 : if (Wfd%usepaw==1) then
1373 : 0 : call pawcprj_free(Cp1)
1374 [ # # # # : 0 : ABI_FREE(Cp1)
# # # # #
# ]
1375 : : end if
1376 : : end if
1377 : :
1378 : : ! Initialize Sigma results. TODO it is better if we use ragged arrays indexed by the k-point
1379 : 201 : call Sr%init(Sigp, Kmesh%nibz, Dtset%usepawu)
1380 : :
1381 : : ! Setup bare Hamiltonian := T + v_{loc} + v_{nl} + v_H.
1382 : : !
1383 : : ! * The representation depends whether we are updating the wfs or not.
1384 : : ! * ks_vUme is zero unless we are using DFT+U as starting point, see calc_vHxc_braket
1385 : : ! * Note that vH matrix elements are calculated using the true uncutted interaction
1386 : : ! This should be changed if the cutoff is also used in the GS run.
1387 : :
1388 [ + + ]: 201 : if (gwcalctyp < 10) then
1389 : : ! For one-shot GW use the KS representation.
1390 [ + - + - : 52716 : Sr%hhartree = hdft - KS_me%vxcval
+ - + - -
+ - - + +
+ + + + +
+ ]
1391 : :
1392 : : ! Additional stuff for PAW
1393 : : ! * DFT +U Hamiltonian
1394 : : ! * LEXX.
1395 : : ! * Core contribution estimated using Fock exchange.
1396 [ + + ]: 125 : if (Dtset%usepaw==1) then
1397 [ + + + - : 1090 : if (Sigp%use_sigxcore == 1) Sr%hhartree = hdft - (KS_me%vxc - KS_me%sxcore)
+ - + - +
- - + - -
+ + + + +
+ + + ]
1398 [ - + - - : 5 : if (Dtset%usepawu /= 0) Sr%hhartree = Sr%hhartree - KS_me%vu
- - - - -
- - - ]
1399 [ - + ]: 5 : if (Dtset%useexexch /= 0) then
1400 : 0 : ABI_ERROR("useexexch > 0 not implemented")
1401 [ # # # # : 0 : Sr%hhartree = Sr%hhartree - KS_me%vlexx
# # # # #
# ]
1402 : : end if
1403 : : end if
1404 : :
1405 : : else
1406 : : ! Self-consistent on energies and|or wavefunctions.
1407 : : ! * For NC get the bare Hamiltonian $H_{bare}= T+v_{loc}+ v_{nl}$ in the KS representation
1408 : : ! * For PAW, calculate the matrix elements of h0, store also the new Dij in QP_Paw_ij.
1409 : : ! * h0 is defined as T+vH[tn+nhat+tnZc] + vxc[tnc] + dij_eff and
1410 : : ! dij_eff = dij^0 + dij^hartree + dij^xc-dij^xc_val + dijhat - dijhat_val.
1411 : : ! In the above expression tn, tnhat are QP quantities.
1412 [ + - ]: 76 : if (Dtset%usepaw==0) then
1413 [ - + + - : 456 : ABI_MALLOC(hbare, (b1gw:b2gw,b1gw:b2gw,Kmesh%nibz,Sigp%nsppol*Sigp%nsig_ab))
- + + - -
+ + - - +
+ - + - +
- - + -
+ ]
1414 [ + - + - : 52603 : hbare = hdft - KS_me%vhartree - KS_me%vxcval
+ - + - -
+ - - + +
+ + + + +
+ ]
1415 : :
1416 : : ! Change basis from KS to QP, hbare is overwritten: A_{QP} = U^\dagger A_{KS} U
1417 [ - + + - : 380 : ABI_MALLOC(htmp, (b1gw:b2gw,b1gw:b2gw, Kmesh%nibz, Sigp%nsppol*Sigp%nsig_ab))
- + + - -
+ + - - +
+ - - + -
+ ]
1418 [ - + + - : 304 : ABI_MALLOC(ctmp, (b1gw:b2gw, b1gw:b2gw))
- + + - +
- + - - +
- + - + ]
1419 [ - + + - : 228 : ABI_MALLOC(uks2qp, (b1gw:b2gw, b1gw:b2gw))
- + + - -
+ - + ]
1420 [ + - + - : 105054 : htmp = hbare; hbare = czero
+ - + - -
+ - - - -
- - + + +
+ + + + +
+ + + + +
+ + + ]
1421 : :
1422 [ + + ]: 154 : do spin=1,Sigp%nsppol
1423 [ + + ]: 607 : do ik=1,Kmesh%nibz
1424 [ + + + + ]: 52373 : uks2qp(:,:) = Sr%m_ks_to_qp(b1gw:b2gw,b1gw:b2gw,ik,spin)
1425 [ + + ]: 984 : do iab=1,Sigp%nsig_ab
1426 [ - + ]: 453 : is_idx=spin; if (Sigp%nsig_ab>1) is_idx=iab
1427 [ + - + + : 2820233 : ctmp(:,:)=MATMUL(htmp(:,:,ik,is_idx),uks2qp(:,:))
+ + + + +
+ + + + -
+ - + - +
- + - ]
1428 [ + - + + : 2820686 : hbare(:,:,ik,is_idx)=MATMUL(TRANSPOSE(CONJG(uks2qp)),ctmp)
+ + + + +
+ + + + -
+ - + - +
- + - - -
- - - - ]
1429 : : end do
1430 : : end do
1431 : : end do
1432 [ - + ]: 76 : ABI_FREE(htmp)
1433 [ - + ]: 76 : ABI_FREE(ctmp)
1434 [ - + ]: 76 : ABI_FREE(uks2qp)
1435 : : end if ! usepaw==0
1436 : :
1437 : : ! Calculate the QP matrix elements
1438 : : ! This part is parallelized within MPI_COMM_WORD since each node has all GW wavefunctions.
1439 : : ! For PAW, we have to construct the new bare Hamiltonian.
1440 : 76 : call wrtout(std_out,ch10//' *************** QP Energies *******************')
1441 : :
1442 : 76 : call QP_mflags%reset()
1443 : : ! if (gwcalctyp<20) QP_mflags%only_diago=1 ! For e-only, no need of off-diagonal elements.
1444 : 76 : QP_mflags%has_vhartree=1
1445 [ - + ]: 76 : if (Dtset%usepaw==1) then
1446 : 0 : QP_mflags%has_kinetic =1
1447 : 0 : QP_mflags%has_hbare =1
1448 : : end if
1449 : : !QP_mflags%has_vxc =1
1450 : : !QP_mflags%has_vxcval =1
1451 : : !if (Sigp%gwcalctyp >100) QP_mflags%has_vxcval_hybrid=1
1452 [ + + + + ]: 76 : if (mod10==5 .and. &
1453 : : (Dtset%ixc_sigma==-402 .or. Dtset%ixc_sigma==-406 .or. Dtset%ixc_sigma==-427 .or. Dtset%ixc_sigma==-428 .or. &
1454 : : Dtset%ixc_sigma==-456 .or. Dtset%ixc_sigma==41 .or. Dtset%ixc_sigma==42)) then
1455 : 23 : QP_mflags%has_vxcval_hybrid = 1
1456 : : end if
1457 : :
1458 : : !if (Sigp%use_sigxcore==1) QP_mflags%has_sxcore =1
1459 : : !if (Dtset%usepawu/=0) QP_mflags%has_vu =1
1460 : : !if (Dtset%useexexch/=0) QP_mflags%has_lexexch=1
1461 : :
1462 [ - + + - : 304 : ABI_MALLOC(tmp_kstab, (2, Wfd%nkibz, Wfd%nsppol))
- + + - +
- + - - +
- + ]
1463 [ + + + + : 1513 : tmp_kstab=0
+ + ]
1464 [ + + ]: 154 : do spin=1,Sigp%nsppol
1465 [ + + ]: 553 : do ikcalc=1,Sigp%nkptgw ! No spin dependent!
1466 : 399 : ik_ibz = Kmesh%tab(Sigp%kptgw2bz(ikcalc))
1467 : 399 : tmp_kstab(1,ik_ibz,spin)=Sigp%minbnd(ikcalc,spin)
1468 : 477 : tmp_kstab(2,ik_ibz,spin)=Sigp%maxbnd(ikcalc,spin)
1469 : : end do
1470 : : end do
1471 : :
1472 : : call calc_vhxc_me(Wfd,QP_mflags,QP_me,Cryst,Dtset,nfftf,ngfftf,&
1473 : : qp_vtrial,qp_vhartr,qp_vxc,Psps,Pawtab,QP_paw_an,Pawang,Pawfgrtab,QP_paw_ij,dijexc_core,&
1474 : 76 : qp_rhor,usexcnhat,qp_nhat,qp_nhatgr,nhatgrdim,tmp_kstab,taur=qp_taur)
1475 [ - + ]: 76 : ABI_FREE(tmp_kstab)
1476 : :
1477 [ + + - + ]: 76 : if (gwcalctyp>=20 .and. Sigp%symsigma>0) then
1478 : 0 : bmin=Sigp%minbdgw; bmax=Sigp%maxbdgw
1479 [ # # # # : 0 : ABI_MALLOC(qp_irreptab,(bmin:bmax,Kmesh%nibz,Sigp%nsppol))
# # # # #
# # # # #
# # # # #
# ]
1480 [ # # # # : 0 : qp_irreptab=0
# # ]
1481 [ # # ]: 0 : do spin=1,Sigp%nsppol
1482 [ # # ]: 0 : do ikcalc=1,Sigp%nkptgw
1483 : 0 : ik_ibz = Kmesh%tab(Sigp%kptgw2bz(ikcalc))
1484 : 0 : first_band = Sigp%minbnd(ikcalc,spin)
1485 : 0 : last_band = Sigp%maxbnd(ikcalc,spin)
1486 [ # # ]: 0 : if (.not. QP_sym(ik_ibz,spin)%failed()) then
1487 [ # # ]: 0 : qp_irreptab(first_band:last_band,ik_ibz,spin) = QP_sym(ik_ibz,spin)%b2irrep(first_band:last_band)
1488 : : !qp_irreptab(bmin:bmax,ik_ibz,spin) = QP_sym(ik_ibz,spin)%b2irrep(bmin:bmax)
1489 : : end if
1490 : : end do
1491 : : end do
1492 : 0 : call QP_me%zero(qp_irreptab)
1493 [ # # ]: 0 : ABI_FREE(qp_irreptab)
1494 : : end if
1495 : :
1496 : 76 : call QP_me%print(header="Matrix elements in the QP basis set", prtvol=Dtset%prtvol)
1497 : :
1498 : : ! Output the QP pseudopotential strengths Dij and the augmentation occupancies Rhoij.
1499 [ - + ]: 76 : if (Dtset%usepaw==1) then
1500 : 0 : call wrtout(std_out," *** After calc_vHxc_braket *** ")
1501 : : ! TODO finalize the implementation of this routine.
1502 : 0 : call paw_ij_print(QP_Paw_ij,unit=std_out,pawprtvol=Dtset%pawprtvol,pawspnorb=Dtset%pawspnorb,mode_paral="COLL")
1503 : 0 : call pawprt(Dtset,Cryst%natom,QP_paw_ij,QP_Pawrhoij,Pawtab)
1504 : : end if
1505 : :
1506 [ + - ]: 76 : if (Dtset%usepaw==0) then
1507 : : ! GA: We have an odd bug here. I have to unroll this loop, otherwise it
1508 : : ! might cause segfault when running on several nodes.
1509 : : !
1510 : : ! Sr%hhartree = hbare + QP_me%vhartree
1511 [ + + ]: 76 : if (QP_mflags%has_vxcval_hybrid == 0) then
1512 [ + + ]: 108 : do spin=1,Sigp%nsppol*Sr%nsig_ab
1513 [ + + ]: 380 : do ikcalc=1,Sr%nkibz
1514 [ + + ]: 2691 : do ib1=b1gw,b2gw
1515 [ + + ]: 24256 : do ib2=b1gw,b2gw
1516 : 23984 : Sr%hhartree(ib2,ib1,ikcalc,spin) = hbare(ib2,ib1,ikcalc,spin) + QP_me%vhartree(ib2,ib1,ikcalc,spin)
1517 : : end do
1518 : : end do
1519 : : end do
1520 : : end do
1521 : : else
1522 [ + + ]: 46 : do spin=1,Sigp%nsppol*Sr%nsig_ab
1523 [ + + ]: 227 : do ikcalc=1,Sr%nkibz
1524 [ + + ]: 2300 : do ib1=b1gw,b2gw
1525 [ + + ]: 28117 : do ib2=b1gw,b2gw
1526 : : Sr%hhartree(ib2,ib1,ikcalc,spin) = hbare(ib2,ib1,ikcalc,spin) + &
1527 : 27936 : QP_me%vhartree(ib2,ib1,ikcalc,spin) + QP_me%vxcval_hybrid(ib2,ib1,ikcalc,spin)
1528 : : end do
1529 : : end do
1530 : : end do
1531 : : end do
1532 : : end if
1533 : : else
1534 [ # # # # : 0 : Sr%hhartree=QP_me%hbare
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
1535 : : end if
1536 : :
1537 [ + + - + ]: 76 : if (gwcalctyp>=20 .and. Sigp%symsigma > 0) then
1538 : : ! bmin=Sigp%minbdgw; bmax=Sigp%maxbdgw
1539 [ # # ]: 0 : do spin=1,Sigp%nsppol
1540 [ # # ]: 0 : do ik_ibz=1,Kmesh%nibz
1541 [ # # ]: 0 : if (.not. QP_sym(ik_ibz,spin)%failed()) then
1542 : 0 : bmin=Sigp%minbnd(ik_ibz,spin); bmax=Sigp%minbnd(ik_ibz,spin)
1543 [ # # ]: 0 : do ib2=bmin,bmax
1544 : 0 : irr_idx2 = QP_sym(ik_ibz,spin)%b2irrep(ib2)
1545 [ # # ]: 0 : do ib1=bmin,bmax
1546 : 0 : irr_idx1 = QP_sym(ik_ibz,spin)%b2irrep(ib1)
1547 [ # # # # ]: 0 : if (irr_idx1/=irr_idx2 .and. ALL((/irr_idx1,irr_idx2/)/=0) ) Sr%hhartree(ib1,ib2,ik_ibz,spin) = czero
1548 : : end do
1549 : : end do
1550 : : end if
1551 : : end do
1552 : : end do
1553 : : end if
1554 : :
1555 [ - + ]: 76 : ABI_FREE(qp_rhog)
1556 [ - + ]: 76 : ABI_FREE(qp_vhartr)
1557 [ - + ]: 76 : ABI_FREE(qp_vxc)
1558 [ - + ]: 76 : ABI_FREE(qp_nhat)
1559 [ - + ]: 76 : ABI_FREE(qp_nhatgr)
1560 : 76 : call QP_me%free()
1561 : : end if ! gwcalctyp<10
1562 : :
1563 : : ! Free some memory
1564 [ + + ]: 201 : ABI_SFREE(hbare)
1565 [ + - ]: 201 : ABI_SFREE(hdft)
1566 : :
1567 : : ! Prepare the storage of QP amplitudes and energies
1568 : : ! Initialize with KS wavefunctions and energies.
1569 : : ! FIXME: This array should be allocated only if self-consistent
1570 [ + + + + : 73472 : if (sr%needs_eigvec_qp) Sr%eigvec_qp=czero
+ + + + +
+ ]
1571 [ + + + + : 30808 : Sr%en_qp_diago=zero
+ + ]
1572 [ + + ]: 5828 : do ib=1,Sigp%nbnds
1573 [ + + + + ]: 40474 : Sr%en_qp_diago(ib,:,:) = ks_ebands%eig(ib,:,:)
1574 [ + + + + : 12004 : if (sr%needs_eigvec_qp) Sr%eigvec_qp(ib,ib,:,:) = cone
+ + ]
1575 : : end do
1576 : :
1577 : : ! Store <n,k,s|V_xc[n_val]|n,k,s> and <n,k,s|V_U|n,k,s> ===
1578 : : ! Note that we store the matrix elements of V_xc in the KS basis set, not in the QP basis set
1579 : : ! Matrix elements of V_U are zero unless we are using DFT+U as starting point
1580 [ + + ]: 1629 : do ib=b1gw,b2gw
1581 [ + + + + ]: 13142 : Sr%vxcme(ib,:,:)=KS_me%vxcval(ib,ib,:,:)
1582 [ + + + + : 1568 : if (Sigp%use_sigxcore == 1) Sr%vxcme(ib,:,:)= KS_me%vxc(ib,ib,:,:) -KS_me%sxcore(ib,ib,:,:) !SF: This needs to be updated, otherwise Vxc will be reported incorrectly in the output. However, vxcme is not used by solve_dyson
+ + ]
1583 [ - + - - : 1629 : if (Dtset%usepawu/=0) Sr%vUme (ib,:,:)=KS_me%vu(ib,ib,:,:)
- - ]
1584 : : end do
1585 : :
1586 : : ! Initial guess for the GW energies
1587 : : ! Save the energies of the previous iteration.
1588 [ + + ]: 406 : do spin=1,Sigp%nsppol
1589 [ + + ]: 1638 : do ik=1,Kmesh%nibz
1590 [ + + ]: 30402 : do ib=1,Sigp%nbnds
1591 : 29170 : Sr%e0 (ib,ik,spin) = qp_ebands%eig(ib,ik,spin)
1592 : 30402 : Sr%egw(ib,ik,spin) = qp_ebands%eig(ib,ik,spin)
1593 : : end do
1594 : 1232 : Sr%e0gap(ik,spin) = zero
1595 : 1232 : ks_iv = ks_vbik(ik, spin)
1596 [ + - ]: 1437 : if (Sigp%nbnds>=ks_iv+1) Sr%e0gap(ik,spin)=Sr%e0(ks_iv+1,ik,spin)-Sr%e0(ks_iv,ik,spin)
1597 : : end do
1598 : : end do
1599 : :
1600 [ - + ]: 201 : if (dtset%userie == 458) then
1601 : : ! userie=456 reads all energies from SC_WFK in setup_sigma, so that the poles of G0 and the frequency at which
1602 : : ! Sigma is evaluated are both frozen. userie=458 does not read SC_WFK in setup_sigma, so that the poles of G0
1603 : : ! move with the atoms, and here we read SC_WFK to set Sr%e0 and Sr%egw (omega4sd is built from Sr%egw) to the
1604 : : ! frozen ones.
1605 : 0 : call wfk_read_eigenvalues("SC_WFK", eig_sc, hdr_sc, comm)
1606 [ # # # # : 0 : Sr%e0 = eig_sc(1:Sigp%nbnds,:,:)
# # # # #
# # # # #
# # ]
1607 [ # # # # : 0 : Sr%egw = eig_sc(1:Sigp%nbnds,:,:)
# # # # #
# # # # #
# # ]
1608 : 0 : call hdr_sc%free()
1609 [ # # ]: 0 : ABI_FREE(eig_sc)
1610 : : end if
1611 : : !
1612 : : !=== If required apply a scissor operator or update the energies ===
1613 : : !TODO check if other Sr entries have to be updated
1614 : : !moreover this part should be done only in case of semiconductors
1615 : : !FIXME To me it makes more sense if we apply the scissor to ks_ebands but I have to RECHECK csigme
1616 [ + + ]: 201 : if (ABS(Sigp%mbpt_sciss)>tol6) then
1617 : 2 : write(msg,'(6a,f10.5,2a)')ch10,&
1618 : 2 : ' sigma : performing a first self-consistency',ch10,&
1619 : 2 : ' update of the energies in G by a scissor operator',ch10, &
1620 : 4 : ' applying a scissor operator of ',Sigp%mbpt_sciss*Ha_eV,' [eV] ',ch10
1621 : 2 : call wrtout(units, msg)
1622 [ + + ]: 4 : do spin=1,Sigp%nsppol
1623 [ + + ]: 8 : do ik=1,Kmesh%nibz
1624 : 4 : ks_iv=ks_vbik(ik,spin)
1625 [ + - ]: 6 : if (Sigp%nbnds>=ks_iv+1) then
1626 [ + + ]: 28 : Sr%egw (ks_iv+1:Sigp%nbnds,ik,spin) = Sr%egw (ks_iv+1:Sigp%nbnds,ik,spin)+Sigp%mbpt_sciss
1627 [ + + ]: 28 : qp_ebands%eig(ks_iv+1:Sigp%nbnds,ik,spin) = qp_ebands%eig(ks_iv+1:Sigp%nbnds,ik,spin)+Sigp%mbpt_sciss
1628 : : end if
1629 : : end do
1630 : : end do
1631 : : !call apply_scissor(qp_ebands,Sigp%mbpt_sciss)
1632 : : else if (.FALSE.) then
1633 : : write(msg,'(4a)')ch10,&
1634 : : ' sigma : performing a first self-consistency',ch10,&
1635 : : ' update of the energies in G by a previous GW calculation'
1636 : : call wrtout(units, msg)
1637 : : ! TODO Recheck this part, is not clear to me!
1638 : : ABI_MALLOC(igwene,(qp_ebands%mband, qp_ebands%nkpt, qp_ebands%nsppol))
1639 : : call rdgw(qp_ebands, '__in.gw__', igwene, extrapolate=.TRUE.)
1640 : : ABI_FREE(igwene)
1641 : : Sr%egw=qp_ebands%eig
1642 : : !
1643 : : ! * Recalculate the new fermi level.
1644 : : call qp_ebands%update_occ(Dtset%spinmagntarget, prtvol=0)
1645 : : end if
1646 : :
1647 : : ! In case of AC refer all the energies wrt to the fermi level
1648 : : ! Be careful because results from ppmodel cannot be used for AC
1649 : : ! FIXME check ks_energy or qp_energy (in case of SCGW?)
1650 : :
1651 [ + + ]: 201 : if (mod10 == SIG_GW_AC) then
1652 : : ! All these quantities will be passed to csigme
1653 : : ! if I skipped the self-consistent part then here I have to use fermi
1654 [ + + + + : 942 : qp_ebands%eig = qp_ebands%eig - qp_ebands%fermie
+ + ]
1655 [ + + + + : 942 : Sr%egw = Sr%egw - qp_ebands%fermie
+ + ]
1656 [ + + + + : 942 : Sr%e0 = Sr%e0 - qp_ebands%fermie
+ + ]
1657 : 9 : old_fermie = qp_ebands%fermie
1658 : : ! TODO Recheck fermi
1659 : : ! Clean EVERYTHING in particulare the treatment of E fermi
1660 : 9 : qp_ebands%fermie = zero
1661 : : end if
1662 : :
1663 : : ! Setup frequencies around the KS\QP eigenvalues to compute Sigma derivatives (notice the spin) ===
1664 : : ! TODO it is better using an odd Sr%nomega4sd so that the KS\QP eigenvalue is in the middle
1665 : 201 : ioe0j=Sr%nomega4sd/2+1
1666 [ + + ]: 406 : do spin=1,Sigp%nsppol
1667 [ + + ]: 1053 : do ikcalc=1,Sigp%nkptgw
1668 : 647 : ib1=Sigp%minbnd(ikcalc,spin)
1669 : 647 : ib2=Sigp%maxbnd(ikcalc,spin)
1670 : 647 : ik_ibz=Kmesh%tab(Sigp%kptgw2bz(ikcalc))
1671 [ + + ]: 6303 : do jb=ib1,ib2
1672 [ + + ]: 25845 : do io=1,Sr%nomega4sd
1673 : 25198 : Sr%omega4sd(jb,ik_ibz,io,spin)=Sr%egw(jb,ik_ibz,spin)+Sigp%deltae*(io-ioe0j)
1674 : : end do
1675 : : end do
1676 : : end do
1677 : : end do
1678 : :
1679 : 201 : call pstat_proc%print(_PSTAT_ARGS_)
1680 : 201 : call timab(408,2,tsec) ! hqp_init
1681 : 201 : call timab(409,1,tsec) ! getW
1682 : :
1683 : : ! Get epsilon^{-1} either from the _SCR or the _SUSC file and store it in epsm1%epsm1
1684 : : ! If epsm1%mqmem==0, allocate and read a single q-slice inside csigme.
1685 : : ! TODO epsm1%nomega should be initialized so that only the frequencies really needed are stored in memory
1686 : : ! TODO The same piece of code is present in screening.
1687 [ + + ]: 201 : if (sigp%needs_w()) then
1688 : :
1689 : 327 : select case (dtset%gwgamma)
1690 : : case (0)
1691 : 161 : id_required = 4; ikxc = 0; approx_type = 0; option_test = 0; dim_kxcg = 0
1692 [ - + + - : 322 : ABI_MALLOC(kxcg, (nfftf_tot,dim_kxcg))
- + - + ]
1693 : :
1694 : : case (1, 2)
1695 : : ! ALDA TDDFT kernel vertex
1696 [ - + ]: 1 : ABI_CHECK(epsm1%ID == 0, "epsm1%ID should be 0")
1697 : :
1698 [ - + ]: 1 : if (Dtset%usepaw==1) then
1699 : : ! If we have PAW, we need the full density on the fine grid
1700 [ # # # # : 0 : ABI_MALLOC(ks_aepaw_rhor,(nfftf,Wfd%nspden))
# # # # #
# # # # #
# # ]
1701 [ # # # # ]: 0 : if (Dtset%getpawden==0 .and. Dtset%irdpawden==0) then
1702 : 0 : ABI_ERROR("Must use get/irdpawden to provide a _PAWDEN file!")
1703 : : end if
1704 : 0 : call wrtout(std_out,sjoin('Checking for existence of: ',Dtfil%filpawdensin))
1705 [ # # ]: 0 : if (.not. file_exists(dtfil%filpawdensin)) then
1706 : 0 : ABI_ERROR(sjoin("Missing file:", dtfil%filpawdensin))
1707 : : end if
1708 : :
1709 [ # # # # : 0 : ABI_MALLOC(tmp_pawrhoij,(cryst%natom*wfd%usepaw))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
1710 : : call read_rhor(Dtfil%filpawdensin, cplex1, nfftf_tot, Wfd%nspden, ngfftf, 1, MPI_enreg_seq, &
1711 : 0 : ks_aepaw_rhor, Hdr_rhor, tmp_pawrhoij, wfd%comm)
1712 : :
1713 : 0 : call Hdr_rhor%free()
1714 : 0 : call pawrhoij_free(tmp_pawrhoij)
1715 [ # # # # : 0 : ABI_FREE(tmp_pawrhoij)
# # # # #
# # # # #
# # # # ]
1716 : : end if ! usepaw==1
1717 : :
1718 : 1 : id_required=4; ikxc=7; approx_type=1; dim_kxcg=1
1719 [ + - ]: 1 : if (Dtset%gwgamma==1) option_test=1 ! TESTELECTRON, vertex in chi0 *and* sigma
1720 [ - + ]: 1 : if (Dtset%gwgamma==2) option_test=0 ! TESTPARTICLE, vertex in chi0 only
1721 [ - + + - : 3 : ABI_MALLOC(kxcg, (nfftf_tot, dim_kxcg))
+ - + - -
+ - + ]
1722 : :
1723 : 1 : dbg_mode=.FALSE.
1724 [ - + ]: 1 : if (Dtset%usepaw==1) then
1725 : : ! Use PAW all-electron density
1726 : : call kxc_driver(Dtset,Cryst,ikxc,ngfftf,nfftf_tot,Wfd%nspden,ks_aepaw_rhor,&
1727 : 0 : epsm1%npwe,dim_kxcg,kxcg,Gsph_c%gvec,xmpi_comm_self,dbg_mode=dbg_mode)
1728 : : else
1729 : : ! Norm-conserving
1730 : : call kxc_driver(Dtset,Cryst,ikxc,ngfftf,nfftf_tot,Wfd%nspden,ks_rhor,&
1731 : 1 : epsm1%npwe,dim_kxcg,kxcg,Gsph_c%gvec,xmpi_comm_self,dbg_mode=dbg_mode)
1732 : : end if
1733 : :
1734 : : case (3, 4)
1735 : : ! ADA non-local kernel vertex
1736 [ # # ]: 0 : ABI_CHECK(epsm1%ID==0, "epsm1%ID should be 0")
1737 [ # # ]: 0 : ABI_CHECK(Sigp%nsppol==1, "ADA vertex for GWGamma not available yet for spin-polarised cases")
1738 : :
1739 [ # # ]: 0 : if (Dtset%usepaw==1) then
1740 : : ! If we have PAW, we need the full density on the fine grid
1741 [ # # # # : 0 : ABI_MALLOC(ks_aepaw_rhor,(nfftf, Sigp%nsppol))
# # # # #
# # # # #
# # ]
1742 [ # # # # ]: 0 : if (Dtset%getpawden==0.and.Dtset%irdpawden==0) then
1743 : 0 : ABI_ERROR("Must use get/irdpawden to provide a _PAWDEN file!")
1744 : : end if
1745 : 0 : call wrtout(std_out,sjoin('Checking for existence of: ',Dtfil%filpawdensin))
1746 [ # # ]: 0 : if (.not. file_exists(dtfil%filpawdensin)) then
1747 : 0 : ABI_ERROR(sjoin("Missing file:", dtfil%filpawdensin))
1748 : : end if
1749 : :
1750 [ # # # # : 0 : ABI_MALLOC(tmp_pawrhoij,(cryst%natom*wfd%usepaw))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
1751 : :
1752 : : call read_rhor(Dtfil%filpawdensin, cplex1, nfftf_tot, Wfd%nspden, ngfftf, 1, MPI_enreg_seq, &
1753 : 0 : ks_aepaw_rhor, Hdr_rhor, tmp_pawrhoij, wfd%comm)
1754 : :
1755 : 0 : call Hdr_rhor%free()
1756 : 0 : call pawrhoij_free(tmp_pawrhoij)
1757 [ # # # # : 0 : ABI_FREE(tmp_pawrhoij)
# # # # #
# # # # #
# # # # ]
1758 : : end if ! Dtset%usepaw==1
1759 : :
1760 : 0 : id_required=4; ikxc=7; approx_type=2;
1761 [ # # ]: 0 : if (Dtset%gwgamma==3) option_test=1 ! TESTELECTRON, vertex in chi0 *and* sigma
1762 [ # # ]: 0 : if (Dtset%gwgamma==4) option_test=0 ! TESTPARTICLE, vertex in chi0 only
1763 [ # # # # : 0 : ABI_MALLOC(fxc_ADA, (epsm1%npwe, epsm1%npwe, epsm1%nqibz))
# # # # #
# # # # #
# # # # #
# ]
1764 : : ! Use userrd to set kappa
1765 [ # # ]: 0 : if (Dtset%userrd==zero) Dtset%userrd = 2.1_dp
1766 : : ! Set correct value of kappa (should be scaled with alpha*r_s where)
1767 : : ! r_s is Wigner-Seitz radius and alpha=(4/(9*Pi))^(1/3)
1768 : 0 : rhoav = (drude_plsmf*drude_plsmf)/four_pi
1769 : 0 : r_s = (three/(four_pi*rhoav))**third
1770 : 0 : alpha = (four*ninth*piinv)**third
1771 : 0 : Dtset%userrd = Dtset%userrd/(alpha*r_s)
1772 : :
1773 : 0 : dbg_mode=.TRUE.
1774 [ # # ]: 0 : if (Dtset%usepaw==1) then
1775 : : ! Use PAW all-electron density
1776 : : call kxc_ADA(Dtset,Cryst,ikxc,ngfftf,nfftf_tot,Wfd%nspden,&
1777 : : ks_aepaw_rhor,epsm1%npwe,epsm1%nqibz,epsm1%qibz,&
1778 : 0 : fxc_ADA,Gsph_c%gvec,xmpi_comm_self,kappa_init=Dtset%userrd,dbg_mode=dbg_mode)
1779 : : else
1780 : : ! Norm conserving
1781 : : call kxc_ADA(Dtset,Cryst,ikxc,ngfftf,nfftf_tot,Wfd%nspden,&
1782 : : ks_rhor,epsm1%npwe,epsm1%nqibz,epsm1%qibz,&
1783 : 0 : fxc_ADA,Gsph_c%gvec,xmpi_comm_self,kappa_init=Dtset%userrd,dbg_mode=dbg_mode)
1784 : : end if
1785 : :
1786 : 0 : dim_kxcg = 0
1787 [ # # # # : 0 : ABI_MALLOC(kxcg,(nfftf_tot,dim_kxcg))
# # # # ]
1788 : :
1789 : : case (-3, -4, -5, -6, -7, -8)
1790 : : ! bootstrap kernels
1791 [ - + ]: 3 : ABI_CHECK(epsm1%ID==0,"epsm1%ID should be 0")
1792 : :
1793 [ - + ]: 3 : if (Dtset%usepaw==1) then
1794 : : ! If we have PAW, we need the full density on the fine grid
1795 [ # # # # : 0 : ABI_MALLOC(ks_aepaw_rhor, (nfftf,Wfd%nspden))
# # # # #
# # # # #
# # ]
1796 [ # # # # ]: 0 : if (Dtset%getpawden==0.and.Dtset%irdpawden==0) then
1797 : 0 : ABI_ERROR("Must use get/irdpawden to provide a _PAWDEN file!")
1798 : : end if
1799 : 0 : call wrtout(std_out,sjoin('Checking for existence of: ',Dtfil%filpawdensin))
1800 [ # # ]: 0 : if (.not. file_exists(dtfil%filpawdensin)) then
1801 : 0 : ABI_ERROR(sjoin("Missing file:", dtfil%filpawdensin))
1802 : : end if
1803 : :
1804 [ # # # # : 0 : ABI_MALLOC(tmp_pawrhoij, (cryst%natom*wfd%usepaw))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
1805 : :
1806 : : call read_rhor(Dtfil%filpawdensin, cplex1, nfftf_tot, Wfd%nspden, ngfftf, 1, MPI_enreg_seq, &
1807 : 0 : ks_aepaw_rhor, Hdr_rhor, tmp_pawrhoij, wfd%comm)
1808 : :
1809 : 0 : call Hdr_rhor%free()
1810 : 0 : call pawrhoij_free(tmp_pawrhoij)
1811 [ # # # # : 0 : ABI_FREE(tmp_pawrhoij)
# # # # #
# # # # #
# # # # ]
1812 : : end if ! Dtset%usepaw==1
1813 : :
1814 : 3 : id_required=4; ikxc=7; dim_kxcg=0
1815 : :
1816 [ + + ]: 3 : if (dtset%gwgamma>-5) then
1817 : 2 : approx_type=4 ! full fxc(G,G')
1818 [ + - ]: 1 : else if (dtset%gwgamma>-7) then
1819 : 1 : approx_type=5 ! fxc(0,0) one-shot
1820 : : else
1821 : 0 : approx_type=6 ! rpa-type bootstrap
1822 : : end if
1823 : :
1824 : 3 : option_test=MOD(Dtset%gwgamma,2)
1825 : : ! 1 -> TESTELECTRON, vertex in chi0 *and* sigma
1826 : : ! 0 -> TESTPARTICLE, vertex in chi0 only
1827 [ - + + - : 6 : ABI_MALLOC(kxcg, (nfftf_tot,dim_kxcg))
- + - + ]
1828 : :
1829 : : case (-11)
1830 : : ! LR+ALDA kernel
1831 [ - + ]: 1 : ABI_CHECK(epsm1%ID==0,"epsm1%ID should be 0")
1832 : :
1833 [ - + ]: 1 : if (Dtset%usepaw==1) then
1834 : : ! If we have PAW, we need the full density on the fine grid
1835 [ # # # # : 0 : ABI_MALLOC(ks_aepaw_rhor,(nfftf,Wfd%nspden))
# # # # #
# # # # #
# # ]
1836 [ # # # # ]: 0 : if (Dtset%getpawden==0.and.Dtset%irdpawden==0) then
1837 : 0 : ABI_ERROR("Must use get/irdpawden to provide a _PAWDEN file!")
1838 : : end if
1839 : 0 : call wrtout(std_out,sjoin('Checking for existence of: ',Dtfil%filpawdensin))
1840 [ # # ]: 0 : if (.not. file_exists(dtfil%filpawdensin)) then
1841 : 0 : ABI_ERROR(sjoin("Missing file:", dtfil%filpawdensin))
1842 : : end if
1843 : :
1844 [ # # # # : 0 : ABI_MALLOC(tmp_pawrhoij,(cryst%natom*wfd%usepaw))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
1845 : :
1846 : : call read_rhor(Dtfil%filpawdensin, cplex1, nfftf_tot, Wfd%nspden, ngfftf, 1, MPI_enreg_seq, &
1847 : 0 : ks_aepaw_rhor, hdr_rhor, tmp_pawrhoij, wfd%comm)
1848 : :
1849 : 0 : call hdr_rhor%free()
1850 : 0 : call pawrhoij_free(tmp_pawrhoij)
1851 [ # # # # : 0 : ABI_FREE(tmp_pawrhoij)
# # # # #
# # # # #
# # # # ]
1852 : : end if ! Dtset%usepaw==1
1853 : :
1854 : 1 : id_required=4; ikxc=7; dim_kxcg=1
1855 : 1 : approx_type=7
1856 : 1 : option_test=1
1857 : : ! 1 -> TESTELECTRON, vertex in chi0 *and* sigma
1858 [ - + + - : 3 : ABI_MALLOC(kxcg,(nfftf_tot,dim_kxcg))
+ - + - -
+ - + ]
1859 : :
1860 : : case default
1861 [ + + - + : 166 : ABI_ERROR(sjoin("Wrong gwgamma:", itoa(dtset%gwgamma)))
+ - ]
1862 : : end select
1863 : :
1864 : : ! Set plasma frequency
1865 [ + + ]: 166 : my_plsmf = drude_plsmf; if (Dtset%ppmfrq>tol6) my_plsmf = Dtset%ppmfrq
1866 : 166 : Dtset%ppmfrq = my_plsmf
1867 : :
1868 [ + - ]: 166 : if (Dtset%gwgamma < 3) then
1869 : : call epsm1%mkdump(Vcp,epsm1%npwe,Gsph_c%gvec,dim_kxcg,kxcg,id_required,&
1870 : : approx_type,ikxc,option_test,Dtfil%fnameabo_scr,Dtset%iomode,&
1871 : 166 : nfftf_tot,ngfftf,comm)
1872 : : else
1873 : : call epsm1%mkdump(Vcp,epsm1%npwe,Gsph_c%gvec,dim_kxcg,kxcg,id_required,&
1874 : : approx_type,ikxc,option_test,Dtfil%fnameabo_scr,Dtset%iomode,&
1875 : 0 : nfftf_tot,ngfftf,comm,fxc_ADA=fxc_ADA)
1876 : : end if
1877 [ + - ]: 166 : ABI_SFREE(kxcg)
1878 [ - + ]: 166 : ABI_SFREE(fxc_ADA)
1879 [ - + ]: 166 : ABI_SFREE(ks_aepaw_rhor)
1880 : : end if
1881 : : !
1882 : : ! ================================================
1883 : : ! ==== Calculate plasmonpole model parameters ====
1884 : : ! ================================================
1885 : : ! TODO Maybe its better if we use mqmem as input variable
1886 : 201 : use_aerhor=0
1887 [ - + + - : 402 : ABI_MALLOC(ks_aepaw_rhor, (nfftf,Wfd%nspden*use_aerhor))
- + - + -
+ ]
1888 : :
1889 [ + + ]: 201 : if (sigp%needs_ppm()) then
1890 : : ! If epsm1 is MPI-shared, we have to start the RMA epoch. Note that epsm1%epsm1 is read-only.
1891 [ + + ]: 130 : if (epsm1%use_mpi_shared_win) then
1892 : 24 : call xmpi_win_fence(XMPI_MODE_NOPRECEDE, epsm1%epsm1_win, ierr)
1893 : 24 : ABI_CHECK_MPI(ierr, "")
1894 : : end if
1895 : :
1896 [ + - ]: 130 : my_plsmf = drude_plsmf; if (Dtset%ppmfrq > tol6) my_plsmf = Dtset%ppmfrq
1897 : 130 : call PPm%init(epsm1%mqmem, epsm1%nqibz, epsm1%npwe, Sigp%ppmodel, my_plsmf, Dtset%gw_invalid_freq)
1898 : : ! PPm%force_plsmf= force_ppmfrq ! this line to change the plasma frequency in the HL expression.
1899 : :
1900 [ + + - + ]: 130 : if (Wfd%usepaw==1 .and. Ppm%userho==1) then
1901 : : ! For PAW and ppmodel 2-3-4 we need the AE rho(G) without compensation charge.
1902 : : ! It would be possible to calculate rho(G) using Paw_pwff, though. It should be faster but
1903 : : ! results will depend on the expression used for the matrix elements. This approach is safer.
1904 : 0 : use_aerhor=1
1905 [ # # ]: 0 : ABI_FREE(ks_aepaw_rhor)
1906 [ # # # # : 0 : ABI_MALLOC(ks_aepaw_rhor, (nfftf,Wfd%nspden))
# # # # #
# # # # #
# # ]
1907 : :
1908 : : ! Check if input density file is available, otherwise compute
1909 [ # # ]: 0 : pawden_fname = strcat(Dtfil%filnam_ds(3), '_PAWDEN')
1910 : 0 : call wrtout(std_out,sjoin('Checking for existence of:',pawden_fname))
1911 [ # # ]: 0 : if (file_exists(pawden_fname)) then
1912 : : ! Read density from file
1913 [ # # # # : 0 : ABI_MALLOC(tmp_pawrhoij, (cryst%natom*wfd%usepaw))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
1914 : :
1915 : : call read_rhor(pawden_fname, cplex1, nfftf_tot, Wfd%nspden, ngfftf, 1, MPI_enreg_seq, &
1916 : 0 : ks_aepaw_rhor, Hdr_rhor, tmp_pawrhoij, wfd%comm)
1917 : :
1918 : 0 : call Hdr_rhor%free()
1919 : 0 : call pawrhoij_free(tmp_pawrhoij)
1920 [ # # # # : 0 : ABI_FREE(tmp_pawrhoij)
# # # # #
# # # # #
# # # # ]
1921 : : else
1922 : : ! Have to calculate PAW AW rhor from scratch
1923 [ # # # # : 0 : ABI_MALLOC(qp_rhor_n_one, (pawfgr%nfft,Dtset%nspden))
# # # # #
# # # # #
# # ]
1924 [ # # # # : 0 : ABI_MALLOC(qp_rhor_nt_one, (pawfgr%nfft,Dtset%nspden))
# # # # #
# # # ]
1925 : :
1926 : : ! FIXME
1927 : 0 : ABI_WARNING(" denfgr in sigma seems to produce wrong results")
1928 [ # # ]: 0 : write(std_out,*)" input tilde ks_rhor integrates: ",SUM(ks_rhor(:,1))*Cryst%ucvol/nfftf
1929 : :
1930 : : call denfgr(Cryst%atindx1,Cryst%gmet,comm,Cryst%natom,Cryst%natom,Cryst%nattyp,ngfftf,ks_nhat,Wfd%nspinor,&
1931 : : Wfd%nsppol,Wfd%nspden,Cryst%ntypat,Pawfgr,Pawrad,KS_Pawrhoij,Pawtab,Dtset%prtvol, &
1932 : 0 : ks_rhor,ks_aepaw_rhor,qp_rhor_n_one,qp_rhor_nt_one,Cryst%rprimd,Cryst%typat,Cryst%ucvol,Cryst%xred)
1933 : :
1934 [ # # ]: 0 : ABI_FREE(qp_rhor_n_one)
1935 [ # # ]: 0 : ABI_FREE(qp_rhor_nt_one)
1936 : : end if
1937 : :
1938 [ # # ]: 0 : write(msg,'(a,f8.4)')' sigma: PAW AE density used for PPmodel integrates to: ',SUM(ks_aepaw_rhor(:,1))*Cryst%ucvol/nfftf
1939 : 0 : call wrtout(std_out, msg)
1940 : :
1941 [ # # ]: 0 : if (epsm1%mqmem /= 0) then
1942 : : ! Calculate ppmodel parameters for all q-points.
1943 : 0 : call PPm%setup(Cryst,Qmesh,epsm1%npwe,epsm1%nomega,epsm1%omega,epsm1%epsm1,nfftf,Gsph_c%gvec,ngfftf,ks_aepaw_rhor(:,1))
1944 : : end if
1945 : :
1946 : : else
1947 : : ! NC or PAW with PPmodel 1.
1948 [ + + ]: 130 : if (epsm1%mqmem /= 0) then
1949 : : ! Calculate ppmodel parameters for all q-points
1950 : 113 : call PPm%setup(Cryst, Qmesh, epsm1%npwe, epsm1%nomega, epsm1%omega, epsm1%epsm1, nfftf, Gsph_c%gvec, ngfftf, ks_rhor(:,1))
1951 : : end if
1952 : : end if ! PAW or NC PPm and/or needs density
1953 : :
1954 : : ! If epsm1 is MPI-shared, we have to close the RMA epoch.
1955 [ + + ]: 130 : if (epsm1%use_mpi_shared_win) then
1956 : 24 : call xmpi_win_fence(XMPI_MODE_NOSUCCEED, epsm1%epsm1_win, ierr)
1957 : 24 : ABI_CHECK_MPI(ierr, "")
1958 : : end if
1959 : : end if ! sigma_needs_ppm
1960 : :
1961 : 201 : call pstat_proc%print(_PSTAT_ARGS_)
1962 : 201 : call timab(409,2,tsec) ! getW
1963 : :
1964 [ + + ]: 201 : if (wfd%my_rank == master) then
1965 : : ! Write info on the run on ab_out, then open files to store final results.
1966 : 173 : call ks_ebands%report_gap(header='KS Band Gaps',unit=ab_out)
1967 [ + - ]: 173 : if(dtset%ucrpa == 0) call write_sigma_header(Sigp,epsm1,Cryst,Kmesh,Qmesh)
1968 : :
1969 : : ! unt_gw: File with GW corrections.
1970 : : ! unt_sig: Self-energy as a function of frequency.
1971 : : ! unt_sgr: Derivative wrt omega of the Self-energy.
1972 : : ! unt_sigc: Sigma_c(eik) MRM
1973 : : ! unt_sgm: Sigma on the Matsubara axis (imag axis)
1974 : :
1975 [ - + ]: 173 : if (open_file(Dtfil%fnameabo_gw, msg, unit=unt_gw, status='unknown', form='formatted') /= 0) then
1976 : 0 : ABI_ERROR(msg)
1977 : : end if
1978 : 173 : write(unt_gw,"(a)")"# QP energies E in eV"
1979 : 173 : write(unt_gw,"(a)")"# Format:"
1980 : 173 : write(unt_gw,"(a)")"# kpoint"
1981 : 173 : write(unt_gw,"(a)")"# number of bands computed"
1982 : 173 : write(unt_gw,"(2a)")"# band index, Re(E), E-E0, Im(E)", ch10
1983 : 173 : write(unt_gw,"(2(i0,1x),a)")Sigp%nkptgw,Sigp%nsppol, "# nkptgw, nsppol"
1984 : :
1985 [ - + ]: 173 : if (open_file(Dtfil%fnameabo_gwdiag, msg, unit=unt_gwdiag, status='unknown', form='formatted') /= 0) then
1986 : 0 : ABI_ERROR(msg)
1987 : : end if
1988 : 173 : write(unt_gwdiag,*)Sigp%nkptgw,Sigp%nsppol
1989 : :
1990 [ - + ]: 173 : if (open_file(Dtfil%fnameabo_sig, msg, unit=unt_sig, status='unknown', form='formatted') /= 0) then
1991 : 0 : ABI_ERROR(msg)
1992 : : end if
1993 : 173 : write(unt_sig,"(a)")"# Sigma_xc and spectral function A along the real frequency axis in eV units"
1994 : 173 : write(unt_sig,"(a)")"# Format:"
1995 : 173 : write(unt_sig,"(a)")"# kpoint"
1996 : 173 : write(unt_sig,"(a)")"# min_band(k) max_band(k)"
1997 : 173 : write(unt_sig,"(a)")"# For each frequency w:"
1998 : 173 : write(unt_sig,"(2a)")"# w, {Re(Sigma_b(w)), Im(Sigma_b(w), A_b(w) for b in [min_band, max_band]}",ch10
1999 : :
2000 [ - + ]: 173 : if (open_file(Dtfil%fnameabo_sgr, msg, unit=unt_sgr, status='unknown', form='formatted') /= 0) then
2001 : 0 : ABI_ERROR(msg)
2002 : : end if
2003 : 173 : write(unt_sgr,"(a)")"# Derivatives of Sigma_c(omega) wrt omega in eV units"
2004 : :
2005 : : ! Sigma_c(eik) MRM
2006 [ - + ]: 173 : if (open_file(trim(Dtfil%fnameabo_sgr)//'_SIGC', msg, unit=unt_sigc, status='unknown', form='formatted') /= 0) then
2007 : 0 : ABI_ERROR(msg)
2008 : : end if
2009 : :
2010 [ + + ]: 173 : if (mod10 == SIG_GW_AC) then
2011 : : ! Sigma along the imaginary axis.
2012 [ - + ]: 9 : if (open_file(Dtfil%fnameabo_sgm, msg, unit=unt_sgm, status='unknown', form='formatted') /= 0) then
2013 : 0 : ABI_ERROR(msg)
2014 : : end if
2015 : 9 : write(unt_sgm,"(a)")"# Sigma_xc along the imaginary frequency axis in eV units"
2016 : : end if
2017 : : end if
2018 : :
2019 : : !=======================================================================
2020 : : !==== Calculate self-energy and output the results for each k-point ====
2021 : : !=======================================================================
2022 : : ! Here it would be possible to calculate the QP correction for the same k-point using a PPmodel
2023 : : ! in the first iteration just to improve the initial guess and CD or AC in the second step. Useful
2024 : : ! if the KS level is far from the expected QP results. Previously it was possible to do such
2025 : : ! calculation by simply listing the same k-point twice in kptgw. Now this trick is not allowed anymore.
2026 : : ! Everything, indeed, should be done in a clean and transparent way inside csigme.
2027 : :
2028 [ + + ]: 402 : call wfd%print([std_out])
2029 : 201 : call wrtout(std_out, sigma_type_from_key(mod10))
2030 : :
2031 [ + + ]: 201 : if (gwcalctyp < 10) then
2032 : 125 : msg = " Perturbative Calculation"
2033 [ + + ]: 125 : if (gwcalctyp == 1) msg = " Newton Raphson method "
2034 [ + + ]: 76 : else if (gwcalctyp < 20) then
2035 : 11 : msg = " Self-Consistent on Energies only"
2036 [ + + ]: 65 : else if (gwcalctyp == 21) then
2037 : 5 : msg = " GW 1-RDM Corrections"
2038 : : else
2039 : 60 : msg = " Self-Consistent on Energies and Wavefunctions"
2040 : : end if
2041 [ + - ]: 201 : if (Dtset%ucrpa == 0) call wrtout(std_out,msg)
2042 : :
2043 : : !=================================================
2044 : : !==== Calculate the matrix elements of Sigma =====
2045 : : !=================================================
2046 : :
2047 [ + + ]: 201 : nomega_sigc=Sr%nomega_r+Sr%nomega4sd; if (mod10==SIG_GW_AC) nomega_sigc=Sr%nomega_i
2048 : :
2049 : : ! min and max band indices for GW corrections.
2050 : 201 : ib1=Sigp%minbdgw; ib2=Sigp%maxbdgw
2051 : :
2052 : : !MG TODO: I don't like the fact that ib1 and ib2 are redefined here because this
2053 : : ! prevents me from refactoring the code. In particular I want to store the self-energy
2054 : : ! results inside the sigma_results datatypes hence one needs to know all the dimensions
2055 : : ! at the beginning of the execution (e.g. in setup_sigma) so that one can easily allocate the arrays in the type.
2056 [ - + ]: 201 : if (Dtset%ucrpa >= 1) then
2057 : : ! Read the band
2058 [ # # ]: 0 : if (dtset%plowan_compute<10)then
2059 [ # # ]: 0 : if (open_file("forlb.ovlp",msg,newunit=temp_unt,form="formatted", status="unknown") /= 0) then
2060 : 0 : ABI_ERROR(msg)
2061 : : end if
2062 : 0 : rewind(temp_unt)
2063 : 0 : read(temp_unt,*)
2064 : 0 : read(temp_unt,*)
2065 : 0 : read(temp_unt,*) msg, ib1, ib2
2066 : 0 : close(temp_unt)
2067 : : else
2068 [ # # ]: 0 : if (open_file("data.plowann",msg,newunit=temp_unt,form="formatted", status="unknown") /= 0) then
2069 : 0 : ABI_ERROR(msg)
2070 : : end if
2071 : 0 : rewind(temp_unt)
2072 : 0 : read(temp_unt,*)
2073 : 0 : read(temp_unt,*)
2074 : 0 : read(temp_unt,'(a7,2i4)') msg, ib1, ib2
2075 : 0 : close(temp_unt)
2076 : : endif
2077 : : endif
2078 : :
2079 : : ! Do not store it for rdm_update because it might be too large!
2080 [ + + ]: 201 : if (.not. rdm_update) then
2081 [ - + + - : 285117 : ABI_CALLOC(sigcme, (nomega_sigc,ib1:ib2,ib1:ib2,Sigp%nkptgw,Sigp%nsppol*Sigp%nsig_ab))
- + + - -
+ + - - +
+ - - + +
- + - + -
- + - + +
+ + + + +
+ + + + ]
2082 : : endif
2083 : :
2084 : : ! if (.False. .and. psps%usepaw == 0 .and. wfd%nspinor == 1 .and. any(dtset%so_psp /= 0)) then
2085 : : ! call wrtout(std_out, "Computing SOC contribution with first-order perturbation theory")
2086 : : ! ABI_MALLOC(bks_mask, (wfd%mband, wfd%nkibz, wfd%nsppol))
2087 : : ! bks_mask = .False.
2088 : : ! do spin=1,wfd%nsppol
2089 : : ! do ikcalc=1,Sigp%nkptgw
2090 : : ! ik_ibz = Kmesh%tab(Sigp%kptgw2bz(ikcalc)) ! Irred k-point for GW
2091 : : ! ii=Sigp%minbnd(ikcalc, spin); jj=Sigp%maxbnd(ikcalc, spin)
2092 : : ! bks_mask(ii:jj, ik_ibz, spin) = .True.
2093 : : ! end do
2094 : : ! end do
2095 : : !
2096 : : ! call wfd_get_socpert(wfd, cryst, psps, pawtab, bks_mask, osoc_bks)
2097 : : ! ABI_FREE(bks_mask)
2098 : : ! ABI_FREE(osoc_bks)
2099 : : ! end if
2100 : :
2101 : : !==========================================================
2102 : : !==== Exchange part using the dense gwx_ngfft FFT mesh ====
2103 : : !==========================================================
2104 : : !TODO : load distribution is not optimal if band parallelism is used.
2105 : : !but this problem was also affecting the old implementation.
2106 : 201 : call timab(421,1,tsec) ! calc_sigx_me
2107 : :
2108 : : ! This routine shows how the wavefunctions are distributed.
2109 : : !call wfd_show_bkstab(Wfd,unit=std_out)
2110 : :
2111 [ - + ]: 201 : if (Dtset%ucrpa>=1) then
2112 : : ! Calculation of the Rho_n for calc_ucrpa
2113 : 0 : call wrtout(std_out, sjoin("begin of Ucrpa calc for a nb of kpoints of: ",itoa(Sigp%nkptgw)))
2114 : : ! Wannier basis: rhot1_q_m will need an atom index in the near future.
2115 : 0 : ic=0
2116 [ # # ]: 0 : do itypat=1,cryst%ntypat
2117 [ # # ]: 0 : if(pawtab(itypat)%lpawu.ne.-1) then
2118 : 0 : ndim=2*dtset%lpawu(itypat)+1
2119 : 0 : ic=ic+1
2120 : 0 : itypatcor=itypat
2121 : 0 : lcor=dtset%lpawu(itypat)
2122 : : end if
2123 : : end do
2124 [ # # ]: 0 : if(ic>1) then
2125 : 0 : ABI_ERROR("number of correlated species is larger than one")
2126 : : end if
2127 [ # # # # : 0 : ABI_MALLOC(rhot1_q_m, (cryst%nattyp(itypatcor),Wfd%nspinor,Wfd%nspinor,ndim,ndim,sigp%npwx,Qmesh%nibz))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
2128 [ # # # # : 0 : ABI_MALLOC(M1_q_m, (cryst%nattyp(itypatcor),Wfd%nspinor,Wfd%nspinor,ndim,ndim,sigp%npwx,Qmesh%nibz))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
2129 : :
2130 [ # # # # : 0 : M1_q_m=czero
# # # # #
# # # #
# ]
2131 [ # # # # : 0 : rhot1_q_m=czero
# # # # #
# # # #
# ]
2132 : :
2133 : : !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
2134 : : !Initialization of wan objects and getting psichies
2135 : : !Allocation of rhot1
2136 : : !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
2137 [ # # ]: 0 : if (dtset%plowan_compute>=10)then
2138 : 0 : call wrtout(units, " cRPA calculations using wannier weights from data.plowann")
2139 : : call init_plowannier(dtset%plowan_bandf,dtset%plowan_bandi,dtset%plowan_compute,dtset%plowan_iatom,&
2140 : : dtset%plowan_it,dtset%plowan_lcalc,dtset%plowan_natom,dtset%plowan_nbl,dtset%plowan_nt,&
2141 : : dtset%plowan_projcalc,dtset%acell_orig,dtset%kptns,sum(dtset%plowan_nbl),dtset%nimage,dtset%nkpt,dtset%nspinor,&
2142 [ # # ]: 0 : dtset%nsppol,dtset%wtk,dtset%dmft_t2g,wanibz_in)
2143 : 0 : call get_plowannier(wanibz_in,wanibz,dtset)
2144 : 0 : call fullbz_plowannier(dtset,kmesh,cryst,pawang,wanibz,wanbz)
2145 [ # # # # : 0 : ABI_MALLOC(rhot1,(sigp%npwx,Qmesh%nibz))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
2146 [ # # ]: 0 : do pwx=1,sigp%npwx
2147 [ # # ]: 0 : do ibz=1,Qmesh%nibz
2148 : 0 : call init_operwan_realspace(wanbz,rhot1(pwx,ibz))
2149 : 0 : call zero_operwan_realspace(wanbz,rhot1(pwx,ibz))
2150 : : end do
2151 : : end do
2152 : : endif
2153 : :
2154 : : !do ikcalc=1,Sigp%nkptgw
2155 : : !if(cryst%nsym==1) nkcalc=Kmesh%nbz
2156 : : !if(cryst%nsym>1) nkcalc=Kmesh%nibz
2157 : 0 : nkcalc=Kmesh%nbz
2158 : : !if(1==1)then!DEBUG
2159 : : !open(67,file="test.rhot1",status="REPLACE")
2160 [ # # ]: 0 : do ikcalc=1,nkcalc ! for the oscillator strength, spins are identical without SOC
2161 : : ! if(Sigp%nkptgw/=Kmesh%nbz) then
2162 : : ! write(msg,'(6a)')ch10,&
2163 : : !& ' nkptgw and nbz differs: this is not allowed to compute U in cRPA '
2164 : : ! ABI_ERROR(msg)
2165 : : ! endif
2166 : 0 : write(std_out,*) " ikcalc",ikcalc,size(Sigp%kptgw2bz),nkcalc
2167 : :
2168 [ # # ]: 0 : if(mod(ikcalc-1,nprocs)==Wfd%my_rank) then
2169 [ # # ]: 0 : if(cryst%nsym==1) ik_ibz=Kmesh%tab(ikcalc) ! Index of the irred k-point for GW
2170 [ # # ]: 0 : if(cryst%nsym>1) ik_ibz=Kmesh%tab(Sigp%kptgw2bz(ikcalc)) ! Index of the irred k-point for GW
2171 : :
2172 : : call prep_calc_ucrpa(ik_ibz,ikcalc,itypatcor,ib1,ib2,Cryst,qp_ebands,Sigp,Gsph_x,Vcp,&
2173 : : & Kmesh,Qmesh,lcor,M1_q_m,Pawtab,Pawang,Paw_pwff,&
2174 : : & Pawfgrtab,Paw_onsite,Psps,Wfd,Wfdf,QP_sym,gwx_ngfft,&
2175 [ # # ]: 0 : & ngfftf,Dtset%prtvol,Dtset%pawcross,Dtset%plowan_compute,rhot1_q_m,wanbz,rhot1)
2176 : : end if
2177 : : end do
2178 [ # # ]: 0 : if (dtset%plowan_compute<10)then
2179 : 0 : call xmpi_sum(rhot1_q_m,Wfd%comm,ierr)
2180 : 0 : call xmpi_sum(M1_q_m,Wfd%comm,ierr)
2181 [ # # # # : 0 : M1_q_m=M1_q_m/Kmesh%nbz/Wfd%nsppol
# # # # #
# # # #
# ]
2182 [ # # # # : 0 : rhot1_q_m=rhot1_q_m/Kmesh%nbz/Wfd%nsppol
# # # # #
# # # #
# ]
2183 : : !do pwx=1,sigp%npwx; do ibz=1,Qmesh%nibz; do ispinor1=1,dtset%nspinor; do ispinor2=1,dtset%nspinor; do iatom1=1,cryst%nattyp(itypatcor)
2184 : : ! do im1=1,2*lcor+1; do im2=1,2*lcor+1
2185 : : ! write(67,*)ibz,im1,im2,rhot1_q_m(iatom1,ispinor1,ispinor2,im1,im2,pwx,ibz)
2186 : : !enddo; enddo; enddo; enddo; enddo; enddo; enddo
2187 : : else
2188 : 0 : call reduce_operwan_realspace(wanbz,rhot1,sigp%npwx,Qmesh%nibz,Wfd%comm,Kmesh%nbz,Wfd%nsppol)
2189 : : !call cwtime(cpu,wall,gflops,"start") !reduction of rhot1
2190 : : ! dim=0
2191 : : ! do pwx=1,sigp%npwx; do ibz=1,Qmesh%nibz
2192 : : ! do spin=1,wanbz%nsppol; do ispinor1=1,wanbz%nspinor; ispinor2=1,wanbz%nspinor
2193 : : ! do iatom1=1,wanbz%natom_wan; do iatom2=1,wanbz%natom_wan
2194 : : ! do pos1=1,size(wanbz%nposition(iatom1)%pos,1); do pos2=1,size(wanbz%nposition(iatom2)%pos,1)
2195 : : ! do il1=1,wanbz%nbl_atom_wan(iatom1); do il2=1,wanbz%nbl_atom_wan(iatom2)
2196 : : ! do im1=1,2*wanbz%latom_wan(iatom1)%lcalc(il1)+1
2197 : : ! do im2=1,2*wanbz%latom_wan(iatom2)%lcalc(il2)+1
2198 : : ! dim=dim+1
2199 : : ! enddo!im2
2200 : : ! enddo!im1
2201 : : ! enddo!il2
2202 : : ! enddo!il1
2203 : : ! enddo!pos2
2204 : : ! enddo!pos1
2205 : : ! enddo!iatom2
2206 : : ! enddo!iatom1
2207 : : ! enddo!ispinor2
2208 : : ! enddo!ispinor1
2209 : : ! enddo!spin
2210 : : ! enddo!ibz
2211 : : ! enddo!pwx
2212 : : ! ABI_MALLOC(buffer,(dim))
2213 : : ! nnn=0
2214 : : ! do pwx=1,sigp%npwx; do ibz=1,Qmesh%nibz; do spin=1,wanbz%nsppol; do ispinor1=1,wanbz%nspinor; do ispinor2=1,wanbz%nspinor
2215 : : ! do iatom1=1,wanbz%natom_wan; do iatom2=1,wanbz%natom_wan
2216 : : ! do pos1=1,size(wanbz%nposition(iatom1)%pos,1); do pos2=1,size(wanbz%nposition(iatom2)%pos,1)
2217 : : ! do il1=1,wanbz%nbl_atom_wan(iatom1); do il2=1,wanbz%nbl_atom_wan(iatom2)
2218 : : ! do im1=1,2*wanbz%latom_wan(iatom1)%lcalc(il1)+1
2219 : : ! do im2=1,2*wanbz%latom_wan(iatom2)%lcalc(il2)+1
2220 : : ! nnn=nnn+1
2221 : : ! buffer(nnn)=rhot1(pwx,ibz)%atom_index(iatom1,iatom2)%position(pos1,pos2)%atom(il1,il2)%matl(im1,im2,spin,ispinor1,ispinor2)
2222 : : ! enddo; enddo; enddo; enddo; enddo; enddo; enddo; enddo; enddo; enddo; enddo; enddo; enddo
2223 : : ! call xmpi_sum(buffer,Wfd%comm,ierr)
2224 : : ! buffer=buffer/Kmesh%nbz/Wfd%nsppol
2225 : : ! nnn=0
2226 : : ! do pwx=1,sigp%npwx; do ibz=1,Qmesh%nibz; do spin=1,wanbz%nsppol; do ispinor1=1,wanbz%nspinor; do ispinor2=1,wanbz%nspinor
2227 : : ! do iatom1=1,wanbz%natom_wan; do iatom2=1,wanbz%natom_wan
2228 : : ! do pos1=1,size(wanbz%nposition(iatom1)%pos,1); do pos2=1,size(wanbz%nposition(iatom2)%pos,1)
2229 : : ! do il1=1,wanbz%nbl_atom_wan(iatom1); do il2=1,wanbz%nbl_atom_wan(iatom2)
2230 : : ! do im1=1,2*wanbz%latom_wan(iatom1)%lcalc(il1)+1
2231 : : ! do im2=1,2*wanbz%latom_wan(iatom2)%lcalc(il2)+1
2232 : : ! nnn=nnn+1
2233 : : ! rhot1(pwx,ibz)%atom_index(iatom1,iatom2)%position(pos1,pos2)%atom(il1,il2)%matl(im1,im2,spin,ispinor1,ispinor2)=buffer(nnn)
2234 : : ! !write(67,*)ibz,im1,im2,rhot1(pwx,ibz)%atom_index(iatom1,iatom2)%position(pos1,pos2)%atom(il1,il2)%matl(im1,im2,spin,ispinor1,ispinor2)
2235 : : ! enddo; enddo; enddo;enddo; enddo; enddo;enddo; enddo; enddo; enddo; enddo; enddo; enddo
2236 : : ! ABI_FREE(buffer)
2237 : : endif
2238 : :
2239 : : !close(67)
2240 : : ! call xmpi_barrier(Wfd%comm)
2241 : : ! call cwtime(cpu,wall,gflops,"stop")!reduction of rhot1
2242 : : ! write(6,*)cpu,wall,gflops
2243 : : ! if(Cryst%nsym==1) then
2244 : : ! M1_q_m=M1_q_m/Kmesh%nbz/Wfd%nsppol
2245 : : ! rhot1_q_m=rhot1_q_m/Kmesh%nbz/Wfd%nsppol
2246 : : ! endif
2247 : : ! Calculation of U in cRPA: need to treat with a different cutoff the
2248 : : ! bare coulomb and the screened coulomb interaction.
2249 : : ! else !DEBUG
2250 : : ! write(6,*)"DEBUGGING calc_ucrpa"
2251 : : ! open(67,file="test.rhot1",status="OLD")
2252 : : ! rewind(67)
2253 : : ! do pwx=1,sigp%npwx
2254 : : ! do ibz=1,Qmesh%nibz
2255 : : ! do spin=1,wanbz%nsppol
2256 : : ! do ispinor1=1,wanbz%nspinor
2257 : : ! do ispinor2=1,wanbz%nspinor
2258 : : ! do iatom1=1,wanbz%natom_wan
2259 : : ! do iatom2=1,wanbz%natom_wan
2260 : : ! do pos1=1,size(wanbz%nposition(iatom1)%pos,1)
2261 : : ! do pos2=1,size(wanbz%nposition(iatom2)%pos,1)
2262 : : ! do il1=1,wanbz%nbl_atom_wan(iatom1)
2263 : : ! do il2=1,wanbz%nbl_atom_wan(iatom2)
2264 : : ! do im1=1,2*wanbz%latom_wan(iatom1)%lcalc(il1)+1
2265 : : ! do im2=1,2*wanbz%latom_wan(iatom2)%lcalc(il2)+1
2266 : : ! read(67,*)dummy,dummy,dummy,xx
2267 : : ! rhot1(pwx,ibz)%atom_index(iatom1,iatom2)%position(pos1,pos2)%atom(il1,il2)%matl(im1,im2,spin,ispinor1,ispinor2)=xx
2268 : : ! enddo!im2
2269 : : ! enddo!im1
2270 : : ! enddo!il2
2271 : : ! enddo!il1
2272 : : ! enddo!pos2
2273 : : ! enddo!pos1
2274 : : ! enddo!iatom2
2275 : : ! enddo!iatom1
2276 : : ! enddo!ispinor2
2277 : : ! enddo!ispinor1
2278 : : ! enddo!spin
2279 : : ! enddo!ibz
2280 : : ! enddo!pwx
2281 : : ! close(67)
2282 : : ! endif!DEBUG
2283 : : call calc_ucrpa(itypatcor,cryst,Kmesh,lcor,M1_q_m,Qmesh,epsm1%npwe,sigp%npwx,&
2284 : : Cryst%nsym,Sigp%nomegasr,Sigp%minomega_r,Sigp%maxomega_r,ib1,ib2,&
2285 : 0 : 'Gsum',Cryst%ucvol,Wfd,epsm1%fname,dtset%plowan_compute,rhot1,wanbz)
2286 : :
2287 : : !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
2288 : : !Deallocation of wan and rhot1
2289 : : !^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
2290 [ # # ]: 0 : if (dtset%plowan_compute >=10) then
2291 [ # # ]: 0 : do pwx=1,sigp%npwx
2292 [ # # ]: 0 : do ibz=1,Qmesh%nibz
2293 : 0 : call destroy_operwan_realspace(wanbz,rhot1(pwx,ibz))
2294 : : end do
2295 : : end do
2296 [ # # # # : 0 : ABI_FREE(rhot1)
# # # # #
# # # # #
# # # # #
# # # ]
2297 : 0 : call destroy_plowannier(wanbz)
2298 : : endif
2299 [ # # ]: 0 : ABI_FREE(rhot1_q_m)
2300 [ # # ]: 0 : ABI_FREE(M1_q_m)
2301 : :
2302 : : else
2303 : : ! MRM: sigmak_todo is an array indicating whether the k-point must be computed for GW correction.
2304 : : ! This array is set to DO IT (to 1) for any GW calculation
2305 : : ! and it will only change to NOT DO IT (to 0) in case that a density matrix update calc. is used and we are reading checkpoint files
2306 [ - + + - : 603 : ABI_MALLOC(sigmak_todo,(Wfd%nkibz))
+ - + - -
+ - + -
+ ]
2307 [ + + ]: 1423 : sigmak_todo(:)=1
2308 : :
2309 : : ! ======================================================
2310 : : ! ==== Initialize arrays for density matrix updates ====
2311 : : ! ======================================================
2312 [ + + ]: 201 : if (rdm_update) then
2313 : : ! Note: all subroutines of 70_gw/m_gwrdm.F90 are implemented assuming nsppol == 1
2314 [ - + ]: 5 : ABI_CHECK(dtset%nsppol == 1, "1-RDM GW correction only implemented for restricted closed-shell calculations!")
2315 : :
2316 [ - + + - : 2225 : ABI_CALLOC(nateigv, (Wfd%mband, Wfd%mband, Wfd%nkibz, Sigp%nsppol))
- + + - -
+ + - - +
+ - + - +
- - + - +
- + + + +
+ + + +
+ ]
2317 [ - + + - : 290 : ABI_CALLOC(nat_occs, (Wfd%mband, Wfd%nkibz))
- + + - +
- + - - +
- + - + +
+ + + ]
2318 [ - + + - : 2119 : ABI_CALLOC(xrdm_k_full, (b1gw:b2gw, b1gw:b2gw, Wfd%nkibz))
- + + - -
+ + - + -
+ - - + -
+ + + + +
+ + ]
2319 : :
2320 : 5 : write(msg,'(a34,2i9)')' Bands used for the GW 1RDM arrays',b1gw,b2gw
2321 : 5 : call wrtout(units, msg)
2322 : :
2323 [ + + ]: 35 : do ik_ibz=1,Wfd%nkibz
2324 [ + + ]: 264 : do ib=b1gw,b2gw
2325 : 264 : xrdm_k_full(ib,ib,ik_ibz) = qp_ebands%occ(ib,ik_ibz,1)
2326 : : end do
2327 [ + + ]: 275 : do ib=1,Wfd%mband
2328 : : ! Copy initial occ numbers (in principle 2 or 0 from KS-DFT)
2329 : 240 : nat_occs(ib,ik_ibz) = qp_ebands%occ(ib,ik_ibz,1)
2330 : : ! Set to identity matrix
2331 : 270 : nateigv(ib,ib,ik_ibz,1) = cone
2332 : : end do
2333 : : end do
2334 [ + + ]: 5 : if (readchkprdm) then
2335 : 1 : gw1rdm_fname = trim(dtfil%fnameabi_chkp_rdm)
2336 : 1 : call get_chkprdm(Wfd,Kmesh,Sigp,qp_ebands,nat_occs,nateigv,sigmak_todo,my_rank,gw1rdm_fname)
2337 : : end if
2338 : 5 : call xmpi_barrier(Wfd%comm)
2339 : :
2340 : : ! Prepare arrays for the imaginary freq. integration (quadrature) of Sigma_c(iw)
2341 [ - + + - : 15 : ABI_MALLOC(weights, (Sigp%nomegasi))
+ - + - -
+ - + -
+ ]
2342 : 5 : call quadrature_sigma_cw(Sigp,Sr,weights)
2343 : : end if
2344 : :
2345 : : ! ===================================
2346 : : ! ==== Static part (Sigma_x-Vxc) ====
2347 : : ! ===================================
2348 [ + + ]: 840 : do ikcalc=1,Sigp%nkptgw
2349 : : ! Index of the irred k-point for GW
2350 : 639 : ik_ibz = Kmesh%tab(Sigp%kptgw2bz(ikcalc))
2351 : 639 : call pstat_proc%print(_PSTAT_ARGS_)
2352 : :
2353 : : ! Do not compute MELS if the k-point was read from the checkpoint file
2354 : : ! this IF only affects GW density matrix update!
2355 : :
2356 [ + + ]: 840 : if (sigmak_todo(ik_ibz) == 1) then
2357 : : ! min and max band indices for GW corrections (for this k-point)
2358 [ + + ]: 1280 : ib1 = MINVAL(Sigp%minbnd(ikcalc,:))
2359 [ + + ]: 1280 : ib2 = MAXVAL(Sigp%maxbnd(ikcalc,:))
2360 : : call calc_sigx_me(ik_ibz,ikcalc,ib1,ib2,Cryst,qp_ebands,dtset, Sigp,Sr,Gsph_x,Vcp,Kmesh,Qmesh,Ltg_k(ikcalc),&
2361 : : Pawtab,Pawang,Paw_pwff,Pawfgrtab,Paw_onsite,Psps,Wfd,Wfdf,QP_sym,&
2362 [ - + ]: 636 : gwx_ngfft,ngfftf,Dtset%prtvol,Dtset%pawcross,tol_empty)
2363 : :
2364 [ + + ]: 636 : if (rdm_update) then
2365 : : ! Only recompute exchange update to the 1-RDM if the point read was broken or not precomputed
2366 : :
2367 : : ! Compute Sigma_x - Vxc or DELTA Sigma_x - Vxc
2368 : : ! where DELTA Sigma_x = Sigma_x - hyb_parameter Vx^exact for hyb Functionals.
2369 : : ! NB: Only restricted closed-shell calcs are implemented here
2370 [ - + + - : 1790 : ABI_CALLOC(pot_k, (ib1:ib2, ib1:ib2))
- + + - +
- + - - +
- + - + +
+ + + ]
2371 [ - + + - : 1763 : ABI_CALLOC(rdm_k, (ib1:ib2, ib1:ib2))
- + + - -
+ - + - +
+ + + + ]
2372 [ + + + + ]: 1709 : pot_k(ib1:ib2,ib1:ib2) = Sr%x_mat(ib1:ib2,ib1:ib2,ik_ibz,1) - KS_me%vxcval(ib1:ib2,ib1:ib2,ik_ibz,1)
2373 : :
2374 : 27 : call calc_rdmx(ib1, ib2, ik_ibz, pot_k, rdm_k, qp_ebands)
2375 : :
2376 : : ! Update the full 1RDM with the exchange corrected one for this k-point
2377 [ + + + + ]: 1709 : xrdm_k_full(ib1:ib2,ib1:ib2,ik_ibz) = xrdm_k_full(ib1:ib2,ib1:ib2,ik_ibz) + rdm_k(ib1:ib2,ib1:ib2)
2378 : :
2379 : : ! Compute NAT ORBS for exchange corrected 1-RDM
2380 [ + + ]: 223 : do ib=ib1,ib2
2381 : 223 : rdm_k(ib,ib) = rdm_k(ib,ib) + qp_ebands%occ(ib,ik_ibz,1) ! Only restricted closed-shell calcs
2382 : : end do
2383 : 27 : call natoccs(ib1, ib2, rdm_k, nateigv, nat_occs, qp_ebands, ik_ibz, iinfo=0) ! Only restricted closed-shell calcs
2384 [ - + ]: 27 : ABI_FREE(pot_k)
2385 [ - + ]: 27 : ABI_FREE(rdm_k)
2386 : : end if
2387 : : else
2388 : 3 : write(msg,'(a1)') ' '
2389 : 3 : call wrtout(std_out,msg)
2390 : 3 : write(msg,'(a64,i5)') ' Skipping the calc. of Sigma_x - ( Vxc + hyb*Fock) for k-point: ',ik_ibz
2391 : 3 : call wrtout(std_out,msg)
2392 : 3 : write(msg,'(a1)') ' '
2393 : 3 : call wrtout(std_out,msg)
2394 : : end if
2395 : : end do ! ikcalc
2396 : :
2397 : : ! for the time being, do not remove this barrier!
2398 : 201 : call xmpi_barrier(Wfd%comm)
2399 : 201 : call pstat_proc%print(_PSTAT_ARGS_)
2400 : 201 : call timab(421,2,tsec) ! calc_sigx_me
2401 : :
2402 : : ! ==========================================================
2403 : : ! ==== Correlation part using the coarse gwc_ngfft mesh ====
2404 : : ! ==========================================================
2405 [ + + ]: 201 : if (mod10/=SIG_HF) then
2406 [ + + ]: 635 : do ikcalc=1,Sigp%nkptgw
2407 : 469 : ik_ibz=Kmesh%tab(Sigp%kptgw2bz(ikcalc)) ! Index of the irred k-point for GW
2408 [ + + ]: 944 : ib1 = MINVAL(Sigp%minbnd(ikcalc,:)) ! min and max band indices for GW corrections (for this k-point)
2409 [ + + ]: 944 : ib2 = MAXVAL(Sigp%maxbnd(ikcalc,:))
2410 : :
2411 [ - + + - : 274770 : ABI_CALLOC(sigcme_k, (nomega_sigc,ib2-ib1+1,ib2-ib1+1,Sigp%nsppol*Sigp%nsig_ab))
+ - - + +
- - + + -
- + + - +
- + - - +
- + - + +
+ + + + +
+ + ]
2412 : :
2413 [ + + ]: 469 : if (any(mod10 == [SIG_SEX, SIG_COHSEX])) then
2414 : : ! Calculate static COHSEX or SEX using the coarse gwc_ngfft mesh.
2415 : : call cohsex_me(ik_ibz,ikcalc,nomega_sigc,ib1,ib2,dtset, Cryst,qp_ebands,Sigp,Sr,epsm1,Gsph_c,Vcp,Kmesh,Qmesh,&
2416 : : Ltg_k(ikcalc),Pawtab,Pawang,Paw_pwff,Psps,Wfd,QP_sym,&
2417 [ - + ]: 5 : gwc_ngfft,Dtset%iomode,Dtset%prtvol,sigcme_k)
2418 : : else
2419 : : ! Compute correlated part using the coarse gwc_ngfft mesh.
2420 [ + + + + ]: 464 : if (x1rdm/=1 .and. sigmak_todo(ik_ibz)==1) then
2421 : : ! Do not compute correlation MELS if the k-point was read from the checkpoint file
2422 : : ! this IF only affects GW density matrix update
2423 : : call calc_sigc_me(ik_ibz,ikcalc,nomega_sigc,ib1,ib2,Dtset,dtfil, Cryst,qp_ebands, &
2424 : : Sigp,Sr,epsm1,Gsph_Max,Gsph_c,Vcp,Kmesh,Qmesh,&
2425 : : Ltg_k(ikcalc),PPm,Pawtab,Pawang,Paw_pwff,Pawfgrtab,Paw_onsite,Psps,Wfd,Wfdf,QP_sym,&
2426 [ - + ]: 455 : gwc_ngfft,ngfftf,nfftf,ks_rhor,use_aerhor,ks_aepaw_rhor,sigcme_k)
2427 : : else
2428 : 9 : write(msg,'(a1)') ' '
2429 : 9 : call wrtout(std_out, msg)
2430 : 9 : write(msg,'(a44,i5)') ' Skipping the calc. of Sigma_c for k-point: ',ik_ibz
2431 : 9 : call wrtout(std_out, msg)
2432 : 9 : write(msg,'(a1)') ' '
2433 : 9 : call wrtout(std_out, msg)
2434 : : end if
2435 : : end if
2436 : :
2437 : : ! MRM: compute density matrix numerical correction (freq. integration G0 Sigma_c(iw) G0).
2438 [ + + ]: 469 : if (rdm_update) then
2439 [ + + ]: 30 : if (sigmak_todo(ik_ibz) == 1) then
2440 : : ! Only recompute correlation update to the 1-RDM if the point read was broken or not precomputed
2441 [ + + ]: 27 : if (x1rdm /= 1) then
2442 [ - + + - : 1334 : ABI_CALLOC(rdm_k, (ib1:ib2,ib1:ib2))
- + + - +
- + - - +
- + - + +
+ + + ]
2443 : 21 : call calc_rdmc(ib1, ib2, ik_ibz, Sr%omega_i, weights, sigcme_k, qp_ebands, rdm_k)
2444 : : ! Update the full 1RDM with the GW corrected one for this k-point
2445 : : ! Only restricted closed-shell calcs
2446 [ + + + + ]: 1271 : rdm_k(ib1:ib2,ib1:ib2) = xrdm_k_full(ib1:ib2,ib1:ib2,ik_ibz) + rdm_k(ib1:ib2,ib1:ib2)
2447 : : ! Compute nat orbs and occ numbers at k-point ik_ibz
2448 : 21 : call natoccs(ib1, ib2, rdm_k, nateigv, nat_occs, qp_ebands, ik_ibz, iinfo=1)
2449 [ - + ]: 21 : ABI_FREE(rdm_k)
2450 : : endif
2451 : : ! Print the checkpoint file if required
2452 [ + + ]: 27 : if (prtchkprdm) then
2453 : 6 : gw1rdm_fname = trim(dtfil%fnameabo_chkp_rdm)
2454 : 6 : call print_chkprdm(Wfd,nat_occs,nateigv,ik_ibz,my_rank,gw1rdm_fname)
2455 : : end if
2456 : : end if
2457 : : else
2458 [ + + + + : 213867 : sigcme(:,ib1:ib2,ib1:ib2,ikcalc,:) = sigcme_k
+ + + + ]
2459 : : end if
2460 [ - + ]: 635 : ABI_FREE(sigcme_k)
2461 : : end do
2462 : 166 : call xmpi_barrier(Wfd%comm)
2463 [ + + ]: 166 : if (rdm_update) then
2464 [ - + ]: 5 : ABI_FREE(xrdm_k_full)
2465 [ - + ]: 5 : ABI_FREE(weights)
2466 : : end if
2467 : : end if
2468 : :
2469 : 201 : call xmpi_barrier(Wfd%comm)
2470 [ - + ]: 201 : ABI_FREE(sigmak_todo)
2471 : :
2472 : : ! 1) Print WFK and DEN files.
2473 : : ! 2) Build band corrections and compute new energies.
2474 [ + + ]: 201 : if (rdm_update) then
2475 [ - + + - : 19025 : ABI_CALLOC(gw_rhor, (nfftf, dtset%nspden))
- + + - +
- + - - +
- + - + +
+ + + ]
2476 : : !
2477 : : ! NRM WARNING: only the master has bands on Wfd_nato_master so it prints everything and computes gw_rhor
2478 : : !
2479 : : ! All procs. update the qp_ebands and the Hdr_sigma
2480 : 5 : call update_hdr_bst(Wfd_nato_master, nat_occs, b1gw, b2gw, qp_ebands, Hdr_sigma, Dtset%ngfft(1:3))
2481 : :
2482 : : ! Compute unit cell (averaged) occ = \sum _k weight_k occ_k
2483 : 5 : call print_tot_occ(qp_ebands)
2484 : :
2485 [ + - ]: 5 : if (my_rank == master) then
2486 : 5 : call Wfd_nato_master%rotate(cryst, nateigv, bmask=bdm_mask) ! Let it use bdm_mask and build NOs
2487 : 5 : call Wfd_nato_master%mkrho(cryst, psps, qp_ebands, ngfftf, nfftf, gw_rhor) ! Construct the density
2488 [ + - ]: 5 : if (dtset%prtwf == 1) then
2489 : : ! Print WFK file, here qp_ebands contains nat. orb. occs.
2490 : 5 : call Wfd_nato_master%write_wfk(Hdr_sigma, qp_ebands, dtfil%fnameabo_wfk, wfknocheck=.True.)
2491 : : end if
2492 [ + - ]: 5 : if (dtset%prtden == 1) then
2493 : : ! Print DEN file
2494 : : call fftdatar_write("density",dtfil%fnameabo_den,dtset%iomode,Hdr_sigma,&
2495 : 5 : Cryst,ngfftf,cplex1,nfftf,dtset%nspden,gw_rhor,mpi_enreg_seq,ebands=qp_ebands)
2496 : : end if
2497 : : end if
2498 : 5 : call xmpi_bcast(gw_rhor,master, Wfd%comm, ierr)
2499 : :
2500 : : ! We no longer need Wfd_nato_master.
2501 : 5 : call Wfd_nato_master%free()
2502 : 5 : call xmpi_barrier(Wfd%comm)
2503 : :
2504 [ - + ]: 5 : ABI_FREE(bdm_mask) ! The master already used bdm_mask
2505 [ - + ]: 5 : ABI_FREE(nat_occs) ! Occs were already placed in qp_ebands
2506 : 5 : call epsm1%free() ! We no longer need epsm1 for GW@KS-DFT 1RDM but we may need space on the RAM memory
2507 : :
2508 [ + + + - ]: 5 : if (gw1rdm==2 .and. Sigp%nkptgw==Wfd%nkibz) then
2509 : : ! Compute energies only if all k-points are available
2510 : : ! We need the hole 1-RDM to build Fock[GW.1RDM]!
2511 [ - + + - : 232 : ABI_CALLOC(old_ks_purex, (b1gw:b2gw, Sigp%nkptgw))
- + + - +
- + - - +
- + - + +
+ + + ]
2512 [ - + + - : 228 : ABI_CALLOC(new_hartr, (b1gw:b2gw, Sigp%nkptgw))
- + + - -
+ - + - +
+ + + + ]
2513 [ - + + - : 33012 : ABI_CALLOC(gw_rhog, (2, nfftf))
+ - + - -
+ - + + +
+ + ]
2514 [ - + + - : 11012 : ABI_CALLOC(gw_vhartr, (nfftf))
+ - + - -
+ - + +
+ ]
2515 : : !
2516 : : ! A) Compute Evext = int rho(r) vext(r) dr -> simply dot product on the FFT grid
2517 : : ! Only restricted closed-shell calcs
2518 : : !
2519 [ + + ]: 11004 : den_int = sum(gw_rhor(:,1)) * ucvol / nfftf
2520 [ + + ]: 11004 : evext_energy = sum(gw_rhor(:,1) * vpsp(:)) * ucvol / nfftf
2521 : : !
2522 : : ! B) Coulomb <KS_i|Vh[NO]|KS_j>
2523 : : !
2524 : : ! FFT to build gw_rhog
2525 : 4 : call fourdp(1, gw_rhog, gw_rhor(:,1), -1, MPI_enreg_seq, nfftf, ndat1, ngfftf, tim_fourdp5)
2526 : 4 : ecutf = dtset%ecut
2527 [ - + ]: 4 : if (psps%usepaw == 1) then
2528 : 0 : ecutf = dtset%pawecutdg
2529 : 0 : call wrtout(std_out, ch10//' FFT (fine) grid used in PAW GW update:')
2530 : : end if
2531 : 4 : call getcut(boxcut, ecutf, gmet, gsqcut, dtset%iboxcut, std_out, k0, ngfftf)
2532 : : call hartre(1, gsqcut, dtset%icutcoul, psps%usepaw, MPI_enreg_seq, nfftf, ngfftf, dtset%nkpt, dtset%rcut, &
2533 : 4 : gw_rhog, cryst%rprimd, dtset%vcutgeo, gw_vhartr)
2534 : :
2535 : : ! Build Vhartree -> gw_vhartr
2536 [ - + + - : 92 : ABI_ICALLOC(tmp_kstab, (2,Wfd%nkibz,Wfd%nsppol))
- + + - +
- + - - +
- + + + +
+ + + ]
2537 [ + + ]: 8 : do spin=1,Sigp%nsppol
2538 [ + + ]: 32 : do ikcalc=1,Sigp%nkptgw
2539 : 24 : ik_ibz = Kmesh%tab(Sigp%kptgw2bz(ikcalc))
2540 : 24 : tmp_kstab(1,ik_ibz,spin)=Sigp%minbnd(ikcalc,spin)
2541 : 28 : tmp_kstab(2,ik_ibz,spin)=Sigp%maxbnd(ikcalc,spin)
2542 : : end do
2543 : : end do
2544 : :
2545 : : ! Build matrix elements from gw_vhartr -> GW1RDM_me
2546 : : call calc_vhxc_me(Wfd,KS_mflags,GW1RDM_me,Cryst,Dtset,nfftf,ngfftf,&
2547 : : ks_vtrial,gw_vhartr,ks_vxc,Psps,Pawtab,KS_paw_an,Pawang,Pawfgrtab,KS_paw_ij,dijexc_core,&
2548 : 4 : gw_rhor,usexcnhat,ks_nhat,ks_nhatgr,nhatgrdim,tmp_kstab,taur=ks_taur)
2549 : :
2550 : 4 : call xmpi_barrier(Wfd%comm)
2551 [ - + ]: 4 : ABI_FREE(tmp_kstab)
2552 [ - + ]: 4 : ABI_FREE(gw_rhor)
2553 [ - + ]: 4 : ABI_FREE(gw_rhog)
2554 [ - + ]: 4 : ABI_FREE(gw_vhartr)
2555 : :
2556 : : ! Save new <i|Hartree[NO]|i> in KS basis for Delta eik
2557 [ + + ]: 28 : do ikcalc=1,Sigp%nkptgw
2558 : 24 : ik_ibz=Kmesh%tab(Sigp%kptgw2bz(ikcalc)) ! Index of the irreducible k-point for GW
2559 [ + + ]: 48 : ib1=MINVAL(Sigp%minbnd(ikcalc,:)) ! min and max band indices for GW corrections (for this k-point)
2560 [ + + ]: 48 : ib2=MAXVAL(Sigp%maxbnd(ikcalc,:))
2561 [ + + ]: 220 : do ib=b1gw,b2gw
2562 : 216 : new_hartr(ib,ikcalc)=GW1RDM_me%vhartree(ib,ib,ik_ibz,1)
2563 : : end do
2564 : : end do
2565 : : !
2566 : : ! C) Exchange <KS_i|hyb*K^RANGE-SEP?[KS]|KS_j> and save it in old_ks_purex
2567 : : !
2568 : : ! Build Vcp_ks and Vcp_full
2569 : 4 : call setup_vcp(Vcp_ks,Vcp_full,Dtset,Gsph_x,Gsph_c,Cryst,Qmesh,Kmesh,coef_hyb,comm)
2570 : 4 : call xmpi_barrier(Wfd%comm)
2571 [ - + ]: 4 : if (coef_hyb > tol8) then
2572 [ # # ]: 0 : do ikcalc=1,Sigp%nkptgw
2573 : 0 : ik_ibz=Kmesh%tab(Sigp%kptgw2bz(ikcalc)) ! Index of the irreducible k-point for GW
2574 [ # # ]: 0 : ib1=MINVAL(Sigp%minbnd(ikcalc,:)) ! min and max band indices for GW corrections (for this k-point)
2575 [ # # ]: 0 : ib2=MAXVAL(Sigp%maxbnd(ikcalc,:))
2576 : : ! Notice we need KS occs and band energy diffs
2577 : : call calc_sigx_me(ik_ibz,ikcalc,ib1,ib2,Cryst,ks_ebands,dtset, Sigp,Sr,Gsph_x,Vcp_ks,Kmesh,Qmesh,Ltg_k(ikcalc),&
2578 : : Pawtab,Pawang,Paw_pwff,Pawfgrtab,Paw_onsite,Psps,Wfd,Wfdf,QP_sym,&
2579 [ # # ]: 0 : gwx_ngfft,ngfftf,Dtset%prtvol,Dtset%pawcross,tol_empty)
2580 : :
2581 : : ! Build <KS_i|RS?_Hyb?_Sigma_x[KS]|KS_j> matrix (Use Wfd)
2582 : 0 : call xmpi_barrier(Wfd%comm)
2583 [ # # ]: 0 : do ib=b1gw,b2gw
2584 : : ! Save old alpha*<i|K[KS]|i> from the GS calc. for Delta eik
2585 : 0 : old_ks_purex(ib,ikcalc)=Sr%x_mat(ib,ib,ik_ibz,1)
2586 : : end do
2587 : : end do
2588 : : endif
2589 : 4 : call xmpi_barrier(Wfd%comm)
2590 : 4 : call Vcp_ks%free()
2591 : :
2592 : : ! Use the Wfd with 'new name' (Wfd_nato_all) because it will contain the GW 1RDM nat. orbs. (bands)
2593 : 4 : ABI_COMMENT("From now on, the Wfd bands will contain the nat. orbs. ones")
2594 : 4 : Wfd_nato_all => Wfd
2595 : : ! Let rotate build the NOs in Wfd_nato_all (KS->NO)
2596 : 4 : call Wfd_nato_all%rotate(Cryst, nateigv)
2597 : 4 : call xmpi_barrier(Wfd%comm)
2598 : : !
2599 : : ! D) Non-local <NO_i|Vnl|NO_i> terms [saved on nl_bks(band,k,spin)]
2600 : : !
2601 [ - + ]: 4 : call Wfd_nato_all%get_nl_me(Cryst,Psps,Pawtab,bdm2_mask,nl_bks)
2602 : 4 : evextnl_energy=zero
2603 [ + + ]: 8 : do spin=1,Sigp%nsppol
2604 [ + + ]: 32 : do ikcalc=1,Sigp%nkptgw
2605 [ + + ]: 220 : do ib=Sr%b1gw,Sr%b2gw
2606 : 216 : evextnl_energy=evextnl_energy+Kmesh%wt(ikcalc)*qp_ebands%occ(ib,ikcalc,spin)*nl_bks(ib,ikcalc,spin)
2607 : : end do
2608 : : end do
2609 : : end do
2610 : 4 : call xmpi_barrier(Wfd%comm)
2611 [ - + ]: 4 : ABI_FREE(nl_bks)
2612 [ - + ]: 4 : ABI_FREE(bdm2_mask)
2613 : : !
2614 : : ! E) Exchange <NO_i|K[NO]|NO_j>
2615 : : !
2616 : : ! Get the matrix elements and save them on Sr%x_mat
2617 : 4 : tol_empty=0.0001 ! Allow lower occ numbers
2618 [ + + ]: 28 : do ikcalc=1,Sigp%nkptgw
2619 : 24 : ik_ibz=Kmesh%tab(Sigp%kptgw2bz(ikcalc)) ! Index of the irreducible k-point for GW
2620 [ + + ]: 48 : ib1=MINVAL(Sigp%minbnd(ikcalc,:)) ! min and max band indices for GW corrections (for this k-point)
2621 [ + + ]: 48 : ib2=MAXVAL(Sigp%maxbnd(ikcalc,:))
2622 : :
2623 : : ! Build <NO_i|Sigma_x[NO]|NO_j> matrix
2624 : : call calc_sigx_me(ik_ibz,ikcalc,ib1,ib2,Cryst,qp_ebands,dtset, Sigp,Sr,Gsph_x,Vcp_full,Kmesh,Qmesh,Ltg_k(ikcalc),&
2625 : : Pawtab,Pawang,Paw_pwff,Pawfgrtab,Paw_onsite,Psps,Wfd_nato_all,Wfdf,QP_sym,&
2626 [ - + ]: 28 : gwx_ngfft,ngfftf,Dtset%prtvol,Dtset%pawcross,tol_empty)
2627 : : end do
2628 : 4 : tol_empty=0.01 ! Recover standard value for tolerance on the occ numbers
2629 : 4 : call xmpi_barrier(Wfd%comm)
2630 : 4 : call Vcp_full%free()
2631 : : ! Save the new total exchange energy Ex = Ex[GW.1RDM]
2632 : 4 : ex_energy = Sr%get_exene(Kmesh, qp_ebands)
2633 : : ! Save the new total exchange-correlation MBB energy Exc = Exc^MBB[GW.1RDM]
2634 : 4 : exc_mbb_energy = Sr%get_excene(Kmesh,qp_ebands)
2635 : :
2636 : : ! Transform <NO_i|K[NO]|NO_j> -> <KS_i|K[NO]|KS_j>,
2637 : : ! <KS_i|J[NO]|KS_j> -> <NO_i|J[NO]|NO_j>,
2638 : : ! and <KS_i|T|KS_j> -> <NO_i|T|NO_j>
2639 : : !
2640 : 4 : call change_matrix(Sigp,Sr,GW1RDM_me,Kmesh,nateigv)
2641 : 4 : call xmpi_barrier(Wfd%comm) ! Wait for all Sigma_x to be ready before deallocating data
2642 : :
2643 : : ! Print Delta eik and band (state) energies
2644 : : !
2645 : 4 : call print_band_energies(b1gw,b2gw,Sr,Sigp,KS_me,Kmesh,ks_ebands,new_hartr,old_ks_purex)
2646 : 4 : call xmpi_barrier(Wfd%comm) ! Wait for all Sigma_x to be ready before deallocating data
2647 : : !
2648 : : ! Print the updated total energy and all energy components
2649 : : !
2650 : 4 : eh_energy = Sr%get_haene(GW1RDM_me,Kmesh,qp_ebands)
2651 : 4 : ekin_energy = Sr%get_kiene(GW1RDM_me,Kmesh,qp_ebands)
2652 : : ! SD 2-RDM
2653 : 4 : etot_sd=ekin_energy+evext_energy+evextnl_energy+QP_energies%e_corepsp+QP_energies%e_ewald+eh_energy+ex_energy
2654 : : ! MBB 2-RDM
2655 : 4 : etot_mbb=ekin_energy+evext_energy+evextnl_energy+QP_energies%e_corepsp+QP_energies%e_ewald+eh_energy+exc_mbb_energy
2656 : : call print_total_energy(ekin_energy,evext_energy,evextnl_energy,QP_energies%e_corepsp,eh_energy,ex_energy,&
2657 : 4 : exc_mbb_energy,QP_energies%e_ewald,etot_sd,etot_mbb,den_int)
2658 : : !
2659 : : ! Clean GW1RDM_me and allocated arrays
2660 : : !
2661 : 4 : call xmpi_barrier(Wfd%comm) ! Wait for all Sigma_x to be ready before deallocating data
2662 : 4 : call GW1RDM_me%free() ! Deallocate GW1RD_me
2663 [ - + ]: 4 : ABI_FREE(old_ks_purex)
2664 [ - + ]: 8 : ABI_FREE(new_hartr)
2665 : : else
2666 [ - + ]: 1 : ABI_FREE(gw_rhor)
2667 [ - + ]: 1 : ABI_FREE(bdm2_mask)
2668 : : end if
2669 [ - + ]: 5 : ABI_FREE(nateigv)
2670 : : endif
2671 : :
2672 : 201 : call xmpi_barrier(Wfd%comm)
2673 : :
2674 : : ! MRM: skip the rest for rdm_update=true (density matrix update)
2675 [ + + ]: 201 : if (.not.rdm_update) then
2676 : : ! =====================================================
2677 : : ! ==== Solve Dyson equation storing results in Sr% ====
2678 : : ! =====================================================
2679 : : ! * Use perturbative approach or AC to find QP corrections.
2680 : : ! * If qp-GW, diagonalize also H0+Sigma in the KS basis set to get the
2681 : : ! new QP amplitudes and energies (Sr%eigvec_qp and Sr%en_qp_diago.
2682 : : ! TODO AC with spinor not implemented yet.
2683 : : ! TODO Diagonalization of Sigma+hhartre with AC is wrong.
2684 : : !
2685 : 196 : call timab(425,1,tsec) ! solve_dyson
2686 [ + + ]: 805 : do ikcalc=1,Sigp%nkptgw
2687 : 609 : ik_ibz=Kmesh%tab(Sigp%kptgw2bz(ikcalc)) ! Index of the irred k-point for GW
2688 [ + + ]: 1226 : ib1=MINVAL(Sigp%minbnd(ikcalc,:)) ! min and max band indices for GW corrections (for this k-point)
2689 [ + + ]: 1226 : ib2=MAXVAL(Sigp%maxbnd(ikcalc,:))
2690 : :
2691 [ - + + - : 3654 : ABI_MALLOC(sigcme_k,(nomega_sigc,ib2-ib1+1,ib2-ib1+1,Sigp%nsppol*Sigp%nsig_ab))
+ - - + +
- - + + -
- + + - +
- + - - +
- + - + ]
2692 [ + - + - : 274882 : sigcme_k=sigcme(:,ib1:ib2,ib1:ib2,ikcalc,:)
+ - - + -
- + + + +
+ + + + ]
2693 : :
2694 : : call solve_dyson(ikcalc, ib1, ib2, nomega_sigc, dtset, Sigp, Kmesh, sigcme_k, qp_ebands%eig, &
2695 : 609 : Sr, ks_me, Dtfil, Wfd%comm)
2696 [ - + ]: 609 : ABI_FREE(sigcme_k)
2697 : : !
2698 : : ! Calculate direct gap for each spin and print out final results.
2699 : : ! We use the valence index of the KS system because we still do not know
2700 : : ! all the QP corrections. Ideally one should use the QP valence index
2701 [ + + ]: 1226 : do spin=1,Sigp%nsppol
2702 [ + + + + ]: 617 : if (Sigp%maxbnd(ikcalc,spin) >= ks_vbik(ik_ibz,spin)+1 .and. &
2703 : 609 : Sigp%minbnd(ikcalc,spin) <= ks_vbik(ik_ibz,spin) ) then
2704 : 597 : ks_iv=ks_vbik(ik_ibz,spin)
2705 : 597 : Sr%egwgap (ik_ibz,spin)= Sr%egw(ks_iv+1,ik_ibz,spin) - Sr%egw(ks_iv,ik_ibz,spin)
2706 : 597 : Sr%degwgap(ik_ibz,spin)= Sr%degw(ks_iv+1,ik_ibz,spin) - Sr%degw(ks_iv,ik_ibz,spin)
2707 : : else
2708 : : ! The "gap" cannot be computed
2709 : 20 : Sr%e0gap(ik_ibz,spin)=zero; Sr%egwgap (ik_ibz,spin)=zero; Sr%degwgap(ik_ibz,spin)=zero
2710 : : end if
2711 : : end do
2712 : :
2713 [ + + ]: 805 : if (wfd%my_rank == master) call Sr%write_results(ikcalc, ik_ibz, Sigp, ks_ebands)
2714 : : end do !ikcalc
2715 : :
2716 : 196 : call timab(425,2,tsec) ! solve_dyson
2717 : 196 : call timab(426,1,tsec) ! finalize
2718 : :
2719 : : ! Update the energies in qp_ebands
2720 : : ! If QPSCGW, use diagonalized eigenvalues otherwise perturbative results.
2721 [ + + ]: 196 : if (gwcalctyp>=10) then
2722 [ + + ]: 941 : do ib=1,Sigp%nbnds
2723 [ + + + + ]: 6837 : qp_ebands%eig(ib,:,:)=Sr%en_qp_diago(ib,:,:)
2724 : : end do
2725 : : else
2726 [ + - + - : 25070 : qp_ebands%eig=Sr%egw
+ - - + -
- - - - -
- - + + +
+ + + ]
2727 : : end if
2728 : :
2729 : : ! ================================================================================
2730 : : ! ==== This part is done only if all k-points in the IBZ have been calculated ====
2731 : : ! ================================================================================
2732 [ + + ]: 196 : if (Sigp%nkptgw==Kmesh%nibz) then
2733 : :
2734 : : ! Recalculate new occupations and Fermi level.
2735 : 86 : call qp_ebands%update_occ(Dtset%spinmagntarget,prtvol=Dtset%prtvol)
2736 : 86 : qp_vbik(:,:) = qp_ebands%get_valence_idx()
2737 : :
2738 : 86 : write(msg,'(2a,3x,2(es16.6,a))')ch10,' New Fermi energy : ',qp_ebands%fermie,' Ha ,',qp_ebands%fermie*Ha_eV,' eV'
2739 : 86 : call wrtout(units, msg)
2740 : :
2741 : : ! === If all k-points and all occupied bands are calculated, output EXX ===
2742 : : ! FIXME here be careful about the check on ks_vbik in case of metals
2743 : : ! if (my_rank==master.and.Sigp%nkptgw==Kmesh%nibz.and.ALL(Sigp%minbnd(:)==1).and.ALL(Sigp%maxbnd(:)>=MAXVAL(nbv(:)))) then
2744 : : ! if (ALL(Sigp%minbnd==1).and. ALL(Sigp%maxbnd>=MAXVAL(MAXVAL(ks_vbik(:,:),DIM=1))) ) then
2745 [ + + + + : 1164 : if (ALL(Sigp%minbnd==1).and. ALL(Sigp%maxbnd>=ks_vbik) ) then ! FIXME here the two arrays use a different indexing.
+ + + + +
+ + - +
+ ]
2746 : :
2747 : 80 : ex_energy = Sr%get_exene(Kmesh,qp_ebands)
2748 : 80 : write(msg,'(a,2(es16.6,a))')' New Exchange energy : ',ex_energy,' Ha ,',ex_energy*Ha_eV,' eV'
2749 : 80 : call wrtout(units, msg)
2750 : : end if
2751 : :
2752 : : ! Report the QP gaps (Fundamental and direct)
2753 : 86 : call qp_ebands%report_gap(header='QP Band Gaps',unit=ab_out)
2754 : :
2755 : : ! Band structure interpolation from QP energies computed on the k-mesh.
2756 [ + + + + : 1146 : if (nint(dtset%einterp(1)) /= 0 .and. all(sigp%minbdgw == sigp%minbnd) .and. all(sigp%maxbdgw == sigp%maxbnd)) then
+ + + + +
+ + + + +
+ - ]
2757 [ + + ]: 3 : call qp_ebands%interpolate_kpath(dtset, cryst, [sigp%minbdgw, sigp%maxbdgw], dtfil%filnam_ds(4), comm)
2758 : : end if
2759 : : end if ! Sigp%nkptgw==Kmesh%nibz
2760 : : !
2761 : : ! Write SCF data in case of self-consistent calculation ===
2762 : : ! Save Sr%en_qp_diago, Sr%eigvec_qp and m_ks_to_qp in the _QPS file.
2763 : : ! Note that in the first iteration qp_rhor contains KS rhor, then the mixed rhor.
2764 [ + + ]: 196 : if (gwcalctyp>=10) then
2765 : : ! Calculate the new m_ks_to_qp
2766 : 71 : call updt_m_ks_to_qp(Sigp,Kmesh,nscf,Sr,Sr%m_ks_to_qp)
2767 : :
2768 [ + + ]: 71 : if (wfd%my_rank == master) then
2769 : : call wrqps(Dtfil%fnameabo_qps,Sigp,Cryst,Kmesh,Psps,Pawtab,QP_Pawrhoij,&
2770 : 55 : Dtset%nspden,nscf,nfftf,ngfftf,Sr,qp_ebands,Sr%m_ks_to_qp,qp_rhor)
2771 : : end if
2772 : :
2773 : : ! Report the MAX variation for each kptgw and spin
2774 : 71 : call wrtout(ab_out,ch10//' Convergence of QP corrections ')
2775 [ + + ]: 144 : do spin=1,Sigp%nsppol
2776 : 73 : write(msg,'(a,i2,a)')' >>>>> For spin ',spin,' <<<<< '
2777 : 73 : call wrtout(ab_out, msg)
2778 [ + + ]: 513 : do ikcalc=1,Sigp%nkptgw
2779 : 369 : ib1 = Sigp%minbnd(ikcalc,spin); ib2 = Sigp%maxbnd(ikcalc,spin)
2780 : 369 : ik_bz = Sigp%kptgw2bz(ikcalc); ik_ibz = Kmesh%tab(ik_bz)
2781 [ + - + + ]: 4143 : ii = imax_loc(ABS(Sr%degw(ib1:ib2,ik_ibz,spin)))
2782 : 369 : max_degw = Sr%degw(ii,ik_ibz,spin)
2783 : 369 : write(msg,('(a,i3,a,2f8.3,a,i3)'))'. kptgw no:',ikcalc,'; Maximum DeltaE = (',max_degw*Ha_eV,') for band index:',ii
2784 : 442 : call wrtout(ab_out, msg)
2785 : : end do
2786 : : end do
2787 : : end if
2788 : :
2789 : : ! ============================================
2790 : : ! ==== Save the GW results in NETCDF file ====
2791 : : ! ============================================
2792 [ + + ]: 196 : if (wfd%my_rank == master) then
2793 [ - + ]: 168 : NCF_CHECK(nctk_open_create(ncid, strcat(dtfil%filnam_ds(4), '_SIGRES.nc'), xmpi_comm_self))
2794 [ + + - + : 336 : NCF_CHECK(nctk_defnwrite_ivars(ncid, ["sigres_version"], [1]))
- - ]
2795 [ - + ]: 168 : NCF_CHECK(cryst%ncwrite(ncid))
2796 [ - + ]: 168 : NCF_CHECK(ks_ebands%ncwrite(ncid))
2797 [ - + ]: 168 : NCF_CHECK(Sr%ncwrite(Sigp, epsm1, Dtset, ncid)) ! WARNING!! If gw1rdm>0 then epsm1 is no longer present!!
2798 : : ! Add qp_rhor. Note that qp_rhor == ks_rhor if wavefunctions are not updated.
2799 : : !ncerr = nctk_write_datar("qp_rhor",path,ngfft,cplex,nfft,nspden,&
2800 : : ! comm_fft,fftn3_distrib,ffti3_local,datar,action)
2801 [ + - ]: 168 : NCF_CHECK(nf90_close(ncid))
2802 : :
2803 : : !if (Sigp%nkptgw==Wfd%nkibz) then
2804 : : ! call write_qpdata(dtset, sr)
2805 : : !end if
2806 : : end if
2807 : : end if ! MRM skipped if GW density matrix update
2808 : : end if ! ucrpa
2809 : :
2810 : : !----------------------------- END OF THE CALCULATION ------------------------
2811 : : !
2812 : : !=====================
2813 : : !==== Close Files ====
2814 : : !=====================
2815 [ + + ]: 201 : if (wfd%my_rank == master) then
2816 : 173 : close(unt_gw); close(unt_gwdiag); close(unt_sig); close(unt_sgr); close(unt_sigc)
2817 [ + + ]: 173 : if (mod10==SIG_GW_AC) close(unt_sgm)
2818 : : end if
2819 : : !
2820 : : !===============================================
2821 : : !==== Free arrays and local data structures ====
2822 : : !===============================================
2823 [ - + ]: 201 : ABI_FREE(ks_vbik)
2824 [ - + ]: 201 : ABI_FREE(qp_vbik)
2825 [ - + ]: 201 : ABI_FREE(ph1d)
2826 [ - + ]: 201 : ABI_FREE(ph1df)
2827 [ - + ]: 201 : ABI_FREE(qp_rhor)
2828 [ - + ]: 201 : ABI_FREE(ks_rhor)
2829 [ - + ]: 201 : ABI_FREE(ks_rhog)
2830 [ - + ]: 201 : ABI_FREE(qp_taur)
2831 [ - + ]: 201 : ABI_FREE(ks_taur)
2832 [ - + ]: 201 : ABI_FREE(ks_vhartr)
2833 [ - + ]: 201 : ABI_FREE(ks_vtrial)
2834 [ - + ]: 201 : ABI_FREE(vpsp)
2835 [ - + ]: 201 : ABI_FREE(ks_vxc)
2836 [ - + ]: 201 : ABI_FREE(xccc3d)
2837 [ - + ]: 201 : ABI_FREE(grchempottn)
2838 [ - + ]: 201 : ABI_FREE(grewtn)
2839 [ - + ]: 201 : ABI_FREE(grvdw)
2840 [ + + ]: 201 : ABI_SFREE(sigcme)
2841 [ + - ]: 201 : ABI_SFREE(kxc)
2842 [ + + ]: 201 : ABI_SFREE(qp_vtrial)
2843 [ - + ]: 201 : ABI_FREE(ks_nhat)
2844 [ - + ]: 201 : ABI_FREE(ks_nhatgr)
2845 [ - + ]: 201 : ABI_FREE(dijexc_core)
2846 [ - + ]: 201 : ABI_FREE(ks_aepaw_rhor)
2847 : 201 : call pawfgr_destroy(Pawfgr)
2848 : :
2849 : : ! Deallocation for PAW.
2850 [ + + ]: 201 : if (Dtset%usepaw==1) then
2851 : 5 : call pawrhoij_free(KS_Pawrhoij)
2852 [ + - + + : 36 : ABI_FREE(KS_Pawrhoij)
- + - + -
+ - + - +
- + - + ]
2853 : 5 : call pawfgrtab_free(Pawfgrtab)
2854 : 5 : call paw_ij_free(KS_paw_ij)
2855 : 5 : call paw_an_free(KS_paw_an)
2856 : 5 : call pawpwff_free(Paw_pwff)
2857 [ - + ]: 5 : if (gwcalctyp>=10) then
2858 : 0 : call pawrhoij_free(QP_pawrhoij)
2859 : 0 : call paw_ij_free(QP_paw_ij)
2860 : 0 : call paw_an_free(QP_paw_an)
2861 : : end if
2862 [ - + ]: 5 : if (Dtset%pawcross==1) then
2863 : 0 : call paw_pwaves_lmn_free(Paw_onsite)
2864 : 0 : call wfdf%free()
2865 : : end if
2866 : : end if
2867 [ + - - + : 201 : ABI_FREE(Paw_onsite)
- - - - -
- - - - -
- + ]
2868 [ + - + + : 232 : ABI_FREE(Pawfgrtab)
- + - + -
+ - + - +
- + - + -
+ - + ]
2869 [ + - + + : 209 : ABI_FREE(Paw_pwff)
- + - + -
+ ]
2870 [ + - + + : 232 : ABI_FREE(KS_paw_ij)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + ]
2871 [ + - + + : 232 : ABI_FREE(KS_paw_an)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + -
+ ]
2872 [ + + ]: 201 : if (gwcalctyp>=10) then
2873 [ + - - + : 76 : ABI_FREE(QP_pawrhoij)
- - - - -
- - - - -
- - - + ]
2874 [ + - - + : 76 : ABI_FREE(QP_paw_an)
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - -
+ ]
2875 [ + - - + : 76 : ABI_FREE(QP_paw_ij)
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - + ]
2876 : : end if
2877 : :
2878 : 201 : call wfd%free(); call destroy_mpi_enreg(MPI_enreg_seq)
2879 : 201 : call Kmesh%free(); call Qmesh%free(); call Gsph_Max%free(); call Gsph_x%free(); call Gsph_c%free()
2880 : 201 : call Vcp%free(); call cryst%free(); call Sr%free()
2881 [ + + ]: 201 : if (.not.rdm_update) call epsm1%free()
2882 : 201 : call PPm%free(); call Hdr_sigma%free(); call Hdr_wfk%free(); call ks_ebands%free();call qp_ebands%free(); call KS_me%free()
2883 : 201 : call littlegroup_free(Ltg_k)
2884 [ + - + + : 840 : ABI_FREE(Ltg_k)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + ]
2885 : 201 : call esymm_free(KS_sym)
2886 [ + - + + : 1433 : ABI_FREE(KS_sym)
- + - + -
+ - + - +
- + - + -
+ - - - -
- + - + -
+ - - - -
- - - + -
- - - - -
- + - - -
- - - -
+ ]
2887 : :
2888 [ + + - + ]: 201 : if (Sigp%symsigma == 1 .and. gwcalctyp>=20) then
2889 : 0 : call esymm_free(QP_sym)
2890 [ # # ]: 0 : ABI_FREE(QP_sym)
2891 : : end if
2892 : :
2893 : 201 : call Sigp%free()
2894 : :
2895 : 201 : call timab(426,2,tsec) ! finalize
2896 : 201 : call timab(401,2,tsec)
2897 : :
2898 : : DBG_EXIT('COLL')
2899 : :
2900 [ - + - + : 1206 : end subroutine sigma
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- - - - -
- - - - -
- - - - -
+ - - - -
- - - - -
- - - - -
- - - - -
- - - - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - - -
- - - - -
- - - - -
- - + - -
- - - - -
- - - - -
- - - - -
- - - - -
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
- - - - -
- - - - -
- - - - +
- - - - -
- - - - -
- - - - -
- - - - -
- - - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
- - - - +
- + - - -
- - + - -
- - - + -
- - - - -
- - - - -
+ - + - +
- + - + -
+ - + - -
- - - + -
+ - - - -
- + - - -
- - + - -
- - - - -
- - - - +
- + - + -
+ - + - +
- + - - -
- - + - +
- - - - -
+ - - - -
- + - - -
- - - - -
- - - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - - -
- - - - -
- - - - -
- - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - - -
- - - - -
- + - - -
- - - - -
- + - + -
+ - + - -
- - - - -
- - - - -
- - - - -
- - + - +
- + - + -
+ - - - -
- - - - -
- - - - -
- + - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - + - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - - -
- - - - -
- - - - -
- - + - +
- + - + -
+ - + - -
- - - + -
- - - - +
- - - - -
+ - + - +
- + - - -
- - - - -
- - - - -
- - - - -
- + - - -
- - - - +
- - - - -
- - - - -
- - - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
- - - - -
- - - - -
- - - - +
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
+ - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - -
- - - - -
- - - - -
- - - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
- - - - -
- - - - -
- - - - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- - - - -
- - - - -
- - - - -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - - - -
- - - - -
- - - - -
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - - -
- - - - -
- - - - -
- - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - -
- - - - -
+ - + ]
2901 : : !!***
2902 : :
2903 : : !!****f* ABINIT/setup_sigma
2904 : : !! NAME
2905 : : !! setup_sigma
2906 : : !!
2907 : : !! FUNCTION
2908 : : !! Initialize the data type containing parameters for a sigma calculation.
2909 : : !!
2910 : : !! INPUTS
2911 : : !! acell(3)=length scales of primitive translations (bohr)
2912 : : !! wfk_fname=Name of the WFK file.
2913 : : !! Dtset<type(dataset_type)>=all input variables for this dataset
2914 : : !! Dtfil<type(datafiles_type)>=variables related to files
2915 : : !! rprim(3,3)=dimensionless real space primitive translations
2916 : : !! Psps <Pseudopotential_type)>=Info on pseudopotential, only for consistency check of the WFK file
2917 : : !!
2918 : : !! OUTPUT
2919 : : !! Sigp<sigparams_t>=Parameters governing the self-energy calculation.
2920 : : !! Kmesh <kmesh_t>=Structure describing the k-point sampling.
2921 : : !! Qmesh <kmesh_t>=Structure describing the q-point sampling.
2922 : : !! Cryst<crystal_t>=Info on unit cell and symmetries.
2923 : : !! Gsph_Max<gsphere_t>=Info on the G-sphere
2924 : : !! Gsph_c<gsphere_t>=Info on the G-sphere for W and Sigma_c
2925 : : !! Gsph_x<gsphere_t>=Info on the G-sphere for and Sigma_x
2926 : : !! Hdr_wfk<hdr_type>=The header of the WFK file
2927 : : !! Hdr_out<hdr_type>=The header to be used for the results of sigma calculations.
2928 : : !! Vcp<vcoul_t>= Datatype gathering information on the coulombian interaction and the cutoff technique.
2929 : : !! epsm1<epsm1_t>=Datatype storing data used to construct the screening (partially Initialized in OUTPUT)
2930 : : !! ks_ebands<ebands_t>=The KS energies and occupation factors.
2931 : : !! gwc_ngfft(18), gwx_ngfft(18)= FFT meshes for the oscillator strengths used for the correlated and the
2932 : : !! exchange part of the self-energy, respectively.
2933 : : !! comm=MPI communicator.
2934 : : !!
2935 : : !! SOURCE
2936 : :
2937 [ - + - + : 21105 : subroutine setup_sigma(codvsn,wfk_fname,acell,rprim,Dtset,Dtfil,Psps,Pawtab,&
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - - - -
- - - - -
- - - - -
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - - -
- - - - -
- - - - -
- - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + + + +
+ + + + +
+ + + + +
+ + + + +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + + + +
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + + +
+ + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + + +
+ + + + +
+ + + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - -
- - - - -
- - - - -
- - + + -
+ - + - +
- + - + -
+ - + - -
- - - - -
- - + - -
- - - - -
- ]
2938 : : gwx_ngfft,gwc_ngfft,Hdr_wfk,Hdr_out,Cryst,Kmesh,Qmesh,ks_ebands,Gsph_Max,Gsph_x,Gsph_c,Vcp,epsm1,Sigp,comm)
2939 : :
2940 : : !Arguments ------------------------------------
2941 : : !scalars
2942 : : integer,intent(in) :: comm
2943 : : character(len=8),intent(in) :: codvsn
2944 : : character(len=*),intent(in) :: wfk_fname
2945 : : type(Datafiles_type),intent(in) :: Dtfil
2946 : : type(Dataset_type),intent(inout) :: Dtset
2947 : : type(Pseudopotential_type),intent(in) :: Psps
2948 : : type(Pawtab_type),intent(in) :: Pawtab(Psps%ntypat*Dtset%usepaw)
2949 : : type(sigparams_t),intent(out) :: Sigp
2950 : : type(epsm1_t),intent(out) :: epsm1
2951 : : type(ebands_t),intent(out) :: ks_ebands
2952 : : type(kmesh_t),intent(out) :: Kmesh,Qmesh
2953 : : type(crystal_t),intent(out) :: Cryst
2954 : : type(gsphere_t),intent(out) :: Gsph_Max,Gsph_x,Gsph_c
2955 : : type(Hdr_type),intent(out) :: Hdr_wfk,Hdr_out
2956 : : type(vcoul_t),intent(out) :: Vcp
2957 : : !arrays
2958 : : integer,intent(out) :: gwc_ngfft(18),gwx_ngfft(18)
2959 : : real(dp),intent(in) :: acell(3),rprim(3,3)
2960 : :
2961 : : !Local variables-------------------------------
2962 : : !scalars
2963 : : integer,parameter :: pertcase0 = 0, master = 0
2964 : : integer :: bantot,enforce_sym,gwcalctyp,ib,ibtot,icutcoul_eff,ii,ikcalc,ikibz,io,isppol,itypat,jj,method
2965 : : integer :: mod10,mqmem,mband,ng_kss,nsheps,ikcalc2bz,ierr,gap_err,ng, nsppol
2966 : : integer :: gwc_nfftot,gwx_nfftot,nqlwl,test_npwkss,my_rank,nprocs,ik,nk_found,ifo,timrev,usefock_ixc
2967 : : integer :: iqbz,isym,iq_ibz,itim,pinv,ig1,ng_sigx,spin,gw_qprange,ivcoul_init,nvcoul_init,xclevel_ixc
2968 : : real(dp),parameter :: OMEGASIMIN=0.01d0
2969 : : real(dp) :: domegas,domegasi,ucvol,rcut, drude_plasmon_freq, wmax
2970 : : logical :: ltest,remove_inv,changed,found,ex
2971 : : character(len=500) :: msg, iw_mesh_type
2972 : : character(len=fnlen) :: fname,fcore
2973 : 201 : type(wvl_internal_type) :: wvl
2974 : 201 : type(gaps_t) :: ks_gaps
2975 : : !arrays
2976 : : integer :: ng0sh_opt(3),G0(3),q_umklp(3),kpos(6), units(2)
2977 : 201 : integer,allocatable :: npwarr(:),val_indices(:,:)
2978 : 201 : integer,pointer :: gvec_kss(:,:),gsphere_sigx_p(:,:)
2979 : 201 : integer,pointer :: test_gvec_kss(:,:)
2980 : : real(dp) :: gmet(3,3),gprimd(3,3),rmet(3,3),rprimd(3,3),sq(3),q_bz(3),gamma_point(3,1)
2981 : 201 : real(dp),pointer :: energies_p(:,:,:)
2982 : 201 : real(dp),allocatable :: doccde(:),eigen(:),occfact(:),qlwl(:,:)
2983 : 201 : type(Pawrhoij_type),allocatable :: Pawrhoij(:)
2984 [ + + + + : 4422 : type(vcoul_t) :: Vcp_ks
+ + + + +
+ - + ]
2985 : : integer :: nbsum
2986 : : real(dp) :: te_min = -one, te_max = one
2987 : : real(dp) :: ft_max_error(3) = -one
2988 : : real(dp) :: cosft_duality_error = -one
2989 : 201 : real(dp),allocatable :: tau_mesh(:), tau_wgs(:), iw_mesh(:), iw_wgs(:)
2990 : 201 : real(dp),allocatable :: cosft_wt(:,:), cosft_tw(:,:), sinft_wt(:,:)
2991 : : ! *************************************************************************
2992 : :
2993 : : DBG_ENTER('COLL')
2994 [ + + ]: 603 : units = [std_out, ab_out]
2995 : 201 : my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm)
2996 : :
2997 : 201 : nsppol = dtset%nsppol
2998 [ + + + - : 1433 : ABI_CHECK(ALL(Dtset%nband(1:Dtset%nkpt*nsppol) == Dtset%nband(1)), 'Dtset%nband(:) must be constant')
- + ]
2999 : :
3000 : : ! Basic parameters
3001 : 201 : Sigp%ppmodel = Dtset%ppmodel
3002 : 201 : Sigp%gwcalctyp = Dtset%gwcalctyp
3003 : 201 : Sigp%nbnds = Dtset%nband(1)
3004 : 201 : Sigp%symsigma = Dtset%symsigma
3005 : 201 : Sigp%zcut = Dtset%zcut
3006 : 201 : Sigp%mbpt_sciss = Dtset%mbpt_sciss
3007 : :
3008 : 201 : timrev= 2 ! This information is not reported in the header
3009 : : ! 1 => do not use time-reversal symmetry
3010 : : ! 2 => take advantage of time-reversal symmetry
3011 [ + + ]: 201 : if (any(dtset%kptopt == [3, 4])) timrev = 1
3012 : :
3013 : : ! For HF, SEX or COHSEX use Hybertsen-Louie PPM (only $\omega=0$) ===
3014 : : ! Use fake screening for HF.
3015 : : ! FIXME Why, we should not redefine Sigp%ppmodel
3016 : 201 : gwcalctyp = Sigp%gwcalctyp
3017 : 201 : mod10 = MOD(Sigp%gwcalctyp, 10)
3018 [ + + ]: 201 : if (any(mod10 == [5, 6, 7])) Sigp%ppmodel=2
3019 [ + + ]: 163 : if (mod10<5 .and. MOD(Sigp%gwcalctyp,1)/=1) then !
3020 : : ! One shot GW (PPM or contour deformation).
3021 [ - + ]: 124 : if (Dtset%nomegasrd==1) then
3022 : : ! avoid division by zero!
3023 : 0 : Sigp%nomegasrd =1
3024 : 0 : Sigp%maxomega4sd=zero
3025 : 0 : Sigp%deltae =zero
3026 : : else
3027 : 124 : Sigp%nomegasrd = Dtset%nomegasrd
3028 : 124 : Sigp%maxomega4sd = Dtset%omegasrdmax
3029 : 124 : Sigp%deltae = (2*Sigp%maxomega4sd)/(Sigp%nomegasrd-1)
3030 : : endif
3031 : : else
3032 : : ! For AC no need to evaluate derivative by finite differences.
3033 : 77 : Sigp%nomegasrd =1
3034 : 77 : Sigp%maxomega4sd=zero
3035 : 77 : Sigp%deltae =zero
3036 : : end if
3037 : :
3038 : : ! Dimensional primitive translations rprimd (from input), gprimd, metrics and unit cell volume
3039 : 201 : call mkrdim(acell,rprim,rprimd)
3040 : 201 : call metric(gmet,gprimd,-1,rmet,rprimd,ucvol)
3041 : :
3042 : 201 : Sigp%npwwfn = Dtset%npwwfn
3043 : 201 : Sigp%npwx = Dtset%npwsigx
3044 : :
3045 : : ! Read parameters of the WFK, verifify them and retrieve all G-vectors.
3046 [ - + ]: 201 : if (dtset%userie == 456) then
3047 : 0 : call wfk_read_eigenvalues("SC_WFK",energies_p,Hdr_wfk,comm)
3048 : : else
3049 : 201 : call wfk_read_eigenvalues(wfk_fname,energies_p,Hdr_wfk,comm)
3050 : : end if
3051 [ + + ]: 1433 : mband = MAXVAL(Hdr_wfk%nband)
3052 : :
3053 : 201 : remove_inv = .FALSE.
3054 [ + - ]: 201 : if (dtset%userie /= 456) then
3055 : 201 : call hdr_wfk%vs_dtset(dtset)
3056 : : end if
3057 : :
3058 : 201 : test_npwkss = 0
3059 : : call make_gvec_kss(Dtset%nkpt,Dtset%kptns,Hdr_wfk%ecut_eff,Dtset%symmorphi,Dtset%nsym,Dtset%symrel,Dtset%tnons,&
3060 : 201 : gprimd,Dtset%prtvol,test_npwkss,test_gvec_kss,ierr)
3061 [ - + ]: 201 : ABI_CHECK(ierr==0, "Fatal error in make_gvec_kss")
3062 : :
3063 [ - + + - : 603 : ABI_MALLOC(gvec_kss,(3, test_npwkss))
+ - + - -
+ - + ]
3064 [ + - + + : 1093537 : gvec_kss = test_gvec_kss
+ + + + +
+ ]
3065 : 201 : ng_kss = test_npwkss
3066 : :
3067 : 201 : ng = MIN(SIZE(gvec_kss,DIM=2),SIZE(test_gvec_kss,DIM=2))
3068 : 201 : ierr = 0
3069 [ + + ]: 136868 : do ig1=1,ng
3070 [ + + + - : 546869 : if (ANY(gvec_kss(:,ig1)/=test_gvec_kss(:,ig1))) then
- + ]
3071 : 0 : ierr=ierr+1
3072 : 0 : write(std_out,*)" gvec_kss ",ig1,"/",ng,gvec_kss(:,ig1),test_gvec_kss(:,ig1)
3073 : : end if
3074 : : end do
3075 [ - + ]: 201 : ABI_CHECK(ierr == 0, "Mismatch between gvec_kss and test_gvec_kss")
3076 [ - + ]: 201 : ABI_FREE(test_gvec_kss)
3077 : :
3078 : : ! Get important dimensions from the WFK header
3079 : 201 : Sigp%nsppol = Hdr_wfk%nsppol
3080 : 201 : Sigp%nspinor = Hdr_wfk%nspinor
3081 : 201 : Sigp%nsig_ab = Hdr_wfk%nspinor**2 ! TODO Is it useful calculating only diagonal terms?
3082 : :
3083 [ - + ]: 201 : if (Sigp%nbnds > mband) then
3084 : : write(msg,'(2a,2(a,i0))') &
3085 : 0 : 'Number of bands stored WFK file is less than required. ',ch10,&
3086 : 0 : "WFK mband: ", mband, ", self-energy nband: ", sigp%nbnds
3087 : 0 : ABI_ERROR(msg)
3088 : : end if
3089 : :
3090 : : ! Check input
3091 [ + + ]: 201 : if (any(Sigp%ppmodel== [3, 4])) then
3092 [ - + ]: 6 : if (gwcalctyp >= 10) then
3093 : 0 : ABI_ERROR(sjoin('The ppmodel chosen and gwcalctyp: ', itoa(Dtset%gwcalctyp),' are not compatible.'))
3094 : : end if
3095 [ - + ]: 6 : if (Sigp%nspinor==2) then
3096 : 0 : ABI_ERROR(sjoin('The ppmodel chosen and nspinor: ', itoa(Sigp%nspinor), ' are not compatible.'))
3097 : : end if
3098 : : end if
3099 : :
3100 : : ! Create crystal_t data type
3101 [ - + - + : 201 : cryst = Hdr_wfk%get_crystal(gw_timrev=timrev, remove_inv=remove_inv)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + ]
3102 : 201 : call cryst%print()
3103 : :
3104 [ + + ]: 201 : if (Sigp%npwwfn > ng_kss) then ! cannot use more G"s for the wfs than those stored on file
3105 : 2 : Sigp%npwwfn =ng_kss
3106 : 2 : Dtset%npwwfn =ng_kss
3107 : : write(msg,'(2a,(a,i0,a))')&
3108 : 2 : 'Number of G-vectors for WFS found in the KSS file is less than required',ch10,&
3109 : 4 : 'calculation will proceed with npwwfn = ',Sigp%npwwfn,ch10
3110 : 2 : ABI_WARNING(msg)
3111 : : end if
3112 : :
3113 [ - + ]: 201 : if (Sigp%npwx>ng_kss) then
3114 : : ! Have to recalculate the (large) sphere for Sigma_x.
3115 [ # # # # ]: 0 : pinv=1; if (remove_inv.and.Cryst%timrev==2) pinv=-1
3116 : 0 : gamma_point(:,1) = (/zero,zero,zero/); nullify(gsphere_sigx_p)
3117 : :
3118 : : call merge_and_sort_kg(1,gamma_point,Dtset%ecutsigx,Cryst%nsym,pinv,Cryst%symrel,&
3119 : 0 : Cryst%gprimd,gsphere_sigx_p,Dtset%prtvol)
3120 : :
3121 : 0 : ng_sigx=SIZE(gsphere_sigx_p,DIM=2)
3122 : 0 : Sigp%npwx = ng_sigx
3123 : 0 : Dtset%npwsigx = ng_sigx
3124 : :
3125 : : write(msg,'(2a,(a,i0,a))')&
3126 : 0 : 'Number of G-vectors for Sigma_x found in the KSS file is less than required',ch10,&
3127 : 0 : 'calculation will proceed with npwsigx = ',Sigp%npwx,ch10
3128 : 0 : ABI_WARNING(msg)
3129 : :
3130 : 0 : ltest = (Sigp%npwx >= ng_kss)
3131 [ # # ]: 0 : ABI_CHECK(ltest,"Sigp%npwx<ng_kss!")
3132 : :
3133 : : ! Fill gvec_kss with larger sphere.
3134 [ # # ]: 0 : ABI_FREE(gvec_kss)
3135 [ # # # # : 0 : ABI_MALLOC(gvec_kss,(3,Sigp%npwx))
# # # # #
# # # ]
3136 [ # # # # : 0 : gvec_kss = gsphere_sigx_p
# # # # #
# ]
3137 [ # # ]: 0 : ABI_FREE(gsphere_sigx_p)
3138 : : end if
3139 : :
3140 : : ! Set up of the k-points and tables in the whole BZ
3141 : : ! TODO Recheck symmorphy and inversion
3142 : 201 : call Kmesh%init(Cryst,Hdr_wfk%nkpt,Hdr_wfk%kptns,Dtset%kptopt,wrap_1zone=.FALSE.)
3143 : : !call Kmesh%init(Cryst,Hdr_wfk%nkpt,Hdr_wfk%kptns,Dtset%kptopt,wrap_1zone=.TRUE.)
3144 : :
3145 : : ! Some required information are not filled up inside kmesh_init
3146 : : ! So doing it here, even though it is not clean
3147 [ + + + + ]: 2613 : Kmesh%kptrlatt(:,:) =Dtset%kptrlatt(:,:)
3148 : 201 : Kmesh%nshift =Dtset%nshiftk
3149 [ - + + - : 603 : ABI_MALLOC(Kmesh%shift,(3,Kmesh%nshift))
+ - + - -
+ - + -
+ ]
3150 [ + + + + ]: 1005 : Kmesh%shift(:,:) =Dtset%shiftk(:,1:Dtset%nshiftk)
3151 : :
3152 : 201 : call Kmesh%print(units, header="K-mesh for the wavefunctions", prtvol=Dtset%prtvol)
3153 : :
3154 : : ! Initialize the band structure datatype
3155 : : ! Copy WFK energies and occupations up to Sigp%nbnds==Dtset%nband(:)
3156 [ + + ]: 1433 : bantot = SUM(Dtset%nband(1:Dtset%nkpt*nsppol))
3157 [ - + + - : 603 : ABI_MALLOC(doccde,(bantot))
+ - + - -
+ - + ]
3158 [ - + + - : 402 : ABI_MALLOC(eigen,(bantot))
- + - + ]
3159 [ - + + - : 402 : ABI_MALLOC(occfact,(bantot))
- + - + ]
3160 [ + + + + : 87711 : doccde(:)=zero; eigen(:)=zero; occfact(:)=zero
+ + ]
3161 : :
3162 : 201 : jj=0; ibtot=0
3163 [ + + ]: 406 : do isppol=1,nsppol
3164 [ + + ]: 1638 : do ikibz=1,Dtset%nkpt
3165 [ + + ]: 46196 : do ib=1,Hdr_wfk%nband(ikibz+(isppol-1)*Dtset%nkpt)
3166 : 44759 : ibtot=ibtot+1
3167 [ + + ]: 45991 : if (ib<=Sigp%nbnds) then
3168 : 29170 : jj=jj+1
3169 : 29170 : occfact(jj)=Hdr_wfk%occ(ibtot)
3170 : 29170 : eigen (jj)=energies_p(ib,ikibz,isppol)
3171 : : end if
3172 : : end do
3173 : : end do
3174 : : end do
3175 [ - + ]: 201 : ABI_FREE(energies_p)
3176 : :
3177 : : ! Make sure that Dtset%wtk==Kmesh%wt due to the dirty treatment of
3178 : : ! symmetry operations in the old GW code (symmorphy and inversion)
3179 [ + + + - ]: 1423 : ltest=(ALL(ABS(Dtset%wtk(1:Kmesh%nibz)-Kmesh%wt(1:Kmesh%nibz))<tol6))
3180 [ - + ]: 201 : ABI_CHECK(ltest,'Mismatch between Dtset%wtk and Kmesh%wt')
3181 : :
3182 [ - + + - : 603 : ABI_MALLOC(npwarr,(Dtset%nkpt))
+ - + - -
+ - + ]
3183 [ + + ]: 1423 : npwarr(:)=Sigp%npwwfn
3184 : :
3185 : : call ks_ebands%init(bantot, Dtset%nelect,Dtset%ne_qFD,Dtset%nh_qFD,Dtset%ivalence,&
3186 : : doccde,eigen,Dtset%istwfk,Kmesh%ibz,Dtset%nband,&
3187 : : Kmesh%nibz,npwarr,nsppol,Dtset%nspinor,Dtset%tphysel,Dtset%tsmear,Dtset%occopt,occfact,Kmesh%wt,&
3188 : : dtset%cellcharge(1), dtset%kptopt, dtset%kptrlatt_orig, dtset%nshiftk_orig, dtset%shiftk_orig,&
3189 : 201 : dtset%kptrlatt, dtset%nshiftk, dtset%shiftk)
3190 : :
3191 [ - + ]: 201 : ABI_FREE(doccde)
3192 [ - + ]: 201 : ABI_FREE(eigen)
3193 [ - + ]: 201 : ABI_FREE(npwarr)
3194 : :
3195 : : ! Calculate KS occupation numbers and ks_vbk(nkibz, nsppol)
3196 : : ! ks_vbk gives the (valence|last Fermi band) index for each k and spin.
3197 : : ! spinmagntarget is passed to fermi.F90 to fix the problem with newocc in case of magnetic metals
3198 : 201 : call ks_ebands%update_occ(Dtset%spinmagntarget, prtvol=0)
3199 : :
3200 [ - + - + : 201 : ks_gaps = ks_ebands%get_gaps(gap_err)
- + - + -
+ - + - +
- + ]
3201 [ + + ]: 402 : call ks_gaps%print([std_out])
3202 : 201 : call ks_ebands%report_gap(unit=std_out)
3203 : :
3204 [ - + + - : 804 : ABI_MALLOC(val_indices,(ks_ebands%nkpt, nsppol))
- + + - +
- + - - +
- + - + ]
3205 [ + - - + : 201 : val_indices = ks_ebands%get_valence_idx()
- - ]
3206 : :
3207 : : ! Create Sigma header
3208 : : ! TODO Fix problems with symmorphy and k-points
3209 : 201 : call Hdr_out%init(ks_ebands,codvsn,Dtset,Pawtab,pertcase0,Psps,wvl)
3210 : :
3211 : : ! Get Pawrhoij from the header of the WFK file
3212 [ + + + - : 634 : ABI_MALLOC(Pawrhoij, (Cryst%natom*Dtset%usepaw))
+ - + + -
+ - + - +
+ + ]
3213 [ + + ]: 201 : if (Dtset%usepaw==1) then
3214 : 5 : call pawrhoij_alloc(Pawrhoij, 1, Dtset%nspden, Dtset%nspinor, nsppol, Cryst%typat, pawtab=Pawtab)
3215 : 5 : call pawrhoij_copy(Hdr_wfk%Pawrhoij, Pawrhoij)
3216 : : end if
3217 : :
3218 : 201 : call hdr_out%update(bantot,1.0d20,1.0d20,1.0d20,1.0d20,Cryst%rprimd,occfact,Pawrhoij,Cryst%xred,dtset%amu_orig(:,1))
3219 [ - + ]: 201 : ABI_FREE(occfact)
3220 : 201 : call pawrhoij_free(Pawrhoij)
3221 [ + - + + : 232 : ABI_FREE(Pawrhoij)
- + - + -
+ - + - +
- + - + ]
3222 : :
3223 : : ! ===========================================================
3224 : : ! ==== Setup of k-points and bands for the GW corrections ====
3225 : : ! ===========================================================
3226 : : ! * maxbdgw and minbdgw are the Max and min band index for GW corrections over k-points.
3227 : : ! They are used to dimension the wavefunctions and to calculate the matrix elements.
3228 : : !
3229 [ + + ]: 201 : if (dtset%nkptgw == 0) then
3230 : : !
3231 : : ! Use qp_range to select the interesting k-points and the corresponding bands.
3232 : : !
3233 : : ! 0 --> Compute the QP corrections only for the fundamental and the direct gap.
3234 : : ! +num --> Compute the QP corrections for all the k-points in the irreducible zone and include `num`
3235 : : ! bands above and below the Fermi level.
3236 : : ! -num --> Compute the QP corrections for all the k-points in the irreducible zone.
3237 : : ! Include all occupied states and `num` empty states.
3238 : :
3239 : 30 : call wrtout(std_out, "nkptgw == 0 ==> Automatic selection of k-points and bands for the corrections.")
3240 : :
3241 [ + + + + ]: 30 : if (gap_err /= 0 .and. dtset%gw_qprange == 0) then
3242 : 1 : msg = "Problem while computing fundamental/direct gap (likely metal). Will replace gw_qprange=0 with gw_qprange=1"
3243 : 1 : ABI_WARNING(msg)
3244 : 1 : dtset%gw_qprange = 1
3245 : : end if
3246 : :
3247 : 30 : gw_qprange = dtset%gw_qprange
3248 : :
3249 [ - + ]: 30 : if (dtset%ucrpa > 0) then
3250 : 0 : dtset%nkptgw = Kmesh%nbz
3251 : 0 : Sigp%nkptgw = dtset%nkptgw
3252 [ # # # # : 0 : ABI_MALLOC(Sigp%kptgw, (3, Sigp%nkptgw))
# # # # #
# # # #
# ]
3253 [ # # # # : 0 : ABI_MALLOC(Sigp%minbnd, (Sigp%nkptgw, nsppol))
# # # # #
# # # # #
# # # # ]
3254 [ # # # # : 0 : ABI_MALLOC(Sigp%maxbnd, (Sigp%nkptgw, nsppol))
# # # # #
# # # #
# ]
3255 [ # # # # ]: 0 : Sigp%kptgw(:,:) = Kmesh%bz(:,:)
3256 [ # # # # ]: 0 : Sigp%minbnd = 1
3257 [ # # # # ]: 0 : Sigp%maxbnd = Sigp%nbnds
3258 : :
3259 [ + + ]: 30 : else if (gw_qprange /= 0) then
3260 : : ! Include all the k-points in the IBZ.
3261 : : ! Note that kptgw == ebands%kptns so we can use a single ik index in the loop over k-points
3262 : : ! No need to map kptgw onto ebands%kptns.
3263 : 25 : dtset%nkptgw = Kmesh%nibz
3264 : 25 : Sigp%nkptgw = dtset%nkptgw
3265 [ - + + - : 75 : ABI_MALLOC(Sigp%kptgw, (3, Sigp%nkptgw))
+ - + - -
+ - + -
+ ]
3266 [ - + + - : 100 : ABI_MALLOC(Sigp%minbnd, (Sigp%nkptgw, nsppol))
- + + - +
- + - - +
- + - + ]
3267 [ - + + - : 75 : ABI_MALLOC(Sigp%maxbnd, (Sigp%nkptgw, nsppol))
- + + - -
+ - + -
+ ]
3268 [ + + + + ]: 649 : Sigp%kptgw(:,:) = Kmesh%ibz(:,:)
3269 [ + + + + ]: 206 : Sigp%minbnd = 1
3270 [ + + + + ]: 206 : Sigp%maxbnd = Sigp%nbnds
3271 : :
3272 [ + + ]: 25 : if (gw_qprange > 0) then
3273 : : ! All k-points: Add buffer of bands above and below the Fermi level.
3274 [ + + ]: 2 : do spin=1,nsppol
3275 [ + + ]: 8 : do ik=1,Sigp%nkptgw
3276 : 6 : Sigp%minbnd(ik, spin) = MAX(val_indices(ik,spin) - gw_qprange, 1)
3277 : 7 : Sigp%maxbnd(ik, spin) = MIN(val_indices(ik,spin) + gw_qprange + 1, Sigp%nbnds)
3278 : : end do
3279 : : end do
3280 : :
3281 : : else
3282 : : ! All k-points: include all occupied states and -gw_qprange empty states.
3283 [ + + + + ]: 198 : Sigp%minbnd = 1
3284 [ + + ]: 48 : do spin=1,nsppol
3285 [ + + ]: 198 : do ik=1,Sigp%nkptgw
3286 : 174 : Sigp%maxbnd(ik, spin) = MIN(val_indices(ik,spin) - gw_qprange, Sigp%nbnds)
3287 : : end do
3288 : : end do
3289 : : end if
3290 : :
3291 : : else
3292 : : ! gw_qprange is not specified in the input.
3293 : : ! Include the direct and the fundamental KS gap.
3294 : : ! The main problem here is that kptgw and nkptgw do not depend on the spin and therefore
3295 : : ! we have compute the union of the k-points where the fundamental and the direct KS gaps are located.
3296 : : !
3297 : : ! Find the list of `interesting` kpoints.
3298 [ - + ]: 5 : ABI_CHECK(gap_err == 0, "gw_qprange 0 cannot be used because I cannot find the gap (gap_err !=0)")
3299 : 5 : nk_found = 1; kpos(1) = ks_gaps%fo_kpos(1,1)
3300 : :
3301 [ + + ]: 10 : do spin=1,nsppol
3302 [ + + ]: 25 : do ifo=1,3
3303 : 15 : ik = ks_gaps%fo_kpos(ifo, spin)
3304 : 15 : found = .FALSE.; jj = 0
3305 [ + + ]: 30 : do while (.not. found .and. jj < nk_found)
3306 : 15 : jj = jj + 1; found = (kpos(jj) == ik)
3307 : : end do
3308 [ + + ]: 20 : if (.not. found) then
3309 : 5 : nk_found = nk_found + 1; kpos(nk_found) = ik
3310 : : end if
3311 : : end do
3312 : : end do
3313 : :
3314 : : ! Now we can define the list of k-points and the bands range.
3315 : 5 : dtset%nkptgw = nk_found
3316 : 5 : Sigp%nkptgw = dtset%nkptgw
3317 : :
3318 [ - + + - : 15 : ABI_MALLOC(Sigp%kptgw,(3, Sigp%nkptgw))
+ - - + -
+ - + ]
3319 [ - + + - : 20 : ABI_MALLOC(Sigp%minbnd, (Sigp%nkptgw, nsppol))
- + + - +
- + - - +
- + - + ]
3320 [ - + + - : 15 : ABI_MALLOC(Sigp%maxbnd, (Sigp%nkptgw, nsppol))
- + + - -
+ - + -
+ ]
3321 : :
3322 [ + + ]: 15 : do ii=1,Sigp%nkptgw
3323 : 10 : ik = kpos(ii)
3324 [ + + ]: 40 : Sigp%kptgw(:,ii) = Kmesh%ibz(:,ik)
3325 [ + + ]: 25 : do spin=1,nsppol
3326 : 10 : Sigp%minbnd(ii,spin) = val_indices(ik, spin)
3327 : 20 : Sigp%maxbnd(ii,spin) = val_indices(ik, spin) + 1
3328 : : end do
3329 : : end do
3330 : : end if
3331 : :
3332 : : else
3333 : : ! Treat only the k-points and bands specified in the input file.
3334 : 171 : Sigp%nkptgw = dtset%nkptgw
3335 [ - + + - : 513 : ABI_MALLOC(Sigp%kptgw, (3, Sigp%nkptgw))
+ - + - -
+ - + -
+ ]
3336 [ - + + - : 684 : ABI_MALLOC(Sigp%minbnd, (Sigp%nkptgw, nsppol))
- + + - +
- + - - +
- + - + ]
3337 [ - + + - : 513 : ABI_MALLOC(Sigp%maxbnd, (Sigp%nkptgw, nsppol))
- + + - -
+ - + -
+ ]
3338 : :
3339 [ + + ]: 346 : do spin=1,nsppol
3340 [ + + ]: 656 : Sigp%minbnd(:,spin)= dtset%bdgw(1,:,spin)
3341 [ + + ]: 827 : Sigp%maxbnd(:,spin)= dtset%bdgw(2,:,spin)
3342 : : end do
3343 : :
3344 [ + + ]: 684 : do ii=1,3
3345 [ + + ]: 2103 : do ikcalc=1,Sigp%nkptgw
3346 : 1932 : Sigp%kptgw(ii,ikcalc) = Dtset%kptgw(ii,ikcalc)
3347 : : end do
3348 : : end do
3349 : :
3350 [ + + ]: 346 : do spin=1,nsppol
3351 [ + + ]: 827 : do ikcalc=1,Sigp%nkptgw
3352 [ - + ]: 656 : if (Dtset%bdgw(2,ikcalc,spin) > Sigp%nbnds) then
3353 : : write(msg,'(a,2i0,2(a,i0),2a,i0)')&
3354 : 0 : "For (k,s) ",ikcalc, spin," bdgw= ",Dtset%bdgw(2,ikcalc,spin), " > nbnds=",Sigp%nbnds,ch10,&
3355 : 0 : "Calculation will continue with bdgw =",Sigp%nbnds
3356 : 0 : ABI_COMMENT(msg)
3357 : 0 : Dtset%bdgw(2, ikcalc, spin) = Sigp%nbnds
3358 : : end if
3359 : : end do
3360 : : end do
3361 : :
3362 : : end if
3363 : :
3364 : : ! Make sure that all the degenerate states are included.
3365 : : ! * We will have to average the GW corrections over degenerate states if symsigma=1 is used.
3366 : : ! * KS states belonging to the same irreducible representation should be included in the basis set used for SCGW.
3367 [ + + + + ]: 201 : if (Sigp%symsigma /=0 .or. gwcalctyp >= 10) then
3368 [ + + ]: 299 : do isppol=1,nsppol
3369 [ + + ]: 869 : do ikcalc=1,Sigp%nkptgw
3370 : :
3371 [ + - ]: 668 : if (kmesh%has_IBZ_item(Sigp%kptgw(:,ikcalc), ikibz, G0)) then
3372 : : call ks_ebands%enclose_degbands(ikibz,isppol, &
3373 : 517 : Sigp%minbnd(ikcalc,isppol),Sigp%maxbnd(ikcalc,isppol),changed,dtset%symsigma_de)
3374 : :
3375 [ + + ]: 517 : if (changed) then
3376 : : write(msg,'(2(a,i0),2a,2(1x,i0))')&
3377 : 48 : "Not all the degenerate states at ikcalc= ",ikcalc,", spin= ",isppol, ch10, &
3378 : 96 : "were included in the bdgw set. bdgw has been changed to: ",Sigp%minbnd(ikcalc,isppol),Sigp%maxbnd(ikcalc,isppol)
3379 : 48 : ABI_COMMENT(msg)
3380 : : end if
3381 : : else
3382 : : write(msg,'(3a)')&
3383 : 0 : ' not in the list of k points treated in the preparatory SCF run.',ch10, &
3384 : 0 : ' Change kptgw, or shiftk of previous run.'
3385 [ # # ]: 0 : ABI_ERROR(sjoin('k-point', ktoa(Sigp%kptgw(:,ikcalc)),trim(msg)))
3386 : : end if
3387 : :
3388 : : end do
3389 : : end do
3390 : : end if
3391 : :
3392 [ + + + + ]: 1053 : Sigp%minbdgw = MINVAL(Sigp%minbnd)
3393 [ + + + + ]: 1053 : Sigp%maxbdgw = MAXVAL(Sigp%maxbnd)
3394 : :
3395 : : ! Check if there are duplicated k-point in Sigp%
3396 [ + + ]: 840 : do ii=1,Sigp%nkptgw
3397 [ + + ]: 2282 : do jj=ii+1,Sigp%nkptgw
3398 [ - + ]: 2081 : if (isamek(Sigp%kptgw(:,ii), Sigp%kptgw(:,jj), G0)) then
3399 : : write(msg,'(5a)')&
3400 : 0 : 'kptgw contains duplicated k-points. This is not allowed since ',ch10,&
3401 : 0 : 'the QP corrections for this k-point will be calculated more than once. ',ch10,&
3402 : 0 : 'Check your input file. '
3403 : 0 : ABI_ERROR(msg)
3404 : : end if
3405 : : end do
3406 : : end do
3407 : :
3408 : : !=== Check if the k-points are in the BZ ===
3409 : : ! FB: Honestly the code is not able to treat k-points, which are not in the input list of points in the IBZ.
3410 : : ! This extension should require to change the code in different places.
3411 : : ! Therefore, one should by now prevent the user from calculating sigma for a k-point not in the IBZ.
3412 [ - + + - : 603 : ABI_MALLOC(Sigp%kptgw2bz, (Sigp%nkptgw))
+ - + - -
+ - + -
+ ]
3413 : :
3414 [ + + ]: 840 : do ikcalc=1,Sigp%nkptgw
3415 [ + - ]: 840 : if (kmesh%has_BZ_item(Sigp%kptgw(:,ikcalc), ikcalc2bz, G0)) then
3416 : 639 : Sigp%kptgw2bz(ikcalc) = ikcalc2bz
3417 : : else
3418 : : write(msg,'(3a)')&
3419 : 0 : ' not in the list of k points treated in the preparatory SCF run.',ch10,' Change kptgw, or shiftk of previous run.'
3420 [ # # ]: 0 : ABI_ERROR(sjoin('k-point:', ktoa(Sigp%kptgw(:,ikcalc)),trim(msg)))
3421 : : end if
3422 : : end do
3423 : :
3424 : : ! Warn the user if SCGW run and not all the k-points are included.
3425 [ + + + + ]: 201 : if (gwcalctyp >= 10 .and. Sigp%nkptgw /= Hdr_wfk%nkpt) then
3426 : 3 : write(msg,'(3a,2(a,i0),2a)')ch10,&
3427 : 3 : " COMMENT: In a self-consistent GW run, the QP corrections should be calculated for all the k-points of the KSS file ",ch10,&
3428 : 3 : " but nkptgw= ",Sigp%nkptgw," and WFK nkpt= ",Hdr_wfk%nkpt,ch10,&
3429 : 6 : " Assuming expert user. Execution will continue. "
3430 : 3 : call wrtout(ab_out, msg)
3431 : : end if
3432 : :
3433 : : ! Setup of the table used in the case of SCGW on wavefunctions to reduce the number
3434 : : ! of elements <i,kgw,s|\Sigma|j,kgw,s> that have to be calculated. No use of symmetries, except for Hermiticity.
3435 : 201 : call sigma_tables(Sigp, Kmesh)
3436 : :
3437 : : ! === Read external file and initialize basic dimension of epsm1 ===
3438 : : ! TODO use mqmem as input variable instead of gwmem
3439 : :
3440 : : ! === If required, use a matrix for $\Sigma_c$ which is smaller than that stored on file ===
3441 : : ! * By default the entire matrix is read and used,
3442 : : ! * Define consistently npweps and ecuteps for \Sigma_c according the input
3443 [ + + - + ]: 201 : if (Dtset%npweps>0.or.Dtset%ecuteps>0) then
3444 [ + - ]: 128 : if (Dtset%npweps>0) Dtset%ecuteps=zero
3445 : 128 : nsheps=0
3446 : 128 : call setshells(Dtset%ecuteps,Dtset%npweps,nsheps,Dtset%nsym,gmet,gprimd,Dtset%symrel,'eps',ucvol)
3447 : : end if
3448 : :
3449 [ + + ]: 201 : mqmem=0; if (Dtset%gwmem/10==1) mqmem=1
3450 : :
3451 [ + + + + : 201 : if (dtset%getscr /=0 .or. dtset%irdscr/=0 .or. dtset%getscr_filepath /= ABI_NOFILE) then
+ + ]
3452 : 161 : fname = Dtfil%fnameabi_scr
3453 [ + + + + ]: 40 : else if (Dtset%getsuscep/=0 .or. Dtset%irdsuscep/=0) then
3454 : 5 : fname = Dtfil%fnameabi_sus
3455 : : else
3456 : 35 : fname = Dtfil%fnameabi_scr
3457 : : !FIXME this has to be cleaned, in tgw2_3 Dtset%get* and Dtset%ird* are not defined
3458 : : !ABI_ERROR("getsuscep or irdsuscep are not defined")
3459 : : end if
3460 : : !
3461 : : ! === Setup of q-mesh in the whole BZ ===
3462 : : ! Stop if a nonzero umklapp is needed to reconstruct the BZ. In this case, indeed,
3463 : : ! epsilon^-1(Sq) should be symmetrized in csigme using a different expression (G-G_o is needed)
3464 : : !
3465 [ + + ]: 201 : if (sigp%needs_w()) then
3466 [ + - ]: 166 : if (.not. file_exists(fname)) then
3467 : 166 : fname = nctk_ncify(fname)
3468 : 166 : ABI_COMMENT(sjoin("File not found. Will try netcdf file:", fname))
3469 : : end if
3470 : :
3471 : : ! Initialize epsm1 from fname.
3472 : 166 : call epsm1%from_file(fname, mqmem, Dtset%npweps, comm)
3473 : :
3474 : 166 : Sigp%npwc=epsm1%npwe
3475 [ + + ]: 166 : if (Sigp%npwc>Sigp%npwx) then
3476 : 14 : Sigp%npwc=Sigp%npwx
3477 : 14 : ABI_COMMENT("Found npw_correlation > npw_exchange, Imposing npwc=npwx")
3478 : : ! There is a good reason for doing so, see csigme.F90 and the size of the arrays
3479 : : ! rhotwgp and rhotwgp: we need to define a max size and we opt for Sigp%npwx.
3480 : : end if
3481 : :
3482 [ + + ]: 166 : if (Dtset%nfreqim_conv==0) then
3483 : : ! If no extra frequencies is requested, keep the original grids.
3484 : 165 : epsm1%nomega_i_conv = 0
3485 [ - + ]: 1 : else if (Dtset%nfreqim_conv < 0) then
3486 : : ! If negative number of frequencies is requested, multiply the number of frequencies in the file by the absolute value.
3487 : 0 : epsm1%nomega_i_conv = abs(Dtset%nfreqim_conv) * epsm1%nomega_i
3488 : 0 : Dtset%nfreqim_conv = epsm1%nomega_i_conv
3489 [ + - ]: 1 : else if (Dtset%nfreqim_conv >= epsm1%nomega_i) then
3490 : : ! If the requested number of frequencies is larger than the number in the file, use input value.
3491 : 1 : epsm1%nomega_i_conv = Dtset%nfreqim_conv
3492 : : else if (Dtset%nfreqim_conv < epsm1%nomega_i) then
3493 : : ! If the requested number of frequencies is less than the number in the file, give an error
3494 : 0 : ABI_ERROR(sjoin("Requested number of frequencies for convolution is non-zero and less than nfreqim in the file: ", itoa(Dtset%nfreqim_conv)," < ", itoa(epsm1%nomega_i)))
3495 : : end if
3496 : :
3497 : 166 : epsm1%npwe=Sigp%npwc
3498 : 166 : Dtset%npweps=epsm1%npwe
3499 : 166 : call Qmesh%init(Cryst,epsm1%nqibz,epsm1%qibz,Dtset%kptopt)
3500 : :
3501 : : else
3502 : 35 : epsm1%npwe =1
3503 : 35 : Sigp%npwc =1
3504 : 35 : Dtset%npweps=1
3505 : 35 : call qmesh%find_qmesh(Cryst,Kmesh)
3506 [ - + - + ]: 35 : ABI_MALLOC(epsm1%gvec,(3,1))
3507 [ + + ]: 140 : epsm1%gvec(:,1) = [0, 0, 0]
3508 : 35 : epsm1%nomega = 0
3509 : : end if
3510 : :
3511 : 201 : call Qmesh%print(units, header="Q-mesh for screening function", prtvol=Dtset%prtvol)
3512 : :
3513 [ + + ]: 10315 : do iqbz=1,Qmesh%nbz
3514 : 10114 : call qmesh%get_BZ_item(iqbz, q_bz, iq_ibz, isym, itim, umklp=q_umklp)
3515 : : !print *, "iqbz, q_bz, iq_ibz, isym, itim, umklp"
3516 : : !print *, iqbz, q_bz, iq_ibz, isym, itim, q_umklp
3517 : :
3518 [ + + + - : 40657 : if (ANY(q_umklp/=0)) then
- + ]
3519 [ # # # # : 0 : sq = (3-2*itim)*MATMUL(Cryst%symrec(:,:,isym),Qmesh%ibz(:,iq_ibz))
# # # # #
# # # #
# ]
3520 : 0 : write(std_out,*) sq,Qmesh%bz(:,iqbz)
3521 : : write(msg,'(a,3f6.3,a,3f6.3,2a,9i3,a,i2,2a)')&
3522 : 0 : 'qpoint ',Qmesh%bz(:,iqbz),' is the symmetric of ',Qmesh%ibz(:,iq_ibz),ch10,&
3523 : 0 : 'through operation ',Cryst%symrec(:,:,isym),' and itim ',itim,ch10,&
3524 : 0 : 'however a non-zero umklapp G_o vector is required and this is not yet allowed'
3525 : 0 : ABI_ERROR(msg)
3526 : : end if
3527 : : end do
3528 : : !stop
3529 : : !
3530 : : ! === Find optimal value for G-sphere enlargement due to oscillator matrix elements ===
3531 : : ! * Here I have to be sure that Qmesh%bz is always inside the BZ, not always true size bz is buggy
3532 : : ! * -one is used because we loop over all the possible differences, unlike screening
3533 : :
3534 : 201 : call get_ng0sh(Sigp%nkptgw,Sigp%kptgw,Kmesh%nbz,Kmesh%bz,Qmesh%nbz,Qmesh%bz,-one,ng0sh_opt)
3535 : 201 : call wrtout(std_out, sjoin(' Optimal value for ng0sh ', ltoa(ng0sh_opt)))
3536 [ + + ]: 804 : Sigp%mG0 = ng0sh_opt
3537 : :
3538 : : ! G-sphere for W and Sigma_c is initialized from the SCR file.
3539 : 201 : call Gsph_c%init(Cryst, epsm1%npwe, gvec=epsm1%gvec)
3540 [ - + ]: 201 : call Gsph_x%init(Cryst, Sigp%npwx, gvec=gvec_kss)
3541 : 201 : Sigp%ecuteps = Gsph_c%ecut
3542 : 201 : Dtset%ecuteps = Sigp%ecuteps
3543 : :
3544 : : ! Make biggest G-sphere of Sigp%npwvec vectors.
3545 : 201 : Sigp%npwvec=MAX(Sigp%npwwfn,Sigp%npwx)
3546 [ - + ]: 201 : call Gsph_Max%init(Cryst, Sigp%npwvec, gvec=gvec_kss)
3547 : :
3548 : : !BEGIN DEBUG
3549 : : !Make sure that the two G-spheres are equivalent.
3550 : : !ierr=0
3551 : : !if (sigp%needs_w()) then
3552 : : ! ng = MIN(SIZE(Gsph_c%gvec,DIM=2),SIZE(gvec_kss,DIM=2))
3553 : : ! do ig1=1,ng
3554 : : ! if (ANY(Gsph_c%gvec(:,ig1)/=gvec_kss(:,ig1))) then
3555 : : ! ierr=ierr+1
3556 : : ! write(std_out,*)" Gsph_c, gvec_kss ",ig1,"/",ng,Gsph_c%gvec(:,ig1),gvec_kss(:,ig1)
3557 : : ! end if
3558 : : ! end do
3559 : : ! ABI_CHECK(ierr==0,"Mismatch between Gsph_c and gvec_kss")
3560 : : !end if
3561 : : !ierr=0
3562 : : !ng = MIN(SIZE(Gsph_x%gvec,DIM=2),SIZE(gvec_kss,DIM=2))
3563 : : !do ig1=1,ng
3564 : : ! if (ANY(Gsph_x%gvec(:,ig1)/=gvec_kss(:,ig1))) then
3565 : : ! ierr=ierr+1
3566 : : ! write(std_out,*)" Gsph_x, gvec_kss ",ig1,"/",ng,Gsph_x%gvec(:,ig1),gvec_kss(:,ig1)
3567 : : ! end if
3568 : : !end do
3569 : : !ABI_CHECK(ierr==0,"Mismatch between Gsph_x and gvec_kss")
3570 : : !END DEBUG
3571 : :
3572 [ - + ]: 201 : ABI_FREE(gvec_kss)
3573 : : !
3574 : : ! === Get Fourier components of the Coulomb term for all q-points in the IBZ ===
3575 : : ! * If required, use a cutoff in the interaction
3576 : : ! * Pcv%vc_sqrt contains Vc^{-1/2}
3577 : : ! * Setup also the analytical calculation of the q->0 component
3578 : : ! FIXME recheck ngfftf since I got different charge outside the cutoff region
3579 : :
3580 [ + - ]: 201 : if (Dtset%gw_nqlwl==0) then
3581 : 201 : nqlwl=1
3582 [ - + ]: 201 : ABI_MALLOC(qlwl,(3,nqlwl))
3583 [ + + ]: 804 : qlwl(:,1)= GW_Q0_DEFAULT
3584 : : else
3585 : 0 : nqlwl=Dtset%gw_nqlwl
3586 [ # # # # : 0 : ABI_MALLOC(qlwl,(3,nqlwl))
# # # # #
# # # ]
3587 [ # # # # ]: 0 : qlwl(:,:)=Dtset%gw_qlwl(:,1:nqlwl)
3588 : : end if
3589 : :
3590 : : ! The Coulomb interaction used here might have two terms:
3591 : : ! the first term generates the usual sigma self-energy, but possibly, one should subtract
3592 : : ! from it the Coulomb interaction already present in the Kohn-Sham basis,
3593 : : ! if the usefock associated to ixc is one.
3594 : : ! The latter excludes (in the present implementation) mod(Dtset%gwcalctyp,10)==5
3595 : 201 : nvcoul_init=1
3596 : 201 : call get_xclevel(Dtset%ixc,xclevel_ixc,usefock_ixc)
3597 : :
3598 [ + + ]: 201 : if(usefock_ixc==1)then
3599 : 3 : nvcoul_init=2
3600 [ - + ]: 3 : if (mod(Dtset%gwcalctyp, 10) == 5)then
3601 : 0 : write(msg,'(4a,i3,a,i3,4a,i5)')ch10,&
3602 : 0 : ' The starting wavefunctions were obtained from SCF calculations in the planewave basis set',ch10,&
3603 : 0 : ' with ixc = ',Dtset%ixc,' associated with usefock =',usefock_ixc,ch10,&
3604 : 0 : ' In this case, the present implementation does not allow that the self-energy for sigma corresponds to',ch10,&
3605 : 0 : ' mod(gwcalctyp,10)==5, while your gwcalctyp= ',Dtset%gwcalctyp
3606 : 0 : ABI_ERROR(msg)
3607 : : endif
3608 : : endif
3609 [ + + ]: 405 : do ivcoul_init=1,nvcoul_init
3610 : 204 : rcut = Dtset%gw_rcut
3611 : 204 : icutcoul_eff=Dtset%gw_icutcoul
3612 : 204 : Sigp%sigma_mixing=one
3613 [ + + + + ]: 204 : if( mod(Dtset%gwcalctyp,10)==5 .or. ivcoul_init==2)then
3614 [ + + ]: 38 : if(abs(Dtset%hyb_mixing)>tol8)then
3615 : : ! Warning: the absolute value is needed, because of the singular way used to define the default for this input variable
3616 : 20 : Sigp%sigma_mixing=abs(Dtset%hyb_mixing)
3617 [ + - ]: 18 : else if(abs(Dtset%hyb_mixing_sr)>tol8)then
3618 : 18 : Sigp%sigma_mixing=abs(Dtset%hyb_mixing_sr)
3619 : 18 : icutcoul_eff=5
3620 : : endif
3621 [ + + + + ]: 38 : if(abs(rcut)<tol6 .and. abs(Dtset%hyb_range_fock)>tol8) rcut=one/Dtset%hyb_range_fock
3622 : : endif
3623 : :
3624 [ + + ]: 405 : if (ivcoul_init == 1) then
3625 : :
3626 [ + + ]: 201 : if (Gsph_x%ng > Gsph_c%ng) then
3627 : : call Vcp%init(Gsph_x,Cryst,Qmesh,Kmesh,rcut,icutcoul_eff,Dtset%vcutgeo,&
3628 : 134 : Dtset%ecutsigx,Gsph_x%ng,nqlwl,qlwl,comm)
3629 : : else
3630 : : call Vcp%init(Gsph_c,Cryst,Qmesh,Kmesh,rcut,icutcoul_eff,Dtset%vcutgeo,&
3631 : 67 : Dtset%ecutsigx,Gsph_c%ng,nqlwl,qlwl,comm)
3632 : : end if
3633 : :
3634 : : else
3635 : :
3636 : : ! Use a temporary Vcp_ks to compute the Coulomb interaction already present
3637 : : ! in the Fock part of the Kohn-Sham Hamiltonian
3638 [ + - ]: 3 : if (Gsph_x%ng > Gsph_c%ng) then
3639 : : call Vcp_ks%init(Gsph_x,Cryst,Qmesh,Kmesh,rcut,icutcoul_eff,Dtset%vcutgeo,&
3640 : 3 : Dtset%ecutsigx,Gsph_x%ng,nqlwl,qlwl,comm)
3641 : : else
3642 : : call Vcp_ks%init(Gsph_c,Cryst,Qmesh,Kmesh,rcut,icutcoul_eff,Dtset%vcutgeo,&
3643 : 0 : Dtset%ecutsigx,Gsph_c%ng,nqlwl,qlwl,comm)
3644 : : end if
3645 : :
3646 : : ! Now compute the residual Coulomb interaction.
3647 [ + - + - : 1194 : Vcp%vc_sqrt_resid=sqrt(Vcp%vc_sqrt**2-Sigp%sigma_mixing*Vcp_ks%vc_sqrt**2)
- + - - +
+ + + ]
3648 : 3 : Vcp%i_sz_resid=Vcp%i_sz-Sigp%sigma_mixing*Vcp_ks%i_sz
3649 : :
3650 : : ! The mixing factor has already been accounted for, so set it back to one
3651 : 3 : Sigp%sigma_mixing=one
3652 : 3 : call Vcp_ks%free()
3653 : :
3654 : : !write(std_out,'(a)')' setup_sigma : the residual Coulomb interaction has been computed'
3655 : : endif
3656 : :
3657 : : !#else
3658 : : ! call Vcp%init(Gsph_Max,Cryst,Qmesh,Kmesh,rcut,icutcoul_eff,ivcoul_init,Dtset%vcutgeo,&
3659 : : !& Dtset%ecutsigx,Sigp%npwx,nqlwl,qlwl,ngfftf,comm)
3660 : : !#endif
3661 : :
3662 : : end do
3663 : :
3664 : : #if 1
3665 : : ! Using the random q for the optical limit is one of the reasons
3666 : : ! why sigma breaks the initial energy degeneracies.
3667 [ - + ]: 201 : if (dtset%userra > 100) then
3668 : 0 : call wrtout(units, "I am setting Vcp%i_sz=zero, Vcp%vc_sqrt(1,1)=czero, Vcp%vcqlwl_sqrt(1,1)=czero")
3669 : 0 : Vcp%i_sz=zero
3670 : 0 : Vcp%vc_sqrt(1,1)=czero
3671 : 0 : Vcp%vcqlwl_sqrt(1,1)=czero
3672 : : end if
3673 : : #endif
3674 : :
3675 [ - + ]: 201 : ABI_FREE(qlwl)
3676 : :
3677 : 201 : Sigp%ecuteps = Dtset%ecuteps
3678 : 201 : Sigp%ecutwfn = Dtset%ecutwfn
3679 : 201 : Sigp%ecutsigx = Dtset%ecutsigx
3680 : :
3681 : : ! === Setup of the FFT mesh for the oscillator strengths ===
3682 : : ! * Init gwc_ngfft(7:18) and gwx_ngfft(7:18) with Dtset%ngfft(7:18)
3683 : : ! * Here we redefine gwc_ngfft(1:6) according to the following options:
3684 : : !
3685 : : ! method == 0 --> FFT grid read from fft.in (debugging purpose)
3686 : : ! method == 1 --> Normal FFT mesh
3687 : : ! method == 2 --> Slightly augmented FFT grid to calculate exactly rho_tw_g (see setmesh.F90)
3688 : : ! method == 3 --> Doubled FFT grid, same as the the FFT for the density,
3689 : : !
3690 : : ! enforce_sym == 1 --> Enforce a FFT mesh compatible with all the symmetry operation and FFT library
3691 : : ! enforce_sym == 0 --> Find the smallest FFT grid compatible with the library, do not care about symmetries
3692 : : !
3693 [ + + ]: 3819 : gwc_ngfft(1:18) = Dtset%ngfft(1:18)
3694 [ + + ]: 3819 : gwx_ngfft(1:18) = Dtset%ngfft(1:18)
3695 : :
3696 : 201 : method = 2
3697 [ - + ]: 201 : if (Dtset%fftgw == 00 .or. Dtset%fftgw == 01) method = 0
3698 [ + + ]: 201 : if (Dtset%fftgw == 10 .or. Dtset%fftgw == 11) method = 1
3699 [ + + ]: 201 : if (Dtset%fftgw == 20 .or. Dtset%fftgw == 21) method = 2
3700 [ - + ]: 201 : if (Dtset%fftgw == 30 .or. Dtset%fftgw == 31) method = 3
3701 : 201 : enforce_sym = mod(dtset%fftgw, 10)
3702 : :
3703 : : ! FFT mesh for sigma_x.
3704 : : call setmesh(gmet, Gsph_Max%gvec, gwx_ngfft, Sigp%npwvec, Sigp%npwx, Sigp%npwwfn, &
3705 : 201 : gwx_nfftot, method, Sigp%mG0, Cryst, enforce_sym)
3706 : :
3707 : : ! FFT mesh for sigma_c.
3708 : : call setmesh(gmet, Gsph_Max%gvec, gwc_ngfft, Sigp%npwvec, epsm1%npwe, Sigp%npwwfn,&
3709 : 201 : gwc_nfftot, method, Sigp%mG0, Cryst, enforce_sym, unit=dev_null)
3710 : :
3711 : : ! ======================================================================
3712 : : ! ==== Check for presence of files with core orbitals, for PAW only ====
3713 : : ! ======================================================================
3714 : 201 : Sigp%use_sigxcore=0
3715 [ + + + + ]: 201 : if (Dtset%usepaw==1.and.Dtset%gw_sigxcore==1) then
3716 : 1 : ii = 0
3717 [ + + ]: 2 : do itypat=1,Cryst%ntypat
3718 : 1 : call pawpsp_check_corefile(fcore,ex,Psps%filpsp(itypat))
3719 [ + - ]: 2 : if (ex) then
3720 : 1 : ii = ii+1
3721 : : else
3722 : 0 : write(msg,'(a,i2)') "HF decoupling is required but cannot find file for itypat:", itypat
3723 : 0 : ABI_WARNING(msg)
3724 : : end if
3725 : : end do
3726 : :
3727 : 1 : Sigp%use_sigxcore=1
3728 [ - + ]: 1 : if (ii/=Cryst%ntypat) then
3729 : 0 : ABI_ERROR("Files with core orbitals not found")
3730 : : end if
3731 : : end if ! PAW+HF decoupling
3732 : : !
3733 : : ! ==============================
3734 : : ! ==== Extrapolar technique ====
3735 : : ! ==============================
3736 : 201 : Sigp%gwcomp = Dtset%gwcomp
3737 : 201 : Sigp%gwencomp = Dtset%gwencomp
3738 : :
3739 [ + + ]: 201 : if (Sigp%gwcomp==1) then
3740 : 19 : write(msg,'(6a,e11.4,a)')ch10,&
3741 : 19 : 'Using the extrapolar approximation to accelerate convergence',ch10,&
3742 : 19 : 'with respect to the number of bands included',ch10,&
3743 : 38 : 'with gwencomp: ',Sigp%gwencomp*Ha_eV,' [eV]'
3744 : 19 : call wrtout(std_out, msg)
3745 : : end if
3746 : : !
3747 : : ! ===================================
3748 : : ! ==== Final compatibility tests ====
3749 : : ! ===================================
3750 [ + + + - : 1433 : ltest=(ks_ebands%mband == Sigp%nbnds .and. ALL(ks_ebands%nband == Sigp%nbnds))
+ - - + ]
3751 : 0 : ABI_CHECK(ltest, 'BUG in definition of ks_ebands%nband')
3752 : :
3753 [ + + ]: 201 : if (mod10==SIG_GW_AC) then
3754 : : !if (Sigp%gwcalctyp/=1) ABI_ERROR("Self-consistency with AC not implemented") ! MRM: let's allow it
3755 [ - + ]: 9 : if (Sigp%gwcomp==1) ABI_ERROR("AC with extrapolar technique not implemented")
3756 : : end if
3757 : :
3758 : : ! For analytic continuation define the number of imaginary frequencies for Sigma
3759 : : ! Tests show than more than 12 freqs in the Pade approximant worsen the results!
3760 : 192 : Sigp%nomegasi = 0
3761 : :
3762 : : !TODO this should not be done here but in init_sigma_t
3763 : : if (mod10 == 1) then
3764 : 9 : Sigp%nomegasi = abs(Dtset%nomegasi)
3765 : 9 : iw_mesh_type = "linear"
3766 [ + + ]: 9 : if (dtset%nomegasi < 0) iw_mesh_type = "minimax"
3767 : 9 : Sigp%omegasimax = Dtset%omegasimax
3768 : 9 : Sigp%omegasimin = OMEGASIMIN
3769 [ - + + - : 27 : ABI_MALLOC(Sigp%omegasi, (Sigp%nomegasi))
+ - + - -
+ - + -
+ ]
3770 : :
3771 : 7 : select case (iw_mesh_type)
3772 : : case ("linear")
3773 : : ! Linear mesh along the imaginary axis.
3774 : 7 : domegasi=Sigp%omegasimax/(Sigp%nomegasi-1)
3775 [ + + ]: 187 : do io=1,Sigp%nomegasi
3776 : 187 : Sigp%omegasi(io)=CMPLX(zero,(io-1)*domegasi)
3777 : : end do
3778 : :
3779 : : case ("minimax")
3780 : : ! Minimax mesh along the imaginary axis.
3781 : 2 : nbsum = sigp%nbnds
3782 : : !call wrtout(std_out, "Computing minimax grid")
3783 : :
3784 : : ! Compute min/max transition energy taking into account nsppol if any.
3785 [ + - - + : 6 : te_min = minval(ks_gaps%cb_min - ks_gaps%vb_max)
- - + + ]
3786 [ + + + + : 16 : te_max = maxval(ks_ebands%eig(nbsum,:,:) - ks_ebands%eig(1,:,:))
+ + + - -
+ - - ]
3787 [ - + ]: 2 : if (te_min <= tol6) then
3788 : 0 : te_min = tol6
3789 : 0 : ABI_ERROR("System is metallic or with a very small fundamental gap! Check energies in WFK file!")
3790 : : end if
3791 : :
3792 : : call gx_minimax_grid(sigp%nomegasi, te_min, te_max, & ! in
3793 : : tau_mesh, tau_wgs, iw_mesh, iw_wgs, & ! out args allocated by the routine.
3794 : : cosft_wt, cosft_tw, sinft_wt, &
3795 [ - + - + : 2 : ft_max_error, cosft_duality_error, ierr)
- + - + -
+ - + -
+ ]
3796 [ - + ]: 2 : ABI_CHECK(ierr == 0, "Error in gx_minimax_grid")
3797 : :
3798 [ + - - + : 34 : Sigp%omegasi = j_dpc * iw_mesh
- - + + ]
3799 : :
3800 [ - + ]: 2 : ABI_FREE_NOCOUNT(tau_mesh)
3801 [ - + ]: 2 : ABI_FREE_NOCOUNT(tau_wgs)
3802 [ - + ]: 2 : ABI_FREE_NOCOUNT(iw_mesh)
3803 [ - + ]: 2 : ABI_FREE_NOCOUNT(iw_wgs)
3804 [ - + ]: 2 : ABI_FREE_NOCOUNT(cosft_wt)
3805 [ - + ]: 2 : ABI_FREE_NOCOUNT(cosft_tw)
3806 [ - + ]: 2 : ABI_FREE_NOCOUNT(sinft_wt)
3807 : :
3808 : : case default
3809 [ + + - ]: 9 : ABI_ERROR(sjoin("Invalid iw_mesh_type:", iw_mesh_type))
3810 : : end select
3811 : :
3812 : 9 : write(msg,'(7a,i3,2(2a,f8.3),a)')ch10,&
3813 : 9 : ' Parameters for the analytic continuation of Sigma_c(i omega): ',ch10,&
3814 : 9 : ' Mesh type: = ',trim(iw_mesh_type), ch10, &
3815 : 9 : ' Number of imaginary frequencies = ',Sigp%nomegasi,ch10,&
3816 [ + - - + : 228 : ' Min frequency on imag axis (eV) = ',minval(aimag(sigp%omegasi)) * Ha_eV,ch10,&
- - + + ]
3817 [ + - - + : 237 : ' Max frequency on imag axis (eV) = ',maxval(aimag(sigp%omegasi)) * Ha_eV,ch10
- - + + ]
3818 : 9 : call wrtout(units, msg)
3819 : :
3820 : : ! MRM: do not print for 1-RDM correction
3821 [ + + ]: 9 : if (Sigp%gwcalctyp /= 21) then
3822 : 4 : write(msg,'(4a)')ch10,&
3823 : 4 : ' setup_sigma: calculating Sigma(iw)',&
3824 : 8 : ' at imaginary frequencies (eV) (Fermi Level set to 0) ',ch10
3825 : 4 : call wrtout(units, msg)
3826 [ + + ]: 54 : do io=1,Sigp%nomegasi
3827 : 50 : write(msg,'(2(f10.3,2x))')Sigp%omegasi(io)*Ha_eV
3828 : 54 : call wrtout(units, msg)
3829 : : end do
3830 : 4 : call wrtout(units, "")
3831 : : endif
3832 : :
3833 [ + - - + ]: 9 : ltest=(Sigp%omegasimax>0.1d-4.and.Sigp%nomegasi>0)
3834 : 0 : ABI_CHECK(ltest,'Wrong value of omegasimax or nomegasi')
3835 : : !if (Sigp%gwcalctyp/=1) then !
3836 : : ! !ABI_ERROR("SC-GW with analytic continuation is not coded") ! MRM: let's allow it
3837 : : !end if
3838 : : end if
3839 : :
3840 [ + + - + ]: 201 : if (Sigp%symsigma/=0.and.gwcalctyp>=20) then
3841 : 0 : ABI_WARNING("SC-GW with symmetries is still under development. Use at your own risk!")
3842 : 0 : ABI_ERROR("SC-GW requires symsigma == 0 in input. New default in Abinit9 is symsigma 1!")
3843 : : end if
3844 : :
3845 : : ! Setup parameters for Spectral function.
3846 [ + + ]: 201 : if (Dtset%gw_customnfreqsp/=0) then
3847 : 1 : Sigp%nomegasr = Dtset%gw_customnfreqsp
3848 : 1 : ABI_WARNING('Custom grid for spectral function specified. Assuming experienced user.')
3849 [ + - ]: 1 : if (Dtset%gw_customnfreqsp/=0) then
3850 : 1 : Dtset%nfreqsp = Dtset%gw_customnfreqsp
3851 : 1 : ABI_WARNING('nfreqsp has been set to the same number as gw_customnfreqsp')
3852 : : end if
3853 : : else
3854 : 200 : Sigp%nomegasr =Dtset%nfreqsp
3855 : 200 : Sigp%minomega_r=Dtset%freqspmin
3856 : 200 : Sigp%maxomega_r=Dtset%freqspmax
3857 : :
3858 : : ! TODO: Mesh should be centered on e0
3859 : : if (mod10 == 1 .and. sigp%nomegasr == 0 .and. Sigp%gwcalctyp /= 21) then
3860 : : ! Note that in AC computing quantities on the real-axis is really cheap
3861 : : ! so we can use very dense meshes without affecting performance.
3862 : : ! The default for nfresp and freqspmax is zero.
3863 : : ! Here we compute wr_step and nwrt so that we have e0 +- the expected plasmom frequency
3864 : : drude_plasmon_freq = sqrt(four_pi * ks_ebands%nelect / cryst%ucvol)
3865 : : wmax = dtset%freqspmax; if (abs(wmax) < tol6) wmax = two * drude_plasmon_freq
3866 : : !sigp%nomegasr = nint(wmax / (0.05_dp * eV_Ha))
3867 : : !if (mod(sigp%nomegasr, 2) == 0) sigp%nomegasr = sigp%nomegasr + 1
3868 : : !sigp%maxomega_r = wmax
3869 : : end if
3870 : :
3871 : : end if
3872 : :
3873 : : ! FIXME: after the definition of Sigp%nomegasr (Sigp is intent(out)).
3874 [ + + + + ]: 201 : if (Dtset%symsigma/=0 .and. Sigp%nomegasr/=0) then
3875 [ - + ]: 1 : if (cryst%idx_spatial_inversion() == 0) then
3876 : 0 : write(msg,'(5a)')' setup_sigma : BUG :',ch10,&
3877 : 0 : 'It is not possible to use symsigma /= 0 to calculate the spectral function ',ch10,&
3878 : 0 : 'when the system does not have the spatial inversion. Please use symsigma=0 '
3879 : 0 : ABI_WARNING(msg)
3880 : : end if
3881 : : end if
3882 : :
3883 [ + + ]: 201 : if (Sigp%nomegasr > 0) then
3884 [ + + ]: 5 : if (Dtset%gw_customnfreqsp == 0) then
3885 : : ! Check
3886 [ - + ]: 4 : if (Sigp%minomega_r >= Sigp%maxomega_r) then
3887 : 0 : ABI_ERROR('freqspmin must be smaller than freqspmax!')
3888 : : end if
3889 : 4 : domegas = zero
3890 [ + - ]: 4 : if(Sigp%nomegasr /= 1) domegas = (Sigp%maxomega_r-Sigp%minomega_r)/(Sigp%nomegasr-1)
3891 : :
3892 : : !TODO this should be moved to Sr% and done in init_sigma_t
3893 [ - + + - : 12 : ABI_MALLOC(Sigp%omega_r,(Sigp%nomegasr))
+ - + - -
+ - + -
+ ]
3894 [ + + ]: 804 : do io=1,Sigp%nomegasr
3895 : 804 : Sigp%omega_r(io) = CMPLX(Sigp%minomega_r + domegas*(io-1),zero)
3896 : : end do
3897 : 4 : write(msg,'(4a,i8,3(2a,f8.3),a)')ch10,&
3898 : 4 : ' Parameters for the calculation of the spectral function : ',ch10,&
3899 : 4 : ' Number of points = ',Sigp%nomegasr,ch10,&
3900 : 4 : ' Min frequency [eV] = ',Sigp%minomega_r*Ha_eV,ch10,&
3901 : 4 : ' Max frequency [eV] = ',Sigp%maxomega_r*Ha_eV,ch10,&
3902 : 8 : ' Frequency step [eV] = ',domegas*Ha_eV,ch10
3903 : 4 : call wrtout(std_out, msg)
3904 : : else
3905 [ + - - + : 10 : Sigp%minomega_r = MINVAL(Dtset%gw_freqsp(:))
- - + + ]
3906 [ + - - + : 10 : Sigp%maxomega_r = MAXVAL(Dtset%gw_freqsp(:))
- - + + ]
3907 : : !TODO this should be moved to Sr% and done in init_sigma_t
3908 [ - + + - : 3 : ABI_MALLOC(Sigp%omega_r, (Sigp%nomegasr))
+ - - + -
+ - + ]
3909 [ + + ]: 9 : do io=1,Sigp%nomegasr
3910 : 9 : Sigp%omega_r(io) = CMPLX(Dtset%gw_freqsp(io), zero)
3911 : : end do
3912 : 1 : write(msg,'(4a,i8,2(2a,f8.3),3a)')ch10,&
3913 : 1 : ' Parameters for the calculation of the spectral function : ',ch10,&
3914 : 1 : ' Number of points = ',Sigp%nomegasr,ch10,&
3915 : 1 : ' Min frequency [eV] = ',Sigp%minomega_r*Ha_eV,ch10,&
3916 : 1 : ' Max frequency [eV] = ',Sigp%maxomega_r*Ha_eV,ch10,&
3917 : 2 : ' A custom set of frequencies is used! See the input file for values.',ch10
3918 : 1 : call wrtout(std_out, msg)
3919 : : end if
3920 : : end if
3921 : :
3922 [ - + ]: 201 : ABI_FREE(val_indices)
3923 : 201 : call ks_gaps%free()
3924 : :
3925 : : DBG_EXIT('COLL')
3926 : :
3927 [ - + - + : 804 : end subroutine setup_sigma
- + - + -
+ - + - +
- + - + -
+ - - - -
- - - - -
- - - - -
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + ]
3928 : : !!***
3929 : :
3930 : : !----------------------------------------------------------------------
3931 : :
3932 : : !!****f* ABINIT/sigma_tables
3933 : : !! NAME
3934 : : !! sigma_tables
3935 : : !!
3936 : : !! FUNCTION
3937 : : !! Build symmetry tables used to speedup self-consistent GW calculations.
3938 : : !!
3939 : : !! INPUTS
3940 : : !! Kmesh <kmesh_t>=Structure describing the k-point sampling.
3941 : : !! [esymm(Kmesh%nibz,Sigp%nsppol)]= Bands_Symmetries
3942 : : !!
3943 : : !! SiDE EFFECTS
3944 : : !! Sigp<sigparams_t>=This routine initializes the tables:
3945 : : !! %Sigcij_tab
3946 : : !! %Sigxij_tab
3947 : : !! that are used to select the matrix elements of the self-energy that have to be calculated.
3948 : : !!
3949 : : !! SOURCE
3950 : :
3951 : 402 : subroutine sigma_tables(Sigp, Kmesh, esymm)
3952 : :
3953 : : use m_sigtk, only : sigtk_sigma_tables
3954 : :
3955 : : !Arguments ------------------------------------
3956 : : !scalars
3957 : : type(sigparams_t),target,intent(inout) :: Sigp
3958 : : type(kmesh_t),intent(in) :: Kmesh
3959 : : !arrays
3960 : : type(esymm_t),optional,intent(in) :: esymm(Kmesh%nibz, Sigp%nsppol)
3961 : :
3962 : : !Local variables-------------------------------
3963 : : !scalars
3964 : : integer :: ikcalc,ik_ibz
3965 : : logical :: sigc_is_herm, only_diago
3966 : : !arrays
3967 : 201 : integer,allocatable :: kcalc2ibz(:)
3968 : : ! *************************************************************************
3969 : :
3970 : 201 : only_diago = sigp%gwcalctyp < 20
3971 : 201 : sigc_is_herm = sigp%is_herm()
3972 : :
3973 [ - + + - : 603 : ABI_MALLOC(kcalc2ibz, (sigp%nkptgw))
+ - + - -
+ - + ]
3974 [ + + ]: 840 : do ikcalc=1,sigp%nkptgw
3975 : 639 : ik_ibz = Kmesh%tab(Sigp%kptgw2bz(ikcalc))
3976 : 840 : kcalc2ibz(ikcalc) = ik_ibz
3977 : : end do
3978 : :
3979 [ - + ]: 201 : if (present(esymm)) then
3980 : : call sigtk_sigma_tables(sigp%nkptgw, kmesh%nibz, sigp%nsppol, sigp%minbnd, sigp%maxbnd, kcalc2ibz, &
3981 : 0 : only_diago, sigc_is_herm, sigp%sigxij_tab, sigp%sigcij_tab, esymm=esymm)
3982 : : else
3983 : : call sigtk_sigma_tables(sigp%nkptgw, kmesh%nibz, sigp%nsppol, sigp%minbnd, sigp%maxbnd, kcalc2ibz, &
3984 : 201 : only_diago, sigc_is_herm, sigp%sigxij_tab, sigp%sigcij_tab)
3985 : : end if
3986 : :
3987 [ - + ]: 201 : ABI_FREE(kcalc2ibz)
3988 : :
3989 : 201 : end subroutine sigma_tables
3990 : : !!***
3991 : :
3992 : : !----------------------------------------------------------------------
3993 : :
3994 : : !!****f* ABINIT/sigma_bksmask
3995 : : !! NAME
3996 : : !! sigma_bksmask
3997 : : !!
3998 : : !! FUNCTION
3999 : : !! Compute tables for the distribution and the storage of the wavefunctions in the SIGMA code.
4000 : : !!
4001 : : !! INPUTS
4002 : : !! Dtset<type(dataset_type)>=all input variables for this dataset
4003 : : !! Sigp<sigparams_t>=Parameters governing the self-energy calculation.
4004 : : !! Kmesh <kmesh_t>=Structure describing the k-point sampling.
4005 : : !! nprocs=Total number of MPI processors
4006 : : !! my_rank=Rank of this this processor.
4007 : : !!
4008 : : !! OUTPUT
4009 : : !! my_spins(:)=Pointer to NULL in input. In output: list of spins treated by this node.
4010 : : !! bks_mask(Sigp%nbnds,Kmesh%nibz,Sigp%nsppol)=True if this node will treat this state.
4011 : : !! keep_ur(Sigp%nbnds,Kmesh%nibz,Sigp%nsppol)=True if this node will store this state in real space.
4012 : : !! ierr=Exit status.
4013 : : !!
4014 : : !! SOURCE
4015 : :
4016 : 201 : subroutine sigma_bksmask(Dtset,Sigp,Kmesh,my_rank,nprocs,my_spins,bks_mask,keep_ur,ierr)
4017 : :
4018 : : !Arguments ------------------------------------
4019 : : !scalars
4020 : : integer,intent(in) :: my_rank,nprocs
4021 : : integer,intent(out) :: ierr
4022 : : type(Dataset_type),intent(in) :: Dtset
4023 : : type(sigparams_t),intent(in) :: Sigp
4024 : : type(kmesh_t),intent(in) :: Kmesh
4025 : : !arrays
4026 : : integer,allocatable,intent(out) :: my_spins(:)
4027 : : logical,intent(out) :: bks_mask(Sigp%nbnds,Kmesh%nibz,Sigp%nsppol)
4028 : : logical,intent(out) :: keep_ur(Sigp%nbnds,Kmesh%nibz,Sigp%nsppol)
4029 : :
4030 : : !Local variables-------------------------------
4031 : : !scalars
4032 : : integer :: my_nspins,my_maxb,my_minb,isp,spin,band,nsppol,rank_spin
4033 : : logical :: store_ur
4034 : : !arrays
4035 : 402 : integer :: tmp_spins(Sigp%nsppol),nprocs_spin(Sigp%nsppol)
4036 : : ! *************************************************************************
4037 : :
4038 : 201 : ierr=0; nsppol=Sigp%nsppol
4039 : :
4040 : : ! List of spins for each node, number of processors per each spin
4041 : : ! and the MPI rank in the "spin" communicator.
4042 : 201 : my_nspins=nsppol
4043 [ - + + - : 603 : ABI_MALLOC(my_spins, (nsppol))
+ - + - -
+ - + -
+ ]
4044 [ - + + + : 1017 : my_spins= [(isp, isp=1,nsppol)]
+ - + + +
- - + - -
+ + ]
4045 [ + + ]: 406 : nprocs_spin = nprocs; rank_spin = my_rank
4046 : :
4047 [ + + - + ]: 201 : if (nsppol==2 .and. nprocs>1) then
4048 : : ! Distribute spins (optimal distribution if nprocs is even)
4049 : 0 : nprocs_spin(1) = nprocs/2
4050 : 0 : nprocs_spin(2) = nprocs - nprocs/2
4051 : 0 : my_nspins=1
4052 : 0 : my_spins(1)=1
4053 [ # # ]: 0 : if (my_rank+1>nprocs/2) then
4054 : : ! I will treat spin=2, compute shifted rank.
4055 : 0 : my_spins(1)=2
4056 : 0 : rank_spin = my_rank - nprocs/2
4057 : : end if
4058 : : end if
4059 : :
4060 : 201 : store_ur = (MODULO(Dtset%gwmem,10)==1)
4061 [ + + + + : 61415 : keep_ur=.FALSE.; bks_mask=.FALSE.
+ + + + +
+ + + ]
4062 : :
4063 : 243 : select case (Dtset%gwpara)
4064 : : case (1)
4065 : : ! Parallelization over transitions **without** memory distributions (Except for the spin).
4066 : 42 : my_minb=1; my_maxb=Sigp%nbnds
4067 [ - + ]: 42 : if (dtset%ucrpa>0) then
4068 [ # # # # : 0 : bks_mask(my_minb:my_maxb,:,:)=.TRUE.
# # ]
4069 [ # # # # : 0 : if (store_ur) keep_ur(my_minb:my_maxb,:,:)=.TRUE.
# # # # ]
4070 : : else
4071 [ + + ]: 84 : do isp=1,my_nspins
4072 : 42 : spin = my_spins(isp)
4073 [ + + + + ]: 4934 : bks_mask(my_minb:my_maxb,:,spin)=.TRUE.
4074 [ + - + + : 4976 : if (store_ur) keep_ur(my_minb:my_maxb,:,spin)=.TRUE.
+ + ]
4075 : : end do
4076 : : end if
4077 : :
4078 : : case (2)
4079 : : ! Distribute bands and spin (alternating planes of bands)
4080 [ + + ]: 322 : do isp=1,my_nspins
4081 : 163 : spin = my_spins(isp)
4082 [ + + ]: 5403 : do band=1,Sigp%nbnds
4083 [ + + ]: 5244 : if (xmpi_distrib_with_replicas(band,Sigp%nbnds,rank_spin,nprocs_spin(spin))) then
4084 : : !if (MODULO(band-1,nprocs_spin(spin))==rank_spin) then
4085 [ + + ]: 26347 : bks_mask(band,:,spin)=.TRUE.
4086 [ + + + + ]: 25895 : if (store_ur) keep_ur(band,:,spin)=.TRUE.
4087 : : end if
4088 : : end do
4089 : : end do
4090 : :
4091 : : #if 0
4092 : : ! Each node store the full set of occupied states to speed up Sigma_x.
4093 : : do isp=1,my_nspins
4094 : : spin = my_spins(isp)
4095 : : do ik_ibz=1,Kmesh%nibz
4096 : : ks_iv=ks_vbik(ik_ibz,spin) ! Valence index for this (k,s)
4097 : : bks_mask(1:ks_iv,:,spin)=.TRUE.
4098 : : if (store_ur) keep_ur(1:ks_iv,:,spin)=.TRUE.
4099 : : end do
4100 : : end do
4101 : : #endif
4102 : :
4103 : : case default
4104 : 0 : ABI_WARNING("Wrong value for gwpara")
4105 [ + + - ]: 201 : ierr = 1
4106 : : end select
4107 : :
4108 : : ! Return my_spins with correct size.
4109 [ + + ]: 406 : tmp_spins(1:my_nspins) = my_spins(1:my_nspins)
4110 : :
4111 [ - + ]: 201 : ABI_FREE(my_spins)
4112 [ - + + - : 603 : ABI_MALLOC(my_spins, (my_nspins))
+ - + - -
+ - + ]
4113 [ - + + + ]: 607 : my_spins = tmp_spins(1:my_nspins)
4114 : :
4115 : 201 : end subroutine sigma_bksmask
4116 : : !!***
4117 : :
4118 : : !!****f* ABINIT/paw_qpscgw
4119 : : !! NAME
4120 : : !! paw_qpscgw
4121 : : !!
4122 : : !! FUNCTION
4123 : : !! This routine is called during QP self-consistent GW calculations. It calculates the new QP on-site quantities
4124 : : !! using the QP amplitudes read from the QPS file.
4125 : : !!
4126 : : !! INPUTS
4127 : : !! Wfd<wfdgw_t>=Datatype gathering data on QP amplitudes.
4128 : : !! nscf=Number of QPSCGW iterations done so far (read from the QPS file).
4129 : : !! nfftf=Number of points in the fine FFT grid.
4130 : : !! ngfft(18)=information on the fine FFT grid used for densities and potentials.
4131 : : !! Dtset<dataset_type>=All input variables for this dataset.
4132 : : !! Cryst<crystal_t>=Info on unit cell and symmetries.
4133 : : !! Kmesh<kmesh_t>=Structure describing the k-point sampling.
4134 : : !! Psps<Pseudopotential_type)>=Info on pseudopotential, only for consistency check of the KSS file
4135 : : !! Pawang<pawang_type>=PAW angular mesh and related data.
4136 : : !! Pawrad(ntypat*usepaw)<type(pawrad_type)>=paw radial mesh and related data
4137 : : !! Pawtab(ntypat*usepaw)<type(pawtab_type)>=paw tabulated starting data
4138 : : !! Pawfgrtab(natom)<Pawfgrtab_type>= For PAW, various arrays giving data related to fine grid for a given atom.
4139 : : !! prev_Pawrhoij(Cryst%natom))<Pawrhoij_type>=Previous QP rhoij used for mixing if nscf>0 and rhoqpmix/=one.
4140 : : !! MPI_enreg=Information about MPI parallelization.
4141 : : !! qp_ebands<ebands_t>=QP band structure.
4142 : : !! QP_energies<Energies_type>=Simple datastructure to gather all part of total energy.
4143 : : !! nhatgrdim= 0 if pawgrnhat array is not used ; 1 otherwise
4144 : : !!
4145 : : !! OUTPUT
4146 : : !! QP_pawrhoij(Cryst%natom))<Pawrhoij_type>=on-site densities calculated from the QP amplitudes.
4147 : : !! qp_nhat(nfftf,Dtset%nspden)=Compensation charge density calculated from the QP amplitudes.
4148 : : !! qp_nhatgr(nfftf,Dtset%nspden,3*nhatgrdim)=Derivatives of the QP nhat on fine rectangular grid (and derivatives).
4149 : : !! qp_compch_sph=QP compensation charge integral inside spheres computed over spherical meshes.
4150 : : !! qp_compch_fft=QP compensation charge inside spheres computed over fine fft grid.
4151 : : !! QP_paw_ij(Cryst%natom)<Paw_ij_type>=Non-local D_ij strengths of the QP Hamiltonian.
4152 : : !! QP_paw_an(Cryst%natom)<Paw_an_type>=Various arrays related to the Hamiltonian given
4153 : : !! on ANgular mesh or ANgular moments.
4154 : : !!
4155 : : !! SOURCE
4156 : :
4157 [ # # # # : 0 : subroutine paw_qpscgw(Wfd,nscf,nfftf,ngfftf,Dtset,Cryst,Kmesh,Psps,qp_ebands, &
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
4158 : 0 : Pawang,Pawrad,Pawtab,Pawfgrtab,prev_Pawrhoij, &
4159 : 0 : QP_pawrhoij,QP_paw_ij,QP_paw_an,QP_energies,qp_nhat,nhatgrdim, &
4160 : 0 : qp_nhatgr,qp_compch_sph,qp_compch_fft)
4161 : :
4162 : : !Arguments ------------------------------------
4163 : : !scalars
4164 : : integer,intent(in) :: nfftf,nscf,nhatgrdim
4165 : : real(dp),intent(out) :: qp_compch_fft,qp_compch_sph
4166 : : type(kmesh_t),intent(in) :: Kmesh
4167 : : type(crystal_t),intent(in) :: Cryst
4168 : : type(Dataset_type),intent(in) :: Dtset
4169 : : type(Pseudopotential_type),intent(in) :: Psps
4170 : : type(Pawang_type),intent(in) :: Pawang
4171 : : type(ebands_t),intent(in) :: qp_ebands
4172 : : type(Energies_type),intent(inout) :: QP_energies
4173 : : type(wfdgw_t),intent(inout) :: Wfd
4174 : : !arrays
4175 : : integer,intent(in) :: ngfftf(18)
4176 : : real(dp),intent(out) :: qp_nhat(nfftf,Dtset%nspden)
4177 : : real(dp),intent(out) :: qp_nhatgr(nfftf,Dtset%nspden,3*nhatgrdim)
4178 : : type(Pawfgrtab_type),intent(inout) :: Pawfgrtab(Cryst%natom)
4179 : : type(Pawrad_type),intent(in) :: Pawrad(Psps%ntypat*Psps%usepaw)
4180 : : type(Pawtab_type),intent(in) :: Pawtab(Psps%ntypat*Psps%usepaw)
4181 : : type(Pawrhoij_type),intent(inout) :: prev_Pawrhoij(Cryst%natom)
4182 : : type(Pawrhoij_type),intent(out) :: QP_pawrhoij(Cryst%natom)
4183 : : type(Paw_ij_type),intent(out) :: QP_paw_ij(Cryst%natom)
4184 : : type(Paw_an_type),intent(inout) :: QP_paw_an(Cryst%natom)
4185 : :
4186 : : !Local variables ------------------------------
4187 : : !scalars
4188 : : integer,parameter :: ipert0 = 0, idir0 = 0, optrhoij1 = 1
4189 : : integer :: choice,cplex,cplex_rhoij,has_dijU,has_dijso,iat,ider
4190 : : integer :: izero,nkxc1,nspden_rhoij,nzlmopt, option,usexcnhat
4191 : : character(len=500) :: msg
4192 : : real(dp) :: el_temp
4193 : : !arrays
4194 : : real(dp) :: k0(3)
4195 : : !************************************************************************
4196 : :
4197 : : ABI_UNUSED(Kmesh%nibz)
4198 : : !
4199 : : ! * 0 if Vloc in atomic data is Vbare (Blochl s formulation)
4200 : : ! * 1 if Vloc in atomic data is VH(tnzc) (Kresse s formulation)
4201 : : usexcnhat=MAXVAL(Pawtab(:)%usexcnhat)
4202 : : !
4203 : : ! Calculate new rhoij_qp from updated Cprj_ibz, note use_rhoij_=1.
4204 : : call pawrhoij_inquire_dim(cplex_rhoij=cplex_rhoij,nspden_rhoij=nspden_rhoij,&
4205 : 0 : nspden=Dtset%nspden,spnorb=Dtset%pawspnorb,cpxocc=Dtset%pawcpxocc)
4206 : : call pawrhoij_alloc(QP_pawrhoij,cplex_rhoij,nspden_rhoij,Dtset%nspinor,Dtset%nsppol,Cryst%typat,&
4207 : 0 : pawtab=Pawtab,use_rhoij_=1,use_rhoijres=1)
4208 : :
4209 : : ! FIXME kptop should be passed via Kmesh, in GW time reversal is always assumed.
4210 : 0 : call wfd%pawrhoij(Cryst,qp_ebands,Dtset%kptopt,QP_pawrhoij,Dtset%pawprtvol)
4211 : : !
4212 : : ! Symmetrize QP $\rho_{ij}$.
4213 : 0 : choice=1
4214 : : call pawrhoij_symrhoij(QP_pawrhoij,QP_pawrhoij,choice,Cryst%gprimd,Cryst%indsym,ipert0,&
4215 : : Cryst%natom,Cryst%nsym,Cryst%ntypat,optrhoij1,Pawang,Dtset%pawprtvol,&
4216 : 0 : Pawtab,Cryst%rprimd,Cryst%symafm,Cryst%symrec,Cryst%typat)
4217 : :
4218 : : ! ======================
4219 : : ! ==== Make QP nhat ====
4220 : : ! ======================
4221 : 0 : cplex=1; ider=2*nhatgrdim; izero=0; k0(:)=zero
4222 : :
4223 : : call pawmknhat(qp_compch_fft,cplex,ider,idir0,ipert0,izero,Cryst%gprimd,&
4224 : : Cryst%natom,Cryst%natom,nfftf,ngfftf,nhatgrdim,Dtset%nspden,Cryst%ntypat,Pawang,&
4225 : : Pawfgrtab,qp_nhatgr,qp_nhat,QP_Pawrhoij,QP_Pawrhoij,Pawtab,k0,Cryst%rprimd,&
4226 : 0 : Cryst%ucvol,Dtset%usewvl,Cryst%xred)
4227 : :
4228 : : ! Allocate quantities related to the PAW spheres for the QP Hamiltonian.
4229 : : ! TODO call paw_ij_init in scfcv and respfn, fix small issues
4230 [ # # ]: 0 : has_dijso=Dtset%pawspnorb; has_dijU=merge(0,1,Dtset%usepawu==0)
4231 : :
4232 : 0 : call paw_ij_nullify(QP_paw_ij)
4233 : : call paw_ij_init(QP_paw_ij,cplex,Dtset%nspinor,Dtset%nsppol,&
4234 : : Dtset%nspden,Dtset%pawspnorb,Cryst%natom,Cryst%ntypat,Cryst%typat,Pawtab,&
4235 : : has_dij=1,has_dijhartree=1,has_dijhat=1,has_dijxc=1,has_dijxc_hat=1,has_dijxc_val=1,&
4236 : 0 : has_dijso=has_dijso,has_dijU=has_dijU,has_exexch_pot=1,has_pawu_occ=1)
4237 : :
4238 : 0 : call paw_an_nullify(QP_paw_an); nkxc1=0 ! No kernel
4239 : : call paw_an_init(QP_paw_an,Cryst%natom,Cryst%ntypat,nkxc1,0,Dtset%nspden,&
4240 : 0 : cplex,Dtset%pawxcdev,Cryst%typat,Pawang,Pawtab,has_vxc=1,has_vxcval=1)
4241 : :
4242 : : ! =====================================================
4243 : : ! ==== Optional mixing of the PAW onsite densities ====
4244 : : ! =====================================================
4245 [ # # # # ]: 0 : if (nscf>0 .and. (ABS(Dtset%rhoqpmix-one)>tol12) ) then
4246 : 0 : write(msg,'(a,f6.3)')' sigma: mixing on-site QP rho_ij densities using rhoqpmix= ',Dtset%rhoqpmix
4247 : 0 : call wrtout(std_out, msg)
4248 : : ! qp_rhor = prev_rhor + Dtset%rhoqpmix*(qp_rhor-prev_rhor)
4249 : :
4250 : 0 : call pawrhoij_unpack(QP_Pawrhoij) ! Unpack new QP %rhoijp
4251 : 0 : call pawrhoij_unpack(prev_Pawrhoij) ! Unpack previous QP %rhoijp
4252 : :
4253 [ # # ]: 0 : do iat=1,Cryst%natom
4254 : : QP_pawrhoij(iat)%rhoij_ = prev_Pawrhoij(iat)%rhoij_ &
4255 [ # # # # : 0 : + Dtset%rhoqpmix * (QP_pawrhoij(iat)%rhoij_ - prev_pawrhoij(iat)%rhoij_)
# # # # #
# # # ]
4256 : :
4257 : 0 : prev_pawrhoij(iat)%use_rhoij_=0
4258 [ # # ]: 0 : ABI_FREE(prev_pawrhoij(iat)%rhoij_)
4259 : : end do
4260 : :
4261 : : ! Re-Symmetrize mixed QP $\rho_{ij}$.
4262 : : choice=1
4263 : : call pawrhoij_symrhoij(QP_pawrhoij,QP_pawrhoij,choice,Cryst%gprimd,Cryst%indsym,ipert0,&
4264 : : Cryst%natom,Cryst%nsym,Cryst%ntypat,optrhoij1,Pawang,Dtset%pawprtvol,&
4265 : 0 : Pawtab,Cryst%rprimd,Cryst%symafm,Cryst%symrec,Cryst%typat)
4266 : : end if
4267 : :
4268 [ # # ]: 0 : do iat=1,Cryst%natom
4269 : 0 : QP_pawrhoij(iat)%use_rhoij_=0
4270 [ # # ]: 0 : ABI_FREE(QP_pawrhoij(iat)%rhoij_)
4271 : : end do
4272 : : !
4273 : : ! =================================================================================
4274 : : ! ==== Evaluate on-site energies, potentials, densities using (mixed) QP rhoij ====
4275 : : ! =================================================================================
4276 : : ! * Initialize also "lmselect" (index of non-zero LM-moments of densities).
4277 : :
4278 : 0 : nzlmopt=-1; option=0; qp_compch_sph=greatest_real
4279 : :
4280 : : ! Get electronic temperature from dtset
4281 [ # # # # : 0 : el_temp=merge(dtset%tphysel,dtset%tsmear,dtset%tphysel>tol8.and.dtset%occopt/=3.and.dtset%occopt/=9)
# # ]
4282 : :
4283 : : call pawdenpot(qp_compch_sph,el_temp,Cryst%gprimd,ipert0,Dtset%ixc,Cryst%natom,Cryst%natom,Dtset%nspden,&
4284 : : Cryst%ntypat,Dtset%nucdipmom,nzlmopt,option,QP_paw_an,QP_paw_an,QP_energies%paw,&
4285 : : QP_paw_ij,Pawang,Dtset%pawprtvol,Pawrad,QP_pawrhoij,Dtset%pawspnorb,Pawtab,Dtset%pawxcdev,&
4286 : 0 : Dtset%spnorbscl,Dtset%xclevel,Dtset%xc_denpos,Dtset%xc_taupos,Cryst%xred,Cryst%ucvol,Psps%znuclpsp,Dtset%spinaxis)
4287 : :
4288 : 0 : end subroutine paw_qpscgw
4289 : : !!***
4290 : :
4291 : : !!****f* ABINIT/setup_vcp
4292 : : !! NAME
4293 : : !! setup_vcp
4294 : : !!
4295 : : !! FUNCTION
4296 : : !! Initialize the Vcp and compute the corresponding residue.
4297 : : !!
4298 : : !! INPUTS
4299 : : !! Dtset<type(dataset_type)>=all input variables for this dataset
4300 : : !! Gsph_c<gsphere_t>=Info on the G-sphere for W and Sigma_c
4301 : : !! Gsph_x<gsphere_t>=Info on the G-sphere for and Sigma_x
4302 : : !! Kmesh <kmesh_t>=Structure describing the k-point sampling.
4303 : : !! Qmesh <kmesh_t>=Structure describing the q-point sampling.
4304 : : !! Cryst<crystal_t>=Info on unit cell and symmetries.
4305 : : !! comm=Information about the xmpi_world
4306 : : !!
4307 : : !! OUTPUT
4308 : : !! Vcp_full<vcoul_t>= Datatype gathering information on the coulombian interaction and the cutoff technique.
4309 : : !! Vcp_ks<vcoul_t>= Datatype gathering information on the coulombian interaction and the cutoff technique.
4310 : : !! coef_hyb=real variable containing the amount of GLOBAL hybridization
4311 : :
4312 : 4 : subroutine setup_vcp(Vcp_ks,Vcp_full,Dtset,Gsph_x,Gsph_c,Cryst,Qmesh,Kmesh,coef_hyb,comm)
4313 : :
4314 : : !Arguments ------------------------------------
4315 : : !scalars
4316 : : type(Dataset_type),intent(in) :: Dtset
4317 : : type(gsphere_t),intent(in) :: Gsph_x,Gsph_c
4318 : : type(crystal_t),intent(in) :: Cryst
4319 : : type(kmesh_t),intent(in) :: Kmesh, Qmesh
4320 : : type(vcoul_t),intent(inout) :: Vcp_ks, Vcp_full
4321 : : integer,intent(in) :: comm
4322 : : real(dp),intent(inout) :: coef_hyb
4323 : :
4324 : : !Local variables-------------------------------
4325 : : !scalars
4326 : : integer :: usefock_ixc,nqlwl,xclevel_ixc,icsing_eff
4327 : : real(dp) :: rcut
4328 : : !arrays
4329 : 4 : real(dp),allocatable :: qlwl(:,:)
4330 : : !************************************************************************
4331 : :
4332 : : ! Build Vcp_ks and Vcp_full
4333 [ + - ]: 4 : if (Dtset%gw_nqlwl==0) then
4334 : 4 : nqlwl=1
4335 [ - + ]: 4 : ABI_MALLOC(qlwl,(3,nqlwl))
4336 [ + + ]: 16 : qlwl(:,1)= GW_Q0_DEFAULT
4337 : : else
4338 : 0 : nqlwl=Dtset%gw_nqlwl
4339 [ # # # # : 0 : ABI_MALLOC(qlwl,(3,nqlwl))
# # # # #
# # # ]
4340 [ # # # # ]: 0 : qlwl(:,:)=Dtset%gw_qlwl(:,1:nqlwl)
4341 : : end if
4342 : 4 : rcut=Dtset%gw_rcut
4343 : 4 : icsing_eff=Dtset%gw_icutcoul
4344 : : ! 1st part: Use a Vcp_full to compute the full Coulomb interaction for NOs
4345 [ + - ]: 4 : if (Gsph_x%ng > Gsph_c%ng) then
4346 : : call Vcp_full%init(Gsph_x,Cryst,Qmesh,Kmesh,rcut,icsing_eff,Dtset%vcutgeo,&
4347 : 4 : Dtset%ecutsigx,Gsph_x%ng,nqlwl,qlwl,comm)
4348 : : else
4349 : : call Vcp_full%init(Gsph_c,Cryst,Qmesh,Kmesh,rcut,icsing_eff,Dtset%vcutgeo,&
4350 : 0 : Dtset%ecutsigx,Gsph_c%ng,nqlwl,qlwl,comm)
4351 : : end if
4352 : : ! 2nd part: Use a Vcp_ks to compute the Coulomb interaction already present in the Fock part of the Kohn-Sham Hamiltonian
4353 : 4 : coef_hyb=zero
4354 : 4 : call get_xclevel(Dtset%ixc,xclevel_ixc,usefock_ixc) ! usefock is 0 for 0.0 Fock contrib in KS-GS calc
4355 [ - + ]: 4 : if (usefock_ixc==1)then
4356 [ # # ]: 0 : if (abs(Dtset%hyb_mixing)>tol8) then
4357 : 0 : coef_hyb=abs(Dtset%hyb_mixing)
4358 : : if(abs(coef_hyb+999.0d0)<tol8) then ! HF
4359 : : coef_hyb=1.0d0
4360 : : end if
4361 [ # # ]: 0 : else if(abs(Dtset%hyb_mixing_sr)>tol8)then
4362 : 0 : coef_hyb=abs(Dtset%hyb_mixing_sr)
4363 : 0 : icsing_eff=5
4364 : : end if
4365 [ # # # # ]: 0 : if (abs(rcut)<tol6 .and. abs(Dtset%hyb_range_fock)>tol8) then
4366 : 0 : rcut=one/Dtset%hyb_range_fock
4367 : : end if
4368 : : end if
4369 [ + - ]: 4 : if (Gsph_x%ng > Gsph_c%ng) then
4370 : : call Vcp_ks%init(Gsph_x,Cryst,Qmesh,Kmesh,rcut,icsing_eff,Dtset%vcutgeo,&
4371 : 4 : Dtset%ecutsigx,Gsph_x%ng,nqlwl,qlwl,comm)
4372 : : else
4373 : : call Vcp_ks%init(Gsph_c,Cryst,Qmesh,Kmesh,rcut,icsing_eff,Dtset%vcutgeo,&
4374 : 0 : Dtset%ecutsigx,Gsph_c%ng,nqlwl,qlwl,comm)
4375 : : end if
4376 [ - + ]: 4 : ABI_FREE(qlwl)
4377 : : ! Now compute the "residual" Coulomb interactions
4378 : 4 : ABI_COMMENT("From now on, Vcp_ks%vc_sqrt_resid contains the amount of exact exchange present on the GS.")
4379 [ + - + - : 2216 : Vcp_ks%vc_sqrt_resid=sqrt(coef_hyb*Vcp_ks%vc_sqrt**2)
- + - - +
+ + + ]
4380 : 4 : Vcp_ks%i_sz_resid=coef_hyb*Vcp_ks%i_sz
4381 : :
4382 : 4 : end subroutine setup_vcp
4383 : : !!***
4384 : :
4385 : 0 : end module m_sigma_driver
4386 : : !!***
|
