Branch data Line data Source code
1 : : !!****m* ABINIT/m_respfn_driver
2 : : !! NAME
3 : : !! m_respfn_driver
4 : : !!
5 : : !! FUNCTION
6 : : !! Subdriver for DFPT calculations.
7 : : !!
8 : : !! COPYRIGHT
9 : : !! Copyright (C) 1999-2026 ABINIT group (XG, DRH, MT, MKV, GA)
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 : : ! nvtx related macro definition
23 : : #include "nvtx_macros.h"
24 : :
25 : : module m_respfn_driver
26 : :
27 : : use defs_basis
28 : : use defs_wvltypes
29 : : use m_efmas_defs
30 : : use m_abicore
31 : : use m_xmpi
32 : : use m_exit
33 : : use m_wffile
34 : : use m_errors
35 : : use m_ebands
36 : : use m_results_respfn
37 : : use m_hdr
38 : : use m_crystal
39 : : use m_xcdata
40 : : use m_dtset
41 : : use m_dtfil
42 : : use m_gemm_nonlop_projectors
43 : :
44 : : use defs_datatypes, only : pseudopotential_type
45 : : use defs_abitypes, only : MPI_type
46 : : use m_time, only : timab
47 : : use m_fstrings, only : strcat, endswith
48 : : use m_matrix, only : matr3inv
49 : : use m_symtk, only : littlegroup_q, symmetrize_xred
50 : : use m_fft, only : zerosym, fourdp
51 : : use m_kpts, only : symkchk
52 : : use m_geometry, only : irreducible_set_pert, symredcart, sylwtens
53 : : use m_dynmat, only : chkph3, d2sym3, q0dy3_apply, q0dy3_calc, wings3, dfpt_phfrq, sytens, dfpt_prtph, &
54 : : asria_calc, asria_corr, cart29, cart39, chneu9, dfpt_sydy
55 : : use m_ddb, only : ddb_type
56 : : use m_ddb_hdr, only : ddb_hdr_type
57 : : use m_occ, only : newocc
58 : : use m_efmas, only : efmasdeg_free_array, efmasval_free_array
59 : : use m_wfk, only : wfk_read_eigenvalues, wfk_read_my_kptbands
60 : : use m_ioarr, only : read_rhor
61 : : use m_pawang, only : pawang_type
62 : : use m_pawrad, only : pawrad_type
63 : : use m_pawtab, only : pawtab_type, pawtab_get_lsize
64 : : use m_paw_an, only : paw_an_type, paw_an_init, paw_an_free, paw_an_nullify
65 : : use m_paw_ij, only : paw_ij_type, paw_ij_init, paw_ij_free, paw_ij_nullify
66 : : use m_pawfgrtab, only : pawfgrtab_type, pawfgrtab_init, pawfgrtab_free
67 : : use m_pawrhoij, only : pawrhoij_type, pawrhoij_alloc, pawrhoij_free, pawrhoij_copy, &
68 : : pawrhoij_bcast, pawrhoij_nullify, pawrhoij_inquire_dim, &
69 : : pawrhoij_print_rhoij, pawrhoij_io
70 : : use m_pawdij, only : pawdij, symdij, pawdij_print_dij
71 : : use m_paw_energies,only : paw_energies_type
72 : : use m_pawfgr, only : pawfgr_type, pawfgr_init, pawfgr_destroy
73 : : use m_paw_finegrid,only : pawexpiqr
74 : : use m_pawxc, only : pawxc_get_nkxc, pawxc_get_usekden
75 : : use m_paw_dmft, only : paw_dmft_type
76 : : use m_paw_sphharm, only : setsym_ylm
77 : : use m_paw_nhat, only : nhatgrid,pawmknhat
78 : : use m_paw_tools, only : chkpawovlp
79 : : use m_paw_denpot, only : pawdenpot
80 : : use m_paw_init, only : pawinit,paw_gencond
81 : : use m_kg, only : getcut, getph, kpgio
82 : : use m_eig2d, only : eig2tot, elph2_fanddw
83 : : use m_inwffil, only : inwffil
84 : : use m_spacepar, only : hartre, setsym
85 : : use m_mkrho, only : mkrho
86 : : use m_vdw_dftd2, only : vdw_dftd2
87 : : use m_vdw_dftd3, only : vdw_dftd3
88 : : use m_initylmg, only : initylmg
89 : : use m_pspini, only : pspini
90 : : use m_atm2fft, only : atm2fft
91 : : use m_dfpt_loopert,only : dfpt_looppert, eigen_meandege
92 : : use m_rhotoxc, only : rhotoxc
93 : : use m_drivexc, only : check_kxc, xc_need_kden
94 : : use m_xc_tb09, only : xc_tb09_update_c
95 : : use m_mklocl, only : mklocl, mklocl_recipspace
96 : : use m_common, only : setup1, prteigrs
97 : : use m_fourier_interpol, only : transgrid
98 : : use m_paral_atom, only : get_my_atmtab, free_my_atmtab
99 : : use m_paw_occupancies, only : initrhoij
100 : : use m_paw_correlations,only : pawpuxinit
101 : : use m_mkcore, only : mkcore, dfpt_mkcore
102 : : use m_dfpt_elt, only : dfpt_eltfrxc, dfpt_eltfrloc, dfpt_eltfrkin, dfpt_eltfrhar, elt_ewald, dfpt_ewald
103 : : use m_d2frnl, only : d2frnl
104 : : use m_pstat, only : pstat_proc
105 : :
106 : : #if defined HAVE_GPU
107 : : use m_alloc_hamilt_gpu
108 : : #endif
109 : :
110 : : #if defined(HAVE_GPU_MARKERS)
111 : : use m_nvtx_data
112 : : #endif
113 : :
114 : : implicit none
115 : :
116 : : private
117 : : !!***
118 : :
119 : : public :: respfn
120 : : !!***
121 : :
122 : : contains
123 : : !!***
124 : :
125 : : !!****f* m_respfn_driver/respfn
126 : : !! NAME
127 : : !! respfn
128 : : !!
129 : : !! FUNCTION
130 : : !! Primary routine for conducting DFT calculations of Response functions.
131 : : !!
132 : : !! INPUTS
133 : : !! codvsn=code version
134 : : !! cpui=initial cpu time
135 : : !! dtfil <type(datafiles_type)>=variables related to files
136 : : !! dtset <type(dataset_type)>=all input variables for this dataset
137 : : !! | mband=maximum number of bands
138 : : !! | mgfft=maximum single fft dimension
139 : : !! | mkmem=Number of k points treated by this node
140 : : !! | mpw=maximum number of planewaves in basis sphere (large number)
141 : : !! | natom=number of atoms in unit cell
142 : : !! | nfft=(effective) number of FFT grid points (for this processor)
143 : : !! | nkpt=number of k points
144 : : !! | nspden=number of spin-density components
145 : : !! | nsppol=number of channels for spin-polarization (1 or 2)
146 : : !! | nsym=number of symmetry elements in space group
147 : : !! mkmems(3)=array containing the tree values of mkmem (see above) (k-GS, k+q-GS and RF)
148 : : !! mpi_enreg=information about MPI parallelization
149 : : !! npwtot(nkpt)=number of planewaves in basis and boundary at each k point
150 : : !! xred(3,natom)=reduced dimensionless atomic coordinates
151 : : !!
152 : : !! OUTPUT
153 : : !! etotal=total energy (sum of 7 or 8 contributions) (hartree)
154 : : !!
155 : : !! SIDE EFFECTS
156 : : !! iexit=index of "exit" on first line of file (0 if not found)
157 : : !! occ(mband*nkpt*nsppol)=occup number for each band (often 2) at each k point
158 : : !! Occupations number may have been read from a previous dataset...
159 : : !! pawang <type(pawang_type)>=paw angular mesh and related data
160 : : !! pawrad(ntypat*usepaw) <type(pawrad_type)>=paw radial mesh and related data
161 : : !! Some dimensions in pawrad have been set in driver.f
162 : : !! pawtab(ntypat*usepaw) <type(pawtab_type)>=paw tabulated starting data
163 : : !! Some dimensions in pawtab have been set in driver.f
164 : : !! psps <type(pseudopotential_type)>=variables related to pseudopotentials
165 : : !! Before entering the first time in respfn, a significant part of psps
166 : : !! has been initialized: the integers dimekb,lmnmax,lnmax,mpssang,mpssoang,
167 : : !! mpsso,mgrid,ntypat,n1xccc,usepaw,useylm, and the arrays dimensioned to npsp
168 : : !! All the remaining components of psps are to be initialized in the call
169 : : !! to pspini. The next time the code enters respfn, psps might be identical
170 : : !! to the one of the previous dtset, in which case, no reinitialisation
171 : : !! is scheduled in pspini.f .
172 : : !! results_respfn <type(results_respfn_type)>=stores some results of respfn calls
173 : : !!
174 : : !! NOTES
175 : : !! USE OF FFT GRIDS:
176 : : !! =================
177 : : !! In case of PAW:
178 : : !! ---------------
179 : : !! Two FFT grids are used:
180 : : !! - A "coarse" FFT grid (defined by ecut)
181 : : !! for the application of the Hamiltonian on the plane waves basis.
182 : : !! It is defined by nfft, ngfft, mgfft, ...
183 : : !! Hamiltonian, wave-functions, density related to WFs (rhor here), ...
184 : : !! are expressed on this grid.
185 : : !! - A "fine" FFT grid (defined) by ecutdg)
186 : : !! for the computation of the density inside PAW spheres.
187 : : !! It is defined by nfftf, ngfftf, mgfftf, ...
188 : : !! Total density, potentials, ...
189 : : !! are expressed on this grid.
190 : : !! In case of norm-conserving:
191 : : !! ---------------------------
192 : : !! - Only the usual FFT grid (defined by ecut) is used.
193 : : !! It is defined by nfft, ngfft, mgfft, ...
194 : : !! For compatibility reasons, (nfftf,ngfftf,mgfftf)
195 : : !! are set equal to (nfft,ngfft,mgfft) in that case.
196 : : !!
197 : : !! SOURCE
198 : :
199 : 1007 : subroutine respfn(codvsn,cpui,dtfil,dtset,etotal,iexit,&
200 : 720 : & mkmems,mpi_enreg,npwtot,occ,pawang,pawrad,pawtab,psps,results_respfn,xred)
201 : :
202 : : !Arguments ------------------------------------
203 : : integer,intent(inout) :: iexit
204 : : real(dp),intent(in) :: cpui
205 : : real(dp),intent(inout) :: etotal !vz_i
206 : : character(len=8),intent(in) :: codvsn
207 : : type(MPI_type),intent(inout) :: mpi_enreg
208 : : type(datafiles_type),intent(in) :: dtfil
209 : : type(dataset_type),intent(in) :: dtset
210 : : type(pawang_type),intent(inout) :: pawang
211 : : type(pseudopotential_type),intent(inout) :: psps
212 : : integer,intent(in) :: mkmems(3)
213 : : integer,intent(inout) :: npwtot(dtset%nkpt)
214 : : real(dp),intent(inout) :: xred(3,dtset%natom)
215 : : real(dp),intent(inout) :: occ(dtset%mband*dtset%nkpt*dtset%nsppol)
216 : : type(pawrad_type),intent(inout) :: pawrad(psps%ntypat*psps%usepaw)
217 : : type(pawtab_type),intent(inout) :: pawtab(psps%ntypat*psps%usepaw)
218 : : type(results_respfn_type),intent(inout) :: results_respfn
219 : :
220 : : !Local variables-------------------------------
221 : : integer,parameter :: formeig=0,level=10
222 : : integer,parameter :: response=1,syuse=0,master=0,cplex1=1
223 : : integer :: nk3xc
224 : : integer :: analyt,ask_accurate,asr,bantot,bdeigrf,chneut,coredens_method,coretau_method,cplex,cplex_rhoij
225 : : !integer :: nkpt_eff, band_index, ikpt, isppol, nkpt_max, nband_k,
226 : : integer :: dim_eig2nkq,dim_eigbrd,dyfr_cplex,dyfr_nondiag,gnt_option
227 : : integer :: gscase,has_dijnd,has_diju,has_vhartree,has_kxc,iatom,iatom_tot,iband,idir,ider,ierr,ifft,ii,indx
228 : : integer :: i1dir,i1pert,i2dir,i2pert,i3dir,i3pert
229 : : integer :: initialized,ipert,ipert2,ireadwf0,iscf,iscf_eff,ispden,isym
230 : : integer :: itypat,izero,mcg,me,mgfftf,mk1mem,mkqmem,mpert,mu
231 : : integer :: my_natom,n1,natom,n3xccc,nfftf,nfftot,nfftotf,nhatdim,nhatgrdim
232 : : integer :: nkpt_rbz,nkxc,nkxc1,nspden_rhoij,ntypat,nzlmopt,openexit
233 : : integer :: optcut,option,optgr0,optgr1,optgr2,optorth,optrad
234 : : integer :: optatm,optdyfr,opteltfr,optgr,optn,optn2,optstr,optv
235 : : integer :: outd2,pawbec,pawpiezo,prtbbb,psp_gencond,qzero,rdwrpaw
236 : : integer :: rfddk,rfelfd,rfphon,rfstrs,rf2_dkdk,rf2_dkde,rfmagn
237 : : integer :: spaceworld,sumg0,sumg0_save,sz1,sz2,tim_mkrho,timrev,usecprj,usevdw,usevxctau,usevxctau_paw
238 : : integer :: usexcnhat,use_sym,vloc_method,zero_by_symm
239 : : logical :: has_full_piezo,has_allddk,is_dfpt=.true.,non_magnetic_xc
240 : : logical :: paral_atom,qeq0,use_nhat_gga,call_pawinit
241 : : real(dp) :: boxcut,compch_fft,compch_sph,cpus,ecore,ecut_eff,ecutdg_eff,ecutf
242 : : real(dp) :: eei,eew,ehart,eii,ek,enl,entropy,bigexc,bigsxc
243 : : real(dp) :: etot,evdw,fermie,fermih,gsqcut,gsqcut_eff,gsqcutc_eff,qphnrm,residm
244 : : real(dp) :: ucvol,vxcavg,el_temp
245 : : character(len=500) :: msg
246 : 720 : type(ebands_t) :: bstruct
247 : 720 : type(hdr_type) :: hdr,hdr_fine,hdr0,hdr_den
248 : 720 : type(ddb_type) :: ddb
249 [ + + + + : 45360 : type(ddb_hdr_type) :: ddb_hdr
+ + + + +
+ + + + +
+ + + + +
+ ]
250 : 720 : type(paw_dmft_type) :: paw_dmft
251 : : type(paw_energies_type) :: paw_energies
252 : : type(pawfgr_type) :: pawfgr
253 : 720 : type(wvl_data) :: wvl
254 : : type(xcdata_type) :: xcdata
255 : : integer :: ddkfil(3),ngfft(18),ngfftf(18),rfdir(3),rf2_dirs_from_rfpert_nl(3,3)
256 : 720 : integer,allocatable :: atindx(:),atindx1(:),blkflg(:,:,:,:),blkflgfrx1(:,:,:,:),blkflg1(:,:,:,:)
257 : 1440 : integer,allocatable :: blkflg2(:,:,:,:),carflg(:,:,:,:),clflg(:,:),indsym(:,:,:)
258 : 720 : integer,allocatable :: irrzon(:,:,:),kg(:,:),l_size_atm(:),nattyp(:),npwarr(:)
259 : 720 : integer,allocatable :: pertsy(:,:),rfpert(:)
260 : 720 : integer,allocatable :: rfpert_lw(:,:,:,:,:,:),rfpert_nl(:,:,:,:,:,:),symq(:,:,:),symrec(:,:,:)
261 : 720 : logical,allocatable :: distrb_flags(:,:,:)
262 : : real(dp) :: dum_gauss(0),dum_dyfrn(0),dum_dyfrv(0),dum_eltfrxc(0)
263 : : real(dp) :: dum_grn(0),dum_grv(0),dum_rhog(0),dum_vg(0)
264 : : real(dp) :: dummy6(6),gmet(3,3),gmet_for_kg(3,3),gprimd(3,3),gprimd_for_kg(3,3),qphon(3)
265 : : real(dp) :: dummy_in(0)
266 : : real(dp) :: dummy_out1(0),dummy_out2(0),dummy_out3(0),dummy_out4(0),dummy_out5(0),dummy_out6(0)
267 : : real(dp) :: rmet(3,3),rprimd(3,3),rprimd_for_kg(3,3),strn_dummy6(6),strv_dummy6(6),tsec(2)
268 : : real(dp),parameter :: k0(3)=(/zero,zero,zero/)
269 : 720 : real(dp),allocatable :: becfrnl(:,:,:),cg(:,:),d2bbb(:,:,:,:,:,:),d2cart(:,:,:,:,:)
270 : 720 : real(dp),allocatable :: d2cart_bbb(:,:,:,:,:,:),d2eig0(:,:,:,:,:)
271 : 720 : real(dp),allocatable :: d2k0(:,:,:,:,:),d2lo(:,:,:,:,:),d2loc0(:,:,:,:,:)
272 : 720 : real(dp),allocatable :: d2matr(:,:,:,:,:),d2nfr(:,:,:,:,:),d2nl(:,:,:,:,:),d2ovl(:,:,:,:,:)
273 : 720 : real(dp),allocatable :: d2nl0(:,:,:,:,:),d2nl1(:,:,:,:,:),d2tmp(:,:,:,:,:),d2vn(:,:,:,:,:)
274 : 720 : real(dp),allocatable :: displ(:),doccde(:)
275 : 720 : real(dp),allocatable :: dyew(:,:,:,:,:),dyewq0(:,:,:),dyfrlo(:,:,:),dyfrlo_indx(:,:,:)
276 : 720 : real(dp),allocatable :: dyfrnl(:,:,:,:,:),dyfrwf(:,:,:,:,:),dyfrx1(:,:,:,:,:),dyvdw(:,:,:,:,:)
277 : 720 : real(dp),allocatable :: dyfrx2(:,:,:),eigen0(:),eigval(:),eigvec(:)
278 : 720 : real(dp),allocatable :: eig2nkq(:,:,:,:,:,:,:),eigbrd(:,:,:,:,:,:,:)
279 : 720 : real(dp),allocatable :: eigen_fan(:),eigen_ddw(:),eigen_fanddw(:)
280 : 720 : real(dp),allocatable :: eigen_fan_mean(:),eigen_ddw_mean(:)
281 : 720 : real(dp),allocatable :: eltcore(:,:),elteew(:,:),eltfrhar(:,:),eltfrkin(:,:)
282 : 720 : real(dp),allocatable :: eltfrloc(:,:),eltfrnl(:,:),eltfrxc(:,:),eltvdw(:,:),grtn_indx(:,:)
283 : 720 : real(dp),allocatable :: grxc(:,:),kxc(:,:),nhat(:,:),nhatgr(:,:,:)
284 : 720 : real(dp),allocatable :: ph1d(:,:),ph1df(:,:),phfrq(:),phnons(:,:,:),piezofrnl(:,:)
285 : 720 : real(dp),allocatable :: rhog(:,:),rhor(:,:),rhowfg(:,:),rhowfr(:,:)
286 : 720 : real(dp),allocatable :: symrel_cart(:,:,:),taug(:,:),taur(:,:)
287 : 720 : real(dp),allocatable :: vhartr(:),vpsp(:),vtrial(:,:)
288 : 720 : real(dp),allocatable :: vxc(:,:),vxctau(:,:,:),xccc3d(:),xcctau3d(:),ylm(:,:),ylmgr(:,:,:)
289 : 720 : real(dp),pointer :: eigenq_fine(:,:,:),eigen1_pert(:,:,:)
290 : 720 : real(dp),allocatable :: eigen0_pert(:),eigenq_pert(:),occ_rbz_pert(:)
291 : 720 : type(efmasdeg_type),allocatable :: efmasdeg(:)
292 : 720 : type(efmasval_type),allocatable :: efmasval(:,:)
293 : 720 : type(paw_an_type),allocatable :: paw_an(:)
294 : 720 : type(paw_ij_type),allocatable :: paw_ij(:)
295 : 720 : type(pawfgrtab_type),allocatable,save :: pawfgrtab(:)
296 : 720 : type(pawrhoij_type),allocatable :: pawrhoij(:),pawrhoij_read(:)
297 : :
298 : : ! ***********************************************************************
299 : :
300 : : DBG_ENTER("COLL")
301 : :
302 : 720 : call timab(132,1,tsec)
303 : 720 : call timab(133,1,tsec)
304 : : ABI_NVTX_START_RANGE(NVTX_RESPFN)
305 : :
306 : : !Some data for parallelism
307 : :
308 : 720 : my_natom=mpi_enreg%my_natom
309 : 720 : paral_atom=(my_natom/=dtset%natom)
310 : : !Define FFT grid(s) sizes (be careful !)
311 : : !See NOTES in the comments at the beginning of this file.
312 : 720 : call pawfgr_init(pawfgr,dtset,mgfftf,nfftf,ecut_eff,ecutdg_eff,ngfft,ngfftf)
313 : :
314 : : !Structured debugging if dtset%prtvol==-level
315 [ - + ]: 720 : if(dtset%prtvol==-level)then
316 [ # # # # ]: 0 : write(msg,'(80a,a,a)') ('=',ii=1,80),ch10,' respfn : enter , debug mode '
317 : 0 : call wrtout(std_out,msg)
318 : : end if
319 : :
320 : : !Option input variables
321 : 720 : iscf=dtset%iscf
322 : :
323 : : !Get electronic temperature from dtset
324 [ - + - - : 720 : el_temp=merge(dtset%tphysel,dtset%tsmear,dtset%tphysel>tol8.and.dtset%occopt/=3.and.dtset%occopt/=9)
- - ]
325 : :
326 : : !Respfn input variables
327 [ + + ]: 2880 : asr=dtset%asr ; chneut=dtset%chneut ; rfdir(1:3)=dtset%rfdir(1:3)
328 : 720 : rfddk=dtset%rfddk ; rfelfd=dtset%rfelfd ; rfmagn=dtset%rfmagn
329 : 720 : rfphon=dtset%rfphon ; rfstrs=dtset%rfstrs
330 : 720 : rf2_dkdk=dtset%rf2_dkdk ; rf2_dkde=dtset%rf2_dkde
331 : :
332 : : !Scalar potential has no idir.
333 [ + + ]: 720 : if (rfmagn==3) then
334 : 1 : rfdir(:)= 0
335 : 1 : rfdir(1)= 1
336 : : end if
337 : :
338 [ + + + + : 720 : pawbec=0 ; if(psps%usepaw==1.and.(rfphon==1.or.(rfelfd==1.or.rfelfd==3))) pawbec=1
+ + ]
339 [ + + + + : 720 : pawpiezo=0; if(psps%usepaw==1.and.(rfstrs/=0.or.(rfelfd==1.or.rfelfd==3))) pawpiezo=1
+ + ]
340 : : !AM 10152015 -- WARNING --- the full calculation of the piezoelectric tensor
341 : : !from electric field perturbation is only available
342 : : !if nsym/=1 (strain perturbation is not symmetrized):
343 [ + + + + ]: 720 : has_full_piezo=.False. ; if(pawpiezo==1.and.dtset%nsym==1) has_full_piezo=.True.
344 [ + + ]: 720 : usevdw=0;if (dtset%vdw_xc>=5.and.dtset%vdw_xc<=7) usevdw=1
345 : : !mkmem variables (mkmem is already argument)
346 : 720 : mkqmem=mkmems(2) ; mk1mem=mkmems(3)
347 : :
348 : 720 : ntypat=psps%ntypat
349 : 720 : natom=dtset%natom
350 [ + + ]: 2880 : nfftot=product(ngfft(1:3))
351 [ + + ]: 2880 : nfftotf=product(ngfftf(1:3))
352 : :
353 : : !Deactivate acoustic sum rule and charge neutrality at finite frequency
354 [ + + - + ]: 720 : if (abs(dtset%rfomega)>tol10 .and. (asr/=0 .or. chneut/=0)) then
355 : 0 : asr=0
356 : 0 : chneut=0
357 : : write(msg,'(5a)') &
358 : 0 : 'Finite-frequency linear-response calculation detected.',ch10,&
359 : 0 : 'The acoustic sum rule and charge neutrality do not hold in this regime.',ch10,&
360 : 0 : 'asr and chneut have been set to 0.'
361 : 0 : ABI_WARNING(msg)
362 : : end if
363 : :
364 : : !LIKELY TO BE TAKEN AWAY
365 : 720 : initialized=0
366 : 720 : ek=zero ; ehart=zero ; bigexc=zero ; eei=zero ; enl=zero
367 : 720 : eii=zero ; eew=zero ; ecore=zero ; bigsxc=zero
368 : :
369 : : !Set up for iterations
370 : : call setup1(dtset%acell_orig(1:3,1),bantot,dtset,&
371 : : ecutdg_eff,ecut_eff,gmet,gprimd,gsqcut_eff,gsqcutc_eff,&
372 : : ngfftf,ngfft,dtset%nkpt,dtset%nsppol,&
373 [ - + - - : 720 : response,rmet,dtset%rprim_orig(1:3,1:3,1),rprimd,ucvol,psps%usepaw)
- - ]
374 : : !In some cases (e.g. getcell/=0), the plane wave vectors have
375 : : ! to be generated from the original simulation cell
376 : 720 : rprimd_for_kg=rprimd
377 [ + + + - : 756 : if (dtset%getcell/=0.and.dtset%usewvl==0) rprimd_for_kg=dtset%rprimd_orig(:,:,1)
+ + + + ]
378 : 720 : call matr3inv(rprimd_for_kg,gprimd_for_kg)
379 [ + + + + : 28800 : gmet_for_kg=matmul(transpose(gprimd_for_kg),gprimd_for_kg)
+ + ]
380 : :
381 : : !Define the set of admitted perturbations
382 : : ! Note that we have a global parameter (mpert=natom+MPERT_MAX)
383 : : ! with MPERT_MAX=8, but we use a smaller value here.
384 : 720 : mpert=natom+7
385 [ + + ]: 720 : if (rf2_dkdk>0.or.rf2_dkde>0) mpert=natom+11
386 [ + + + + ]: 720 : if (dtset%rfmagn==2.or.dtset%prt1mag/=0) mpert=2*dtset%natom+11
387 : :
388 : : !Initialize the list of perturbations rfpert
389 [ - + + - : 2160 : ABI_MALLOC(rfpert,(mpert))
+ - + - -
+ - + ]
390 [ + + ]: 7461 : rfpert(:)=0
391 [ + + + + ]: 1490 : if(rfphon==1)rfpert(dtset%rfatpol(1):dtset%rfatpol(2))=1
392 : :
393 [ + + ]: 720 : if(rfddk==1)rfpert(natom+1)=1
394 : :
395 [ + + ]: 720 : if(rf2_dkdk/=0)rfpert(natom+10)=1
396 [ + + ]: 720 : if(rf2_dkde/=0)rfpert(natom+11)=1
397 : :
398 [ + + ]: 720 : if(rfelfd==1.or.rfelfd==2)rfpert(natom+1)=1
399 [ + + ]: 720 : if(rfelfd==1.or.rfelfd==3)rfpert(natom+2)=1
400 : :
401 [ + + ]: 720 : if(rfstrs==1.or.rfstrs==3)rfpert(natom+3)=1
402 [ + + ]: 720 : if(rfstrs==2.or.rfstrs==3)rfpert(natom+4)=1
403 : :
404 [ + + ]: 720 : if(rfmagn==1) rfpert(natom+5)=1
405 [ + + + + ]: 723 : if(rfmagn==2) rfpert(natom+11+dtset%rfatpol(1):natom+11+dtset%rfatpol(2))=1
406 [ + + ]: 720 : if(rfmagn==3) rfpert(natom+6)=1
407 : :
408 : 720 : qeq0=(dtset%qptn(1)**2+dtset%qptn(2)**2+dtset%qptn(3)**2<1.d-14)
409 : :
410 : : !Init spaceworld
411 : 720 : spaceworld=mpi_enreg%comm_cell
412 : 720 : me = xmpi_comm_rank(spaceworld)
413 : :
414 : : !Set up the basis sphere of planewaves
415 [ - + + - : 2160 : ABI_MALLOC(kg,(3,dtset%mpw*dtset%mkmem))
+ - + - -
+ - + ]
416 [ - + + - : 2160 : ABI_MALLOC(npwarr,(dtset%nkpt))
+ - + - -
+ - + ]
417 : : call kpgio(ecut_eff,dtset%exchn2n3d,gmet_for_kg,dtset%istwfk,kg,&
418 : : & dtset%kptns,dtset%mkmem,dtset%nband,dtset%nkpt,'PERS',mpi_enreg,dtset%mpw,npwarr,npwtot,&
419 : 720 : & dtset%nsppol)
420 : :
421 : : !Set up the Ylm for each k point
422 [ - + + - : 2880 : ABI_MALLOC(ylm,(dtset%mpw*dtset%mkmem,psps%mpsang*psps%mpsang*psps%useylm))
+ + + - +
- + + - +
- + ]
423 [ + + + - : 720 : if (rfstrs/=0.or.pawbec==1.or.pawpiezo==1.or.dtset%efmas>0) then
+ + ]
424 [ - + + - : 372 : ABI_MALLOC(ylmgr,(dtset%mpw*dtset%mkmem,9,psps%mpsang*psps%mpsang*psps%useylm))
+ + + - +
- + + - +
- + ]
425 : : else
426 [ + + + - : 1254 : ABI_MALLOC(ylmgr,(0,0,psps%useylm))
- + - + ]
427 : : end if
428 [ + + ]: 720 : if (psps%useylm==1) then
429 : 176 : option=0
430 [ + + + - : 176 : if (rfstrs/=0.or.pawbec==1.or.pawpiezo==1.or.dtset%efmas>0) option=2
+ + ]
431 : : call initylmg(gprimd,kg,dtset%kptns,dtset%mkmem,mpi_enreg,psps%mpsang,dtset%mpw,dtset%nband,dtset%nkpt,&
432 : 176 : & npwarr,dtset%nsppol,option,rprimd,ylm,ylmgr)
433 : : end if
434 : :
435 : 720 : call timab(133,2,tsec)
436 : 720 : call timab(134,1,tsec)
437 : :
438 : : !Open and read pseudopotential files
439 : : call pspini(dtset,dtfil,ecore,psp_gencond,gsqcutc_eff,gsqcut_eff,pawrad,pawtab,&
440 : 720 : & psps,rprimd,comm_mpi=mpi_enreg%comm_cell)
441 : :
442 : 720 : call timab(134,2,tsec)
443 : 720 : call timab(135,1,tsec)
444 : :
445 : : !Initialize band structure datatype
446 : 720 : call bstruct%from_dtset(dtset, npwarr)
447 : :
448 : : !Initialize PAW atomic occupancies
449 [ + + ]: 720 : if (psps%usepaw==1) then
450 [ + + + - : 540 : ABI_MALLOC(pawrhoij,(my_natom))
+ - + + -
+ - + - +
+ + + - ]
451 : 116 : call pawrhoij_nullify(pawrhoij)
452 : : call initrhoij(dtset%pawcpxocc,dtset%lexexch,dtset%lpawu, &
453 : : & my_natom,natom,dtset%nspden,dtset%nspinor,dtset%nsppol,dtset%ntypat,&
454 : : & pawrhoij,dtset%pawspnorb,pawtab,cplex1,dtset%spinat,dtset%typat,&
455 : 116 : & comm_atom=mpi_enreg%comm_atom, mpi_atmtab=mpi_enreg%my_atmtab)
456 : : else
457 [ - + - + ]: 604 : ABI_MALLOC(pawrhoij,(0))
458 : : end if
459 : :
460 : : !Initialize header
461 : 720 : gscase=0
462 : : call hdr%init(bstruct,codvsn,dtset,pawtab,gscase,psps,wvl%descr, &
463 : 720 : comm_atom=mpi_enreg%comm_atom, mpi_atmtab=mpi_enreg%my_atmtab)
464 : :
465 : : !Update header, with evolving variables, when available
466 : : !Here, rprimd, xred and occ are available
467 : 720 : etot=hdr%etot ; fermie=hdr%fermie ; fermih=hdr%fermih ; residm=hdr%residm
468 : :
469 : : !If parallelism over atom, hdr is distributed
470 : : call hdr%update(bantot,etot,fermie,fermih,&
471 : : residm,rprimd,occ,pawrhoij,xred,dtset%amu_orig(:,1), &
472 : 720 : comm_atom=mpi_enreg%comm_atom, mpi_atmtab=mpi_enreg%my_atmtab)
473 : :
474 : : !Clean band structure datatype (should use it more in the future !)
475 : 720 : call bstruct%free()
476 : :
477 : : !Initialize wavefunction files and wavefunctions.
478 : 720 : ireadwf0=1
479 : :
480 : :
481 : 720 : mcg=dtset%mpw*dtset%nspinor*dtset%mband_mem*dtset%mkmem*dtset%nsppol
482 [ - + + - : 2160 : ABI_MALLOC(cg,(2,mcg))
+ - + - -
+ - + ]
483 : : !ABI_MALLOC_OR_DIE(cg,(2,mcg), ierr)
484 : :
485 [ - + + - : 2160 : ABI_MALLOC(eigen0,(dtset%mband*dtset%nkpt*dtset%nsppol))
+ - + - -
+ - + ]
486 [ + + ]: 339357 : eigen0(:)=zero ; ask_accurate=1
487 : 720 : optorth=0
488 : :
489 : : ! Initialize the wave function type and read GS WFK
490 [ - + + - : 3600 : ABI_MALLOC(distrb_flags,(dtset%nkpt,dtset%mband,dtset%nsppol))
- + + - -
+ + - + -
+ - - + -
+ ]
491 [ + - + - : 347986 : distrb_flags = (mpi_enreg%proc_distrb == mpi_enreg%me_kpt)
+ - - + -
- + + + +
+ + ]
492 : : call wfk_read_my_kptbands(dtfil%fnamewffk, distrb_flags, spaceworld, dtset%ecut*(dtset%dilatmx)**2, &
493 : : & formeig, dtset%istwfk, dtset%kptns, mcg, dtset%mband, dtset%mband_mem,dtset%mkmem,dtset%mpw,&
494 : : & dtset%natom, dtset%nkpt, npwarr, dtset%nspinor, dtset%nsppol, dtset%usepaw,&
495 : 720 : & cg, eigen=eigen0, pawrhoij=hdr%pawrhoij)
496 [ - + ]: 720 : ABI_FREE(distrb_flags)
497 : :
498 [ + + ]: 720 : if (psps%usepaw==1 .and. ireadwf0==1) then
499 : : ! if parallelism, pawrhoij is distributed, hdr%pawrhoij is not
500 : : call pawrhoij_copy(hdr%pawrhoij,pawrhoij,comm_atom=mpi_enreg%comm_atom,&
501 : 116 : & mpi_atmtab=mpi_enreg%my_atmtab)
502 : : end if
503 : :
504 : 720 : call timab(135,2,tsec)
505 : 720 : call timab(136,1,tsec)
506 : :
507 : : ! Report on eigen0 values ! Should use prteigrs.F90
508 : : !write(msg, '(a,a)' )
509 : : !call wrtout(std_out,ch10//' respfn : eigen0 array')
510 : : !nkpt_eff=dtset%nkpt
511 : : !nkpt_max=50;if(xmpi_paral==1)nkpt_max=-1
512 : : !if( (dtset%prtvol==0.or.dtset%prtvol==1.or.dtset%prtvol==2) .and. dtset%nkpt>nkpt_max ) nkpt_eff=nkpt_max
513 : : !band_index=0
514 : : !do isppol=1,dtset%nsppol
515 : : ! do ikpt=1,dtset%nkpt
516 : : ! nband_k=dtset%nband(ikpt+(isppol-1)*dtset%nkpt)
517 : : ! if(ikpt<=nkpt_eff)then
518 : : ! write(msg, '(a,i2,a,i5)' )' isppol=',isppol,', k point number',ikpt
519 : : ! call wrtout(std_out,msg)
520 : : ! do iband=1,nband_k,4
521 : : ! write(msg, '(a,4es16.6)')' ',eigen0(iband+band_index:min(iband+3,nband_k)+band_index)
522 : : ! call wrtout(std_out,msg)
523 : : ! end do
524 : : ! else if(ikpt==nkpt_eff+1)then
525 : : ! write(msg,'(a,a)' )' respfn : prtvol=0, 1 or 2, stop printing eigen0.',ch10
526 : : ! call wrtout(std_out,msg)
527 : : ! end if
528 : : ! band_index=band_index+nband_k
529 : : ! end do
530 : : !end do
531 : :
532 : : !Allocation for forces and atomic positions (should be taken away, also argument ... )
533 [ - + + - : 2160 : ABI_MALLOC(grxc,(3,natom))
+ - + - -
+ - + ]
534 : :
535 : : !Do symmetry stuff
536 [ - + + - : 2880 : ABI_MALLOC(irrzon,(nfftot**(1-1/dtset%nsym),2,(dtset%nspden/dtset%nsppol)-3*(dtset%nspden/4)))
- + + - +
- + - - +
- + ]
537 [ - + + - : 2880 : ABI_MALLOC(phnons,(2,nfftot**(1-1/dtset%nsym),(dtset%nspden/dtset%nsppol)-3*(dtset%nspden/4)))
- + + - +
- + - - +
- + ]
538 [ - + + - : 2880 : ABI_MALLOC(indsym,(4,dtset%nsym,natom))
- + + - +
- + - - +
- + ]
539 [ - + + - : 2160 : ABI_MALLOC(symrec,(3,3,dtset%nsym))
+ - + - -
+ - + ]
540 [ + + + + : 17611821 : irrzon=0;indsym=0;symrec=0;phnons=zero
+ + + + +
+ + + + +
+ + + + +
+ + + +
+ ]
541 : : !If the density is to be computed by mkrho, need irrzon and phnons
542 [ + + ]: 720 : iscf_eff=0;if(dtset%getden==0)iscf_eff=1
543 : : call setsym(indsym,irrzon,iscf_eff,natom,&
544 : : & nfftot,ngfft,dtset%nspden,dtset%nsppol,dtset%nsym,&
545 : 720 : & phnons,dtset%symafm,symrec,dtset%symrel,dtset%tnons,dtset%typat,xred)
546 : :
547 : : !Symmetrize atomic coordinates over space group elements:
548 : 720 : call symmetrize_xred(natom,dtset%nsym,dtset%symrel,dtset%tnons,xred,indsym=indsym)
549 : :
550 : : !Examine the symmetries of the q wavevector
551 [ - + + - : 2160 : ABI_MALLOC(symq,(4,2,dtset%nsym))
+ - + - -
+ - + ]
552 : : timrev=1
553 : :
554 : : ! By default use symmetries.
555 : 720 : use_sym = 1
556 [ + + ]: 720 : if (dtset%prtgkk == 1)then
557 : 22 : use_sym = 0
558 : 22 : call littlegroup_q(dtset%nsym,dtset%qptn,symq,symrec,dtset%symafm,timrev,prtvol=dtset%prtvol,use_sym=use_sym)
559 : : else
560 : 698 : call littlegroup_q(dtset%nsym,dtset%qptn,symq,symrec,dtset%symafm,timrev,prtvol=dtset%prtvol)
561 : : end if
562 : :
563 : : !Deactivate time-reversal symmetry for finite-omega calculations
564 [ + + + + ]: 720 : if (abs(dtset%rfomega)>tol10.or.dtset%tim1rev==0) timrev=0
565 : :
566 : : !Generate an index table of atoms, in order for them to be used
567 : : !type after type.
568 [ - + + - : 2160 : ABI_MALLOC(atindx,(natom))
+ - + - -
+ - + ]
569 [ - + + - : 1440 : ABI_MALLOC(atindx1,(natom))
- + - + ]
570 [ - + + - : 2160 : ABI_MALLOC(nattyp,(ntypat))
+ - + - -
+ - + ]
571 : 1797 : indx=1
572 [ + + ]: 1797 : do itypat=1,ntypat
573 : 1077 : nattyp(itypat)=0
574 [ + + ]: 4292 : do iatom=1,natom
575 [ + + ]: 3572 : if(dtset%typat(iatom)==itypat)then
576 : 1531 : atindx(iatom)=indx
577 : 1531 : atindx1(indx)=iatom
578 : 1531 : indx=indx+1
579 : 1531 : nattyp(itypat)=nattyp(itypat)+1
580 : : end if
581 : : end do
582 : : end do
583 : :
584 : : !Here allocation of GPU for fft calculations
585 : : #if defined HAVE_GPU
586 : : if (dtset%gpu_option/=ABI_GPU_DISABLED) then
587 : : call alloc_hamilt_gpu(atindx1,dtset,gprimd,mpi_enreg,nattyp,npwarr,0,psps,dtset%gpu_option)
588 : : end if
589 : : #endif
590 : :
591 : : !Compute structure factor phases for current atomic pos:
592 [ + - - + : 2160 : ABI_MALLOC(ph1d,(2,3*(2*dtset%mgfft+1)*natom))
+ - + - +
- - + -
+ ]
593 [ + - - + : 2160 : ABI_MALLOC(ph1df,(2,3*(2*mgfftf+1)*natom))
+ - + - +
- - + -
+ ]
594 : 720 : call getph(atindx,natom,ngfft(1),ngfft(2),ngfft(3),ph1d,xred)
595 : :
596 [ + + + + ]: 720 : if (psps%usepaw==1.and.pawfgr%usefinegrid==1) then
597 : 98 : call getph(atindx,natom,ngfftf(1),ngfftf(2),ngfftf(3),ph1df,xred)
598 : : else
599 [ + + + + ]: 493732 : ph1df(:,:)=ph1d(:,:)
600 : : end if
601 : :
602 : : !Compute occupation numbers and fermi energy, in case occupation scheme is metallic.
603 [ - + + - : 1440 : ABI_MALLOC(doccde,(dtset%mband*dtset%nkpt*dtset%nsppol))
- + - + ]
604 [ + + ]: 720 : if( dtset%occopt>=3.and.dtset%occopt<=9 ) then
605 : :
606 : : call newocc(doccde,eigen0,entropy,fermie,fermih,dtset%ivalence,&
607 : : & dtset%spinmagntarget,dtset%mband,dtset%nband,dtset%nelect,dtset%ne_qFD,dtset%nh_qFD,&
608 : : & dtset%nkpt,dtset%nspinor,dtset%nsppol,occ,dtset%occopt,dtset%prtvol,&
609 : 166 : & dtset%tphysel,dtset%tsmear,dtset%wtk)
610 : :
611 : : ! Update fermie and occ
612 : 166 : etot=hdr%etot ; residm=hdr%residm
613 : 166 : call hdr%update(bantot,etot,fermie,fermih,residm,rprimd,occ,pawrhoij,xred,dtset%amu_orig(:,1))
614 : :
615 : : else
616 : : ! doccde is irrelevant in this case
617 [ + + ]: 190287 : doccde(:)=zero
618 : : end if
619 : :
620 : : !Recompute first large sphere cut-off gsqcut, without taking into account dilatmx
621 : 720 : ecutf=dtset%ecut
622 [ + + ]: 720 : if (psps%usepaw==1) then
623 : 116 : ecutf=dtset%pawecutdg
624 : 116 : call wrtout(std_out,ch10//' FFT (fine) grid used in SCF cycle:')
625 : : end if
626 : :
627 : 720 : call getcut(boxcut,ecutf,gmet,gsqcut,dtset%iboxcut,std_out,k0,ngfftf)
628 : :
629 : : !PAW: 1- Initialize values for several arrays depending only on atomic data
630 : : !2- Check overlap
631 : : !3- Identify FFT points in spheres and compute g_l(r).Y_lm(r) (and exp(-i.q.r) if needed)
632 : : !4- Allocate PAW specific arrays
633 : : !5- Compute perturbed local potential inside spheres
634 : : !6- Eventually open temporary storage files
635 [ + + ]: 720 : if(psps%usepaw==1) then
636 : : ! 1-Initialize values for several arrays depending only on atomic data
637 : 116 : gnt_option=1
638 : : if (dtset%pawxcdev==2.or.dtset%rfphon/=0.or.dtset%rfstrs/=0.or.dtset%rfelfd==1.or.&
639 [ + - + + : 116 : dtset%rfelfd==3.or.dtset%rf2_dkde==1) gnt_option=2
+ - + - +
+ + + ]
640 : :
641 : : ! Test if we have to call pawinit
642 : 116 : call paw_gencond(Dtset,gnt_option,"test",call_pawinit)
643 : :
644 [ + + + + ]: 116 : if (psp_gencond==1.or.call_pawinit) then
645 : : ! Some gen-cond have to be added...
646 : 60 : call timab(553,1,tsec)
647 : : call pawinit(dtset%effmass_free,gnt_option,zero,zero,dtset%pawlcutd,dtset%pawlmix,&
648 : : & psps%mpsang,dtset%pawnphi,dtset%nsym,dtset%pawntheta,&
649 : 60 : & pawang,pawrad,dtset%pawspnorb,pawtab,dtset%pawxcdev,dtset%ixc,dtset%usepotzero)
650 : : call setsym_ylm(gprimd,pawang%l_max-1,dtset%nsym,dtset%pawprtvol,&
651 : 60 : & rprimd,symrec,pawang%zarot)
652 : :
653 : : ! Update internal values
654 : 60 : call paw_gencond(Dtset,gnt_option,"save",call_pawinit)
655 : :
656 : 60 : call timab(553,2,tsec)
657 : : else
658 [ - + - - ]: 56 : if (pawtab(1)%has_kij ==1) pawtab(1:psps%ntypat)%has_kij =2
659 [ - + - - ]: 56 : if (pawtab(1)%has_nabla==1) pawtab(1:psps%ntypat)%has_nabla=2
660 : : end if
661 [ + + ]: 318 : psps%n1xccc=maxval(pawtab(1:psps%ntypat)%usetcore)
662 : 116 : call setsym_ylm(gprimd,pawang%l_max-1,dtset%nsym,dtset%pawprtvol,rprimd,symrec,pawang%zarot)
663 : : call pawpuxinit(dtset%dmatpuopt,dtset%exchmix,dtset%f4of2_sla,dtset%f6of2_sla,&
664 : : & is_dfpt,dtset%jpawu,dtset%lexexch,dtset%lpawu,dtset%nspinor,ntypat,dtset%optdcmagpawu,pawang,dtset%pawprtvol,pawrad,&
665 : 116 : & pawtab,dtset%upawu,dtset%usedmft,dtset%useexexch,dtset%usepawu)
666 : 116 : compch_fft=-1.d5;compch_sph=-1.d5
667 [ + + ]: 318 : usexcnhat=maxval(pawtab(:)%usexcnhat)
668 : 116 : usecprj=dtset%pawusecp
669 : : ! 2-Check overlap
670 : 116 : call chkpawovlp(natom,psps%ntypat,dtset%pawovlp,pawtab,rmet,dtset%typat,xred)
671 : : ! 3-Identify FFT points in spheres and compute g_l(r).Y_lm(r) and exp(-i.q.r)
672 [ + + + - : 540 : ABI_MALLOC(pawfgrtab,(my_natom))
+ - + + -
+ - + - +
+ + ]
673 [ + + ]: 116 : if (my_natom>0) then
674 : : call pawtab_get_lsize(pawtab,l_size_atm,my_natom,dtset%typat,&
675 : 106 : & mpi_atmtab=mpi_enreg%my_atmtab)
676 : : call pawfgrtab_init(pawfgrtab,1,l_size_atm,pawrhoij(1)%nspden,dtset%typat,&
677 : 106 : & mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom)
678 [ - + ]: 106 : ABI_FREE(l_size_atm)
679 : : end if
680 [ + + + - : 116 : use_nhat_gga=(dtset%xclevel==2.and.dtset%pawnhatxc>0.and.usexcnhat>0)
+ + ]
681 : 116 : optcut=0;optgr0=dtset%pawstgylm;optgr1=0;optgr2=0;optrad=1-dtset%pawstgylm
682 [ + + ]: 116 : if (use_nhat_gga) then
683 : 4 : optgr1=dtset%pawstgylm
684 [ + + ]: 4 : if (rfphon==1) optgr2=1
685 : : end if
686 [ + + + + ]: 116 : if (rfphon==1.or.rfstrs/=0.or.rfelfd==3.or.rf2_dkde==1) then ! LB2016-11-28 : Why not rfelfd==1?
687 [ + + ]: 55 : if (optgr1==0) optgr1=dtset%pawstgylm
688 [ + + ]: 55 : if (optgr2==0) optgr2=dtset%pawstgylm
689 [ + - + + : 55 : if (optrad==0.and.(.not.qeq0.or.rfstrs/=0.or.rfelfd==3.or.rf2_dkde==1)) optrad=1 ! LB2016-11-28 : Why not rfelfd==1?
+ + ]
690 : : end if
691 [ + + + + ]: 116 : if (rfelfd==1.or.rfelfd==3.or.rf2_dkde==1) then
692 [ - + ]: 22 : if (optgr1==0) optgr1=dtset%pawstgylm
693 : : end if
694 : : call nhatgrid(atindx1,gmet,my_natom,natom,nattyp,ngfftf,psps%ntypat,&
695 : : & optcut,optgr0,optgr1,optgr2,optrad,pawfgrtab,pawtab,rprimd,dtset%typat,ucvol,xred,&
696 : 116 : & comm_atom=mpi_enreg%comm_atom, mpi_atmtab=mpi_enreg%my_atmtab )
697 : : ! Compute exp(iq.r) factors around the atoms
698 [ + + ]: 116 : if (.not.qeq0) then
699 [ + + ]: 28 : do iatom=1,my_natom
700 [ + + ]: 14 : iatom_tot=iatom; if (paral_atom) iatom_tot=mpi_enreg%my_atmtab(iatom)
701 [ + - ]: 14 : if (allocated(pawfgrtab(iatom)%expiqr)) then
702 : 14 : ABI_FREE(pawfgrtab(iatom)%expiqr)
703 : : end if
704 [ - + + - : 42 : ABI_MALLOC(pawfgrtab(iatom)%expiqr,(2,pawfgrtab(iatom)%nfgd))
+ - + - -
+ - + -
+ ]
705 : : call pawexpiqr(pawfgrtab(iatom)%expiqr,gprimd,pawfgrtab(iatom)%nfgd,dtset%qptn,&
706 : 14 : & pawfgrtab(iatom)%rfgd,xred(:,iatom_tot))
707 : 28 : pawfgrtab(iatom)%expiqr_allocated=1
708 : : end do
709 : : end if
710 : : ! 4-Allocate PAW specific arrays
711 [ + + + - : 540 : ABI_MALLOC(paw_an,(my_natom))
+ - + + -
+ - + - +
+ + + - ]
712 [ + + + - : 540 : ABI_MALLOC(paw_ij,(my_natom))
+ - + + -
+ - + - +
+ + + - ]
713 : 116 : call paw_an_nullify(paw_an)
714 : 116 : call paw_ij_nullify(paw_ij)
715 : 116 : has_kxc=0;nkxc1=0;cplex=1
716 [ + + + + : 1164 : has_dijnd=0; if(any(abs(dtset%nucdipmom)>tol8)) has_dijnd=1
+ + + + ]
717 [ - + ]: 116 : has_diju=merge(0,1,dtset%usepawu==0)
718 [ + + + + : 116 : if (rfphon/=0.or.rfelfd==1.or.rfelfd==3.or.rfstrs/=0.or.rf2_dkde/=0) then
+ + ]
719 : 55 : has_kxc=1
720 : 55 : call pawxc_get_nkxc(nkxc1,dtset%nspden,dtset%xclevel)
721 : : end if
722 : 116 : has_vhartree=0
723 [ + + + + ]: 116 : if(dtset%orbmag>0 .AND. dtset%pawspnorb > 0) has_vhartree=1
724 : 116 : usevxctau_paw=pawxc_get_usekden(dtset%ixc)
725 : : call paw_an_init(paw_an,dtset%natom,dtset%ntypat,nkxc1,0,dtset%nspden,&
726 : : & cplex,dtset%pawxcdev,dtset%typat,pawang,pawtab,has_vxc=1,has_vhartree=has_vhartree,has_vxctau=usevxctau_paw,&
727 : 116 : & has_vxc_ex=1,has_kxc=has_kxc,mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom)
728 : : call paw_ij_init(paw_ij,cplex,dtset%nspinor,dtset%nsppol,dtset%nspden,dtset%pawspnorb,&
729 : : & natom,dtset%ntypat,dtset%typat,pawtab,has_dij=1,has_dijhartree=1,has_dijnd=has_dijnd,&
730 : : & has_dijso=1,has_dijU=has_diju,has_pawu_occ=1,has_exexch_pot=1,&
731 : : & nucdipmom=dtset%nucdipmom,zora=dtset%zora,&
732 : 232 : & mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom)
733 : :
734 : : else ! PAW vs NCPP
735 : 604 : usexcnhat=0;usecprj=0
736 : 604 : use_nhat_gga=.false.
737 [ - + - + ]: 604 : ABI_MALLOC(paw_an,(0))
738 [ - + - + ]: 604 : ABI_MALLOC(paw_ij,(0))
739 [ - + - + ]: 604 : ABI_MALLOC(pawfgrtab,(0))
740 : : end if ! paw
741 : :
742 [ - + + - : 2160 : ABI_MALLOC(rhog,(2,nfftf))
+ - + - -
+ - + ]
743 [ - + + - : 2880 : ABI_MALLOC(rhor,(nfftf,dtset%nspden))
- + + - +
- + - - +
- + ]
744 [ + + + - : 2160 : ABI_MALLOC(taug,(2,nfftf*dtset%usekden))
+ - + + -
+ - + ]
745 [ - + + - : 2880 : ABI_MALLOC(taur,(nfftf,dtset%nspden*dtset%usekden))
+ + + - +
- + + - +
- + - + ]
746 : :
747 : : !>>> Initialize charge density
748 : :
749 : : ABI_NVTX_START_RANGE(NVTX_MKRHO)
750 [ + + - + ]: 720 : if (dtset%getden/=0.or.dtset%irdden/=0) then
751 : : ! Choice 1: read charge density from a disk file and broadcast data
752 : : ! This part is not compatible with MPI-FFT (note single_proc=.True. below)
753 : 86 : rdwrpaw=psps%usepaw ; if(ireadwf0/=0) rdwrpaw=0
754 : : if (rdwrpaw/=0) then
755 : : ABI_MALLOC(pawrhoij_read,(natom))
756 : : call pawrhoij_nullify(pawrhoij_read)
757 : : call pawrhoij_inquire_dim(cplex_rhoij=cplex_rhoij,nspden_rhoij=nspden_rhoij,&
758 : : & nspden=dtset%nspden,spnorb=dtset%pawspnorb,cpxocc=dtset%pawcpxocc)
759 : : call pawrhoij_alloc(pawrhoij_read,cplex_rhoij,nspden_rhoij,dtset%nspinor,&
760 : : & dtset%nsppol,dtset%typat,pawtab=pawtab)
761 : : else
762 [ - + - + ]: 86 : ABI_MALLOC(pawrhoij_read,(0))
763 : : end if
764 : : ! Note MT july 2013: should we read rhoij from the density file?
765 : : call read_rhor(dtfil%fildensin,cplex1,dtset%nspden,nfftf,ngfftf,rdwrpaw,&
766 : 86 : & mpi_enreg,rhor,hdr_den,pawrhoij_read,spaceworld,check_hdr=hdr)
767 : 86 : etotal = hdr_den%etot
768 : 86 : call hdr_den%free()
769 : : if (rdwrpaw/=0) then
770 : : call pawrhoij_bcast(pawrhoij_read,hdr%pawrhoij,0,spaceworld)
771 : : call pawrhoij_free(pawrhoij_read)
772 : : end if
773 [ + - - + : 86 : ABI_FREE(pawrhoij_read)
- - - - -
- - - - -
- - - + ]
774 : : ! Compute up+down rho(G) by fft
775 : 86 : call fourdp(1,rhog,rhor(:,1),-1,mpi_enreg,nfftf,1,ngfftf,0)
776 : :
777 : : else
778 : : ! Choice 2: obtain the charge density from read wfs
779 : : ! Warning: in PAW, compensation density has to be added !
780 : 634 : tim_mkrho=4
781 : 634 : paw_dmft%use_dmft=0 ; paw_dmft%use_sc_dmft=0 ! respfn with dmft not implemented
782 [ + + ]: 634 : if (psps%usepaw==1) then
783 [ - + + - : 285 : ABI_MALLOC(rhowfg,(2,dtset%nfft))
+ - + - -
+ - + ]
784 [ - + + - : 380 : ABI_MALLOC(rhowfr,(dtset%nfft,dtset%nspden))
- + + - +
- + - - +
- + ]
785 : : call mkrho(cg,dtset,gprimd,irrzon,kg,mcg,mpi_enreg,npwarr,occ,paw_dmft,phnons,&
786 : 95 : & rhowfg,rhowfr,rprimd,tim_mkrho,ucvol,wvl%den,wvl%wfs)
787 : 95 : call transgrid(1,mpi_enreg,dtset%nspden,+1,1,1,dtset%paral_kgb,pawfgr,rhowfg,rhog,rhowfr,rhor)
788 [ - + ]: 95 : ABI_FREE(rhowfg)
789 [ - + ]: 95 : ABI_FREE(rhowfr)
790 : : else
791 : : call mkrho(cg,dtset,gprimd,irrzon,kg,mcg,mpi_enreg,npwarr,occ,paw_dmft,phnons,&
792 : 539 : & rhog,rhor,rprimd,tim_mkrho,ucvol,wvl%den,wvl%wfs)
793 : : end if
794 : :
795 : : end if ! choice for charge density initialization
796 : : ABI_NVTX_END_RANGE()
797 : :
798 : : !>>> Initialize kinetic energy density
799 [ + + ]: 720 : if (dtset%usekden==1) then
800 : :
801 [ + - - + ]: 2 : if (dtset%getkden/=0.or.dtset%irdkden/=0) then
802 : : ! Choice 1: read kinetic energy density from a disk file and broadcast data
803 : : ! This part is not compatible with MPI-FFT (note single_proc=.True. below)
804 : 0 : rdwrpaw=0
805 [ # # # # ]: 0 : ABI_MALLOC(pawrhoij_read,(0))
806 : : call read_rhor(dtfil%filkdensin,cplex1,dtset%nspden,nfftf,ngfftf,rdwrpaw,&
807 : 0 : & mpi_enreg,taur,hdr_den,pawrhoij_read,spaceworld,check_hdr=hdr)
808 : 0 : call hdr_den%free()
809 [ # # # # : 0 : ABI_FREE(pawrhoij_read)
# # # # #
# # # # #
# # # # ]
810 : : ! Compute up+down tau(G) by fft
811 : 0 : call fourdp(1,taug,taur(:,1),-1,mpi_enreg,nfftf,1,ngfftf,0)
812 : :
813 : : else
814 : : ! Choice 2: obtain the kinetic energy density from read wfs
815 : 2 : tim_mkrho=4
816 : 2 : paw_dmft%use_dmft=0 ; paw_dmft%use_sc_dmft=0 ! respfn with dmft not implemented
817 [ + - ]: 2 : if (psps%usepaw==1) then
818 [ - + + - : 6 : ABI_MALLOC(rhowfg,(2,dtset%nfft))
+ - + - -
+ - + ]
819 [ - + + - : 8 : ABI_MALLOC(rhowfr,(dtset%nfft,dtset%nspden))
- + + - +
- + - - +
- + ]
820 : : call mkrho(cg,dtset,gprimd,irrzon,kg,mcg,mpi_enreg,npwarr,occ,paw_dmft,phnons,&
821 : 2 : & rhowfg,rhowfr,rprimd,tim_mkrho,ucvol,wvl%den,wvl%wfs,option=1)
822 : 2 : call transgrid(1,mpi_enreg,dtset%nspden,+1,1,1,dtset%paral_kgb,pawfgr,rhowfg,taug,rhowfr,taur)
823 [ - + ]: 2 : ABI_FREE(rhowfg)
824 [ - + ]: 2 : ABI_FREE(rhowfr)
825 : : else
826 : : call mkrho(cg,dtset,gprimd,irrzon,kg,mcg,mpi_enreg,npwarr,occ,paw_dmft,phnons,&
827 : 0 : & taug,taur,rprimd,tim_mkrho,ucvol,wvl%den,wvl%wfs,option=1)
828 : : end if
829 : :
830 : : end if ! choice for kinetic energy density initialization
831 : : end if ! usekden
832 : :
833 : : !In PAW, compensation density has eventually to be added
834 : 720 : nhatgrdim=0;nhatdim=0
835 [ - + ]: 720 : ABI_MALLOC(nhatgr,(0,0,0))
836 [ + + + + : 720 : if (psps%usepaw==1.and. ((usexcnhat==0).or.(dtset%getden==0).or.dtset%xclevel==2)) then
+ + - + ]
837 : 110 : nhatdim=1
838 : :
839 [ - + + - : 440 : ABI_MALLOC(nhat,(nfftf,dtset%nspden))
- + + - +
- + - - +
- + ]
840 : 110 : call timab(558,1,tsec)
841 [ + + + - ]: 110 : nhatgrdim=0;if (dtset%xclevel==2.and.dtset%pawnhatxc>0) nhatgrdim=usexcnhat
842 : 110 : ider=2*nhatgrdim
843 [ + + ]: 110 : if (nhatgrdim>0) then
844 [ - + ]: 4 : ABI_FREE(nhatgr)
845 [ - + + - : 20 : ABI_MALLOC(nhatgr,(nfftf,dtset%nspden,3))
- + + - +
- + - + -
- + - + ]
846 : : end if
847 : 110 : izero=0;cplex=1;ipert=0;idir=0;qphon(:)=zero
848 : : call pawmknhat(compch_fft,cplex,ider,idir,ipert,izero,gprimd,my_natom,natom,&
849 : : & nfftf,ngfftf,nhatgrdim,dtset%nspden,psps%ntypat,pawang,pawfgrtab,&
850 : : & nhatgr,nhat,pawrhoij,pawrhoij,pawtab,qphon,rprimd,ucvol,dtset%usewvl,xred, &
851 : 110 : & mpi_atmtab=mpi_enreg%my_atmtab, comm_atom=mpi_enreg%comm_atom)
852 [ + + ]: 110 : if (dtset%getden==0) then
853 [ + + + + ]: 7255358 : rhor(:,:)=rhor(:,:)+nhat(:,:)
854 : 95 : call fourdp(1,rhog,rhor(:,1),-1,mpi_enreg,nfftf,1,ngfftf,0)
855 : : end if
856 : 110 : call timab(558,2,tsec)
857 : : else
858 [ - + ]: 610 : ABI_MALLOC(nhat,(0,0))
859 : : end if
860 : :
861 : : !The GS irrzon and phnons were only needed to symmetrize the GS density
862 [ - + ]: 720 : ABI_FREE(irrzon)
863 [ - + ]: 720 : ABI_FREE(phnons)
864 : :
865 : : !Will compute now the total potential
866 : :
867 : : !Compute local ionic pseudopotential vpsp and core electron density xccc3d
868 [ + + ]: 720 : n3xccc=0;if (psps%n1xccc/=0) n3xccc=nfftf
869 [ + + + - : 2160 : ABI_MALLOC(xccc3d,(n3xccc))
+ - + + -
+ - + ]
870 [ - + + - : 2160 : ABI_MALLOC(vpsp,(nfftf))
+ - + - -
+ - + ]
871 [ + + ]: 720 : if(psps%usepaw==1) then
872 [ + + + - : 348 : ABI_MALLOC(xcctau3d,(n3xccc*dtset%usekden))
+ - + + -
+ - + -
+ ]
873 : : else
874 [ - + - + ]: 604 : ABI_MALLOC(xcctau3d,(0))
875 : : end if
876 : :
877 : : ! Handling GEMM nonlop use
878 : : ! Not enabled by default for CPU and CUDA implementations
879 : : ! Enabled if using OpenMP GPU offload
880 : 720 : gemm_nonlop_use_gemm = .false.
881 : :
882 : : ! OpenMP GPU offload case (GEMM nonlop used by default)
883 [ + - - + ]: 720 : if(dtset%gpu_option == ABI_GPU_OPENMP .or. dtset%use_gemm_nonlop == 1) then
884 : 0 : gemm_nonlop_use_gemm = .true.
885 : 0 : call init_gemm_nonlop(dtset%gpu_option)
886 : : end if
887 : :
888 : 720 : gemm_nonlop_is_distributed = .false.
889 [ - + ]: 720 : if(dtset%gpu_nl_distrib == 1) gemm_nonlop_is_distributed = .true.
890 : :
891 : : !Determine by which method the local ionic potential and/or
892 : : ! the pseudo core charge density have to be computed
893 : : !Local ionic potential:
894 : : ! Method 1: PAW ; Method 2: Norm-conserving PP
895 [ + + ]: 720 : vloc_method=1;if (psps%usepaw==0) vloc_method=2
896 : : !Pseudo core charge density:
897 : : ! Method 1: PAW, nc_xccc_gspace ; Method 2: Norm-conserving PP
898 : : coredens_method=1;if (psps%usepaw==0) coredens_method=2
899 [ + + ]: 720 : if (psps%nc_xccc_gspace==1) coredens_method=1
900 [ + + ]: 720 : if (psps%nc_xccc_gspace==0) coredens_method=2
901 : :
902 : : ! Core kinetic energy density method
903 : 720 : coretau_method = 0
904 [ + + + - ]: 720 : if (dtset%usekden==1.and.psps%usepaw==1) then
905 : 2 : coretau_method=1
906 [ - + ]: 2 : if (psps%nc_xccc_gspace==0) then
907 : 0 : coretau_method=2
908 : : end if
909 : : end if
910 : :
911 : :
912 : : !Local ionic potential and/or pseudo core charge by method 1
913 [ + + ]: 720 : if (vloc_method==1.or.coredens_method==1) then
914 : 117 : call timab(562,1,tsec)
915 [ + + ]: 117 : optv=0;if (vloc_method==1) optv=1
916 [ + - ]: 117 : optn=0;if (coredens_method==1) optn=n3xccc/nfftf
917 : 117 : optatm=1;optdyfr=0;opteltfr=0;optgr=0;optstr=0;optn2=1
918 : : call atm2fft(atindx1,xccc3d,vpsp,dum_dyfrn,dum_dyfrv,dum_eltfrxc,dum_gauss,gmet,gprimd,&
919 : : & dum_grn,dum_grv,gsqcut,mgfftf,psps%mqgrid_vl,natom,nattyp,nfftf,ngfftf,&
920 : : & ntypat,optatm,optdyfr,opteltfr,optgr,optn,optn2,optstr,optv,psps,pawtab,ph1df,psps%qgrid_vl,&
921 : 117 : & dtset%qprtrb,dtset%rcut,dum_rhog,rprimd,strn_dummy6,strv_dummy6,ucvol,psps%usepaw,dum_vg,dum_vg,dum_vg,dtset%vprtrb,psps%vlspl)
922 : 117 : call timab(562,2,tsec)
923 : : end if
924 : :
925 [ + + ]: 720 : if (coretau_method==1) then
926 : 2 : optv=0;optn=1
927 : 2 : optatm=1;optdyfr=0;opteltfr=0;optgr=0;optstr=0;optn2=4
928 : : call atm2fft(atindx1,xcctau3d,dummy_out6,dummy_out1,dummy_out2,dummy_out3,dummy_in,&
929 : : & gmet,gprimd,dummy_out4,dummy_out5,gsqcut,mgfftf,psps%mqgrid_vl,dtset%natom,nattyp,nfftf,ngfftf,ntypat,&
930 : : & optatm,optdyfr,opteltfr,optgr,optn,optn2,optstr,optv,psps,pawtab,ph1df,psps%qgrid_vl,dtset%qprtrb,&
931 : : & dtset%rcut,dummy_in,rprimd,strn_dummy6,strv_dummy6,ucvol,psps%usepaw,dummy_in,dummy_in,dummy_in,dtset%vprtrb,psps%vlspl,&
932 : : & comm_fft=mpi_enreg%comm_fft,me_g0=mpi_enreg%me_g0,&
933 : 2 : & paral_kgb=mpi_enreg%paral_kgb,distribfft=mpi_enreg%distribfft)
934 : : end if
935 : :
936 : : !Local ionic potential by method 2
937 [ + + ]: 720 : if (vloc_method==2) then
938 : 604 : option=1
939 [ - + + - : 1812 : ABI_MALLOC(dyfrlo_indx,(3,3,natom))
+ - + - -
+ - + ]
940 [ - + + - : 1812 : ABI_MALLOC(grtn_indx,(3,natom))
+ - + - -
+ - + ]
941 : : call mklocl(dtset,dyfrlo_indx,eei,gmet,gprimd,&
942 : : & grtn_indx,gsqcut,dummy6,mgfftf,mpi_enreg,natom,nattyp,&
943 : : & nfftf,ngfftf,dtset%nspden,ntypat,option,pawtab,ph1df,psps,&
944 : 604 : & dtset%qprtrb,rhog,rhor,rprimd,ucvol,dtset%vprtrb,vpsp,wvl%descr,wvl%den,xred)
945 [ - + ]: 604 : ABI_FREE(dyfrlo_indx)
946 [ - + ]: 604 : ABI_FREE(grtn_indx)
947 : : end if
948 : :
949 : : !Pseudo core electron density by method 2
950 [ + + + + ]: 720 : if (coredens_method==2.and.psps%n1xccc/=0) then
951 : 356 : option=1
952 [ - + + - : 1068 : ABI_MALLOC(dyfrx2,(3,3,natom))
+ - + - -
+ - + ]
953 [ - + - + ]: 356 : ABI_MALLOC(vxc,(0,0)) ! dummy
954 : : call mkcore(dummy6,dyfrx2,grxc,mpi_enreg,natom,nfftf,dtset%nspden,ntypat,&
955 : : & ngfftf(1),psps%n1xccc,ngfftf(2),ngfftf(3),option,rprimd,dtset%typat,ucvol,vxc,&
956 : 356 : & psps%xcccrc,psps%xccc1d,xccc3d,xred)
957 [ - + ]: 356 : ABI_FREE(dyfrx2)
958 [ - + ]: 356 : ABI_FREE(vxc) ! dummy
959 : : end if
960 : :
961 : : !Set up hartree and xc potential. Compute kxc here.
962 [ - + + - : 1440 : ABI_MALLOC(vhartr,(nfftf))
- + - + ]
963 : :
964 : : call hartre(1,gsqcut,dtset%icutcoul,psps%usepaw,mpi_enreg,nfftf,ngfftf,&
965 : 720 : &dtset%nkpt,dtset%rcut,rhog,rprimd,dtset%vcutgeo,vhartr)
966 : :
967 : 720 : option=2 ; nk3xc=1
968 [ + + ]: 720 : nkxc=2*min(dtset%nspden,2)-1;if(dtset%xclevel==2)nkxc=12*min(dtset%nspden,2)-5
969 : 720 : call check_kxc(dtset%ixc,dtset%optdriver)
970 [ - + + - : 2880 : ABI_MALLOC(kxc,(nfftf,nkxc))
- + + - +
- + - - +
- + ]
971 [ - + + - : 2880 : ABI_MALLOC(vxc,(nfftf,dtset%nspden))
- + + - +
- + - - +
- + - + ]
972 [ + + ]: 720 : usevxctau=merge(1,0,xc_need_kden(dtset%ixc))
973 [ - + + - : 3602 : ABI_MALLOC(vxctau,(nfftf,dtset%nspden,4*usevxctau))
- + + - +
+ + + + -
+ - + + -
+ - + -
+ ]
974 : :
975 : 720 : call xcdata_init(xcdata,dtset=dtset)
976 [ + + + - ]: 720 : non_magnetic_xc=(dtset%usepaw==1.and.mod(abs(dtset%usepawu),10)==4)
977 : : !If we use the XC Tran-Blaha 2009 (modified BJ) functional, update the c value
978 [ + - ]: 720 : if (dtset%xc_tb09_c>99._dp) then
979 : : call xc_tb09_update_c(dtset%intxc,dtset%ixc,mpi_enreg,dtset%natom,nfftf,ngfftf, &
980 : : & nhat,psps%usepaw,nhatgr,nhatgrdim,dtset%nspden,dtset%ntypat,n3xccc, &
981 : : & pawang,pawrad,pawrhoij,pawtab,dtset%pawxcdev,rhor,rprimd,psps%usepaw, &
982 : 720 : & xccc3d,dtset%xc_denpos,comm_atom=mpi_enreg%comm_atom,mpi_atmtab=mpi_enreg%my_atmtab)
983 : : end if
984 : :
985 : : call rhotoxc(bigexc,bigsxc,kxc,mpi_enreg,nfftf,ngfftf,&
986 : : & nhat,nhatdim,nhatgr,nhatgrdim,nkxc,nk3xc,non_magnetic_xc,n3xccc,option,rhor,&
987 : : & rprimd,usexcnhat,vxc,vxcavg,xccc3d,xcdata,&
988 : 720 : & taur=taur,vhartr=vhartr,vxctau=vxctau,xcctau3d=xcctau3d)
989 : :
990 : : !Compute local + Hxc potential, and subtract mean potential.
991 [ - + + - : 2160 : ABI_MALLOC(vtrial,(nfftf,dtset%nspden))
- + + - -
+ - + ]
992 [ + + ]: 1521 : do ispden=1,min(dtset%nspden,2)
993 [ + + ]: 12236468 : do ifft=1,nfftf
994 : 12235748 : vtrial(ifft,ispden)=vhartr(ifft)+vxc(ifft,ispden)+vpsp(ifft)
995 : : end do
996 : : end do
997 [ + + ]: 720 : if (dtset%nspden==4) then
998 [ + + ]: 60 : do ispden=3,4
999 [ + + ]: 234338 : do ifft=1,nfftf
1000 : 234318 : vtrial(ifft,ispden)=vxc(ifft,ispden)
1001 : : end do
1002 : : end do
1003 : : end if
1004 : :
1005 [ - + ]: 720 : ABI_FREE(vhartr)
1006 : :
1007 [ - + ]: 720 : if(dtset%prtvol==-level) call wrtout(std_out,' respfn: ground-state density and potential set up.')
1008 : :
1009 : : !PAW: compute Dij quantities (psp strengths)
1010 [ + + ]: 720 : if (psps%usepaw==1)then
1011 : 116 : cplex=1;ipert=0;option=1
1012 [ + - ]: 116 : nzlmopt=0;if (dtset%pawnzlm>0) nzlmopt=-1
1013 : :
1014 : : call pawdenpot(compch_sph,el_temp,gprimd,ipert,dtset%ixc,my_natom,natom,dtset%nspden,&
1015 : : & ntypat,dtset%nucdipmom,nzlmopt,option,paw_an,paw_an,paw_energies,paw_ij,pawang,&
1016 : : & dtset%pawprtvol,pawrad,pawrhoij,dtset%pawspnorb,pawtab,dtset%pawxcdev,&
1017 : : & dtset%spnorbscl,dtset%xclevel,dtset%xc_denpos,dtset%xc_taupos,xred,ucvol,psps%znuclpsp,dtset%spinaxis, &
1018 : 116 : & mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom)
1019 : :
1020 : 116 : call timab(561,1,tsec)
1021 : : call pawdij(cplex,dtset%enunit,gprimd,ipert,my_natom,natom,nfftf,nfftotf,&
1022 : : & dtset%nspden,ntypat,paw_an,paw_ij,pawang,pawfgrtab,dtset%pawprtvol,&
1023 : : & pawrad,pawrhoij,dtset%pawspnorb,pawtab,dtset%pawxcdev,k0,&
1024 : : & dtset%spnorbscl,ucvol,dtset%cellcharge(1),vtrial,vxc,xred,dtset%znucl,&
1025 : : & nucdipmom=dtset%nucdipmom,&
1026 : : & mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom,&
1027 : 116 : & spinaxis=dtset%spinaxis)
1028 : : call symdij(gprimd,indsym,ipert,my_natom,natom,dtset%nsym,ntypat,0,&
1029 : : & paw_ij,pawang,dtset%pawprtvol,pawtab,rprimd,dtset%symafm,symrec,&
1030 : 116 : & mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom)
1031 : 116 : call timab(561,2,tsec)
1032 : :
1033 : : end if
1034 : :
1035 : : !-----2. Frozen-wavefunctions and Ewald(q=0) parts of 2DTE
1036 : :
1037 [ + + + + ]: 720 : dyfr_nondiag=0;if (psps%usepaw==1.and.rfphon==1) dyfr_nondiag=1
1038 [ + + + + ]: 720 : dyfr_cplex=1;if (psps%usepaw==1.and.rfphon==1.and.(.not.qeq0)) dyfr_cplex=2
1039 [ + + + + ]: 720 : if (abs(dtset%rfomega)>tol10.or.dtset%tim1rev==0) dyfr_cplex=2
1040 [ - + + - : 3600 : ABI_MALLOC(dyew,(2,3,natom,3,natom))
+ - - + +
- + - + -
- + - + ]
1041 [ - + + - : 2160 : ABI_MALLOC(dyewq0,(3,3,natom))
+ - + - -
+ - + ]
1042 [ - + + - : 1440 : ABI_MALLOC(dyfrlo,(3,3,natom))
- + - + ]
1043 [ - + + - : 1440 : ABI_MALLOC(dyfrx2,(3,3,natom))
- + - + ]
1044 [ - + + - : 4320 : ABI_MALLOC(dyfrnl,(dyfr_cplex,3,3,natom,1+(natom-1)*dyfr_nondiag))
+ - - + +
- + - - +
+ - + - +
- - + -
+ ]
1045 [ - + + - : 2880 : ABI_MALLOC(dyfrwf,(dyfr_cplex,3,3,natom,1+(natom-1)*dyfr_nondiag))
- + + - -
+ + - - +
- + ]
1046 [ - + + - : 2880 : ABI_MALLOC(becfrnl,(3,natom,3*pawbec))
+ + + + +
- + - + +
- + - + ]
1047 [ + + + + : 2160 : ABI_MALLOC(piezofrnl,(6,3*pawpiezo))
+ - + - +
+ - + -
+ ]
1048 [ - + + - : 2880 : ABI_MALLOC(dyvdw,(2,3,natom,3,natom*usevdw))
+ + + - +
- + + - +
- + ]
1049 [ + + + + : 142294 : dyew(:,:,:,:,:)=zero
+ + + + +
+ ]
1050 [ + + + + : 20623 : dyewq0(:,:,:)=zero
+ + ]
1051 [ + + + + : 46077 : dyfrnl(:,:,:,:,:)=zero
+ + + + +
+ ]
1052 [ + + + + : 46077 : dyfrwf(:,:,:,:,:)=zero
+ + + + +
+ ]
1053 [ + + + + : 20623 : dyfrlo(:,:,:)=zero
+ + ]
1054 [ + + + + : 20623 : dyfrx2(:,:,:)=zero
+ + ]
1055 [ + + + + : 916 : if (usevdw==1) dyvdw(:,:,:,:,:)=zero
+ + + + +
+ + + ]
1056 [ + + + + : 2625 : if (pawbec==1) becfrnl(:,:,:)=zero
+ + + + ]
1057 [ + + + + : 1182 : if (pawpiezo==1) piezofrnl(:,:)=zero
+ + ]
1058 : :
1059 [ - + ]: 720 : ABI_MALLOC(eltcore,(6,6))
1060 [ + - - + : 2880 : ABI_MALLOC(elteew,(6+3*natom,6))
+ - + - +
- + - - +
- + ]
1061 [ - + ]: 720 : ABI_MALLOC(eltfrhar,(6,6))
1062 [ - + + - : 1440 : ABI_MALLOC(eltfrnl,(6+3*natom,6))
- + - + ]
1063 [ - + + - : 1440 : ABI_MALLOC(eltfrloc,(6+3*natom,6))
- + - + ]
1064 [ - + ]: 720 : ABI_MALLOC(eltfrkin,(6,6))
1065 [ - + + - : 1440 : ABI_MALLOC(eltfrxc,(6+3*natom,6))
- + - + ]
1066 [ - + + - : 2880 : ABI_MALLOC(eltvdw,(6+3*natom,6*usevdw))
+ + + + +
- + - + +
- + - + ]
1067 [ + + + + ]: 30960 : eltcore(:,:)=zero
1068 [ + + + + ]: 58518 : elteew(:,:)=zero
1069 [ + + + + ]: 58518 : eltfrnl(:,:)=zero
1070 [ + + + + ]: 58518 : eltfrloc(:,:)=zero
1071 [ + + + + ]: 30960 : eltfrkin(:,:)=zero
1072 [ + + + + ]: 30960 : eltfrhar(:,:)=zero
1073 [ + + + + ]: 58518 : eltfrxc(:,:)=zero
1074 [ + + + + : 918 : if (usevdw==1) eltvdw(:,:)=zero
+ + ]
1075 : :
1076 : : !Section common to all perturbations
1077 : : !Compute the nonlocal part of the elastic tensor and/or dynamical matrix
1078 [ + + + + : 720 : if (rfstrs/=0.or.rfphon==1.or.dtset%efmas>0.or.pawbec==1.or.pawpiezo==1)then
+ + ]
1079 : : call d2frnl(becfrnl,cg,dtfil,dtset,dyfrnl,dyfr_cplex,&
1080 : : & dyfr_nondiag,efmasdeg,efmasval,eigen0,eltfrnl,gsqcut,has_allddk,indsym,kg,&
1081 : : & dtset%mband_mem,dtset%mkmem,mgfftf,&
1082 : : & mpi_enreg,psps%mpsang,my_natom,natom,nfftf,ngfft,ngfftf,&
1083 : : & npwarr,occ,paw_ij,pawang,pawbec,pawfgrtab,pawpiezo,pawrad,&
1084 : : & pawrhoij,pawtab,ph1d,ph1df,piezofrnl,psps,rprimd,rfphon,&
1085 [ - + - - : 487 : & rfstrs,symrec,vtrial,vxc,xred,ylm,ylmgr)
- - - - -
+ - + - -
- - - - -
+ ]
1086 : : end if
1087 : :
1088 : : !No more need of these local derivatives
1089 [ + + + + : 720 : if (rfphon==1.and.psps%usepaw==1.and.(.not.use_nhat_gga)) then
+ + ]
1090 [ + + ]: 113 : do iatom=1,my_natom
1091 [ + - ]: 70 : if (allocated(pawfgrtab(iatom)%gylmgr2)) then
1092 : 70 : ABI_FREE(pawfgrtab(iatom)%gylmgr2)
1093 : : end if
1094 : 113 : pawfgrtab(iatom)%gylmgr2_allocated=0
1095 : : end do
1096 : : end if
1097 : :
1098 : : !Section for the atomic displacement/electric field perturbations
1099 [ + + ]: 720 : if (rfphon==1) then
1100 : :
1101 : : ! Compute the local of the dynamical matrix
1102 : : ! dyfrnl has not yet been symmetrized, but will be in the next routine
1103 : : call dfpt_dyfro(atindx1,dyfrnl,dyfrlo,dyfrwf,dyfrx2,dyfr_cplex,dyfr_nondiag,&
1104 : : & dtset,gmet,gprimd,gsqcut,indsym,mgfftf,mpi_enreg,psps%mqgrid_vl,&
1105 : : & natom,nattyp, nfftf,ngfftf,dtset%nspden,dtset%nsym,ntypat,&
1106 : : & psps%n1xccc,n3xccc,psps,pawtab,ph1df,psps%qgrid_vl,&
1107 : : & dtset%qptn,rhog,rprimd,symq,symrec,dtset%typat,ucvol,&
1108 : 450 : & psps%usepaw,psps%vlspl,vxc,psps%xcccrc,psps%xccc1d,xccc3d,xred)
1109 : :
1110 : : ! Compute Ewald (q=0) contribution
1111 : 450 : sumg0=0;qphon(:)=zero
1112 : : call dfpt_ewald(dyew,gmet,gsqcut,dtset%icutcoul,my_natom,natom,ngfftf,dtset%nkpt,qphon,dtset%rcut,rmet,&
1113 : : & rprimd,sumg0,dtset%typat,ucvol,dtset%vcutgeo,xred,psps%ziontypat,&
1114 : 450 : & mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom)
1115 : 450 : option=1
1116 : 450 : call q0dy3_calc(natom,dyewq0,dyew,option)
1117 : : ! Calculate the DFT-D2 vdw part of the dynamical matrix
1118 [ + + - + ]: 450 : if (usevdw==1.and.dtset%vdw_xc==5) then
1119 : : call vdw_dftd2(evdw,dtset%ixc,natom,ntypat,1,dtset%typat,rprimd,dtset%vdw_tol,&
1120 : 0 : & xred,psps%znuclpsp,dyn_vdw_dftd2=dyvdw,qphon=dtset%qptn)
1121 : : end if
1122 : : ! Calculate the DFT-D3/D3(BJ) vdw part of the dynamical matrix
1123 [ + + + - ]: 450 : if (usevdw==1.and.(dtset%vdw_xc==6.or.dtset%vdw_xc==7)) then
1124 : : call vdw_dftd3(evdw,dtset%ixc,natom,ntypat,1,dtset%typat,rprimd,&
1125 : : & dtset%vdw_xc,dtset%vdw_tol,dtset%vdw_tol_3bt,xred,psps%znuclpsp,&
1126 : 3 : & dyn_vdw_dftd3=dyvdw,qphon=dtset%qptn)
1127 : : end if
1128 : : !The frozen-wavefunction part of the dynamical matrix is now:
1129 : : ! d2frnl: non-local contribution
1130 : : ! dyfrlo: local contribution
1131 : : ! dyfrx2: 2nd order xc core correction contribution
1132 : : ! dyew : Ewald contribution
1133 : : ! dyvdw : vdw DFT-D contribution
1134 : : ! dyfrwf: all contributions
1135 : : ! In case of PAW, it misses a term coming from the perturbed overlap operator
1136 : : end if
1137 : :
1138 : : !Section for the strain perturbation
1139 [ + + ]: 720 : if(rfstrs/=0) then
1140 : :
1141 : : ABI_NVTX_START_RANGE(NVTX_DFPT_ELT)
1142 : : ! Verify that k-point set has full space-group symmetry; otherwise exit
1143 : 37 : timrev=1
1144 [ - + ]: 37 : if (symkchk(dtset%kptns,dtset%nkpt,dtset%nsym,symrec,timrev,msg) /= 0) then
1145 : 0 : ABI_ERROR(msg)
1146 : : end if
1147 : :
1148 : : ! Calculate the kinetic part of the elastic tensor
1149 : : call dfpt_eltfrkin(cg,eltfrkin,dtset%ecut,dtset%ecutsm,dtset%effmass_free,&
1150 : : & dtset%istwfk,kg,dtset%kptns,dtset%mband,dtset%mband_mem,dtset%mgfft,dtset%mkmem,mpi_enreg,&
1151 : : & dtset%mpw,dtset%nband,dtset%nkpt,ngfft,npwarr,&
1152 : 37 : & dtset%nspinor,dtset%nsppol,occ,rprimd,dtset%wtk)
1153 : :
1154 : : ! Calculate the hartree part of the elastic tensor
1155 : 37 : call dfpt_eltfrhar(eltfrhar,rprimd,gsqcut,mpi_enreg,nfftf,ngfftf,rhog)
1156 : :
1157 : : ! Calculate the xc part of the elastic tensor
1158 : : call dfpt_eltfrxc(atindx,dtset,eltfrxc,bigexc,gsqcut,kxc,mpi_enreg,mgfftf,&
1159 : : & nattyp,nfftf,ngfftf,ngfftf,nhat,nkxc,n3xccc,pawtab,ph1df,psps,rhor,rprimd,&
1160 : 37 : & usexcnhat,vxc,xccc3d,xred)
1161 : :
1162 : : ! Calculate the local potential part of the elastic tensor
1163 : : call dfpt_eltfrloc(atindx,eltfrloc,gmet,gprimd,gsqcut,mgfftf,mpi_enreg,psps%mqgrid_vl,&
1164 : 37 : & natom,nattyp,nfftf,ngfftf,ntypat,ph1df,psps%qgrid_vl,rhog,psps%vlspl)
1165 : :
1166 : : ! Calculate the Ewald part of the elastic tensor
1167 : : call elt_ewald(elteew,gmet,gprimd,my_natom,natom,ntypat,rmet,rprimd,&
1168 : : & dtset%typat,ucvol,xred,psps%ziontypat,&
1169 : 37 : & mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom)
1170 : :
1171 : : ! Calculate the DFT-D2 vdw part of the elastic tensor
1172 [ + + - + ]: 37 : if (usevdw==1.and.dtset%vdw_xc==5) then
1173 [ # # ]: 0 : option=1; if (rfphon==1) option=0
1174 : : call vdw_dftd2(evdw,dtset%ixc,natom,ntypat,option,dtset%typat,rprimd,dtset%vdw_tol,&
1175 : 0 : & xred,psps%znuclpsp,elt_vdw_dftd2=eltvdw)
1176 : : end if
1177 : : ! Calculate the DFT-D3/D3(BJ) vdw part of the elastic tensor
1178 [ + + + - ]: 37 : if (usevdw==1.and.(dtset%vdw_xc==6.or.dtset%vdw_xc==7)) then
1179 [ + - ]: 1 : option=1; if (rfphon==1) option=0
1180 : : call vdw_dftd3(evdw,dtset%ixc,natom,ntypat,option,dtset%typat,rprimd,&
1181 : : & dtset%vdw_xc,dtset%vdw_tol,dtset%vdw_tol_3bt,xred,psps%znuclpsp,&
1182 : 1 : & elt_vdw_dftd3=eltvdw)
1183 : : end if
1184 : : ! Calculate the psp core energy part of elastic tensor (trivial)
1185 [ + + + + ]: 481 : eltcore(1:3,1:3)=ecore/ucvol
1186 : :
1187 : : !The frozen-wavefunction part of the elastic tensor is now:
1188 : : ! eltfrnl: non-local contribution
1189 : : ! eltfrloc: local contribution
1190 : : ! eltfrkin: kinetic contribution
1191 : : ! eltfrhar: Hartree contribution
1192 : : ! eltfrx: XC contribution
1193 : : ! eltcore: psps core contribution
1194 : : ! elteew: Ewald contribution
1195 : : ! eltvdw: vdw DFT-D contribution
1196 : : ! In case of PAW, it misses a term coming from the perturbed overlap operator
1197 : : ABI_NVTX_END_RANGE()
1198 : : end if
1199 : :
1200 [ - + ]: 720 : ABI_FREE(vpsp)
1201 [ - + ]: 720 : ABI_FREE(xccc3d)
1202 [ + - ]: 720 : if(allocated(xcctau3d)) then
1203 : 720 : ABI_FREE(xcctau3d)
1204 : : end if
1205 : :
1206 [ - + ]: 720 : if(dtset%prtvol==-level) call wrtout(std_out,' respfn: frozen wavef. and Ewald(q=0) part of 2DTE done.')
1207 : :
1208 : :
1209 : 720 : call timab(136,2,tsec)
1210 : 720 : call pstat_proc%print(_PSTAT_ARGS_)
1211 : :
1212 : : !-----3. Initialisation of 1st response, taking into account the q vector.
1213 : :
1214 : 720 : call timab(137,1,tsec)
1215 : :
1216 : 720 : write(msg,'(3a)')ch10,' ==> initialize data related to q vector <== ',ch10
1217 [ + + ]: 2160 : call wrtout([std_out, ab_out] ,msg)
1218 : :
1219 [ + + ]: 2880 : qphon(:)=dtset%qptn(:)
1220 : 720 : sumg0=1
1221 : :
1222 : : !Treat the case of q=0 or q too close to 0
1223 : 720 : qzero=0
1224 [ + + ]: 720 : if(qeq0)then
1225 : 505 : qphon(:)=zero
1226 : : write(msg,'(3a)')&
1227 : 505 : & ' respfn : the norm of the phonon wavelength (as input) was small (<1.d-7).',ch10,&
1228 : 1010 : & ' q has been set exactly to (0 0 0)'
1229 : 505 : call wrtout(std_out,msg)
1230 : 505 : sumg0=0
1231 : 505 : qzero=1
1232 : : else
1233 [ + - - + ]: 215 : if(rfelfd/=0 .or. rfstrs/=0 .or. rfddk /= 0 .or. rf2_dkdk /= 0 .or. rf2_dkde /= 0) then
1234 : : ! Temporarily, ...
1235 : 0 : write(msg, '(a,a,a,3es16.6,a,a,5(a,i2),a,a,a)' )ch10,&
1236 : 0 : & 'The treatment of non-zero wavevector q is restricted to phonons.',&
1237 : 0 : & 'However, the input normalized qpt is',qphon(:),',',ch10,&
1238 : 0 : & 'while rfelfd=',rfelfd,', rfddk=',rfddk,', rf2_dkdk=',rf2_dkdk,', rf2_dkde=',rf2_dkde,&
1239 : 0 : & ' and rfstrs=',rfstrs,'.',ch10,&
1240 : 0 : & 'Action: change qpt, or rfelfd, or rfstrs in the input file.'
1241 : 0 : ABI_ERROR(msg)
1242 : : end if
1243 [ + + ]: 215 : if(chneut/=0)then
1244 : 165 : write(msg,'(2a)')ch10,' chneut/=0 not allowed with q/=0 => chneut reset to 0 locally.'
1245 : 165 : ABI_WARNING(msg)
1246 : 165 : chneut=0
1247 : : end if
1248 [ + + ]: 215 : if(asr/=0)then
1249 : 162 : write(msg,'(2a)')ch10,' asr/=0 not allowed with q/=0 => asr reset to 0 locally.'
1250 : 162 : ABI_WARNING(msg)
1251 : 162 : asr=0
1252 : : end if
1253 : :
1254 : : end if
1255 : :
1256 : : !Determine the symmetrical perturbations
1257 [ - + + - : 2160 : ABI_MALLOC(pertsy,(3,mpert))
+ - + - -
+ - + ]
1258 : 720 : call irreducible_set_pert(indsym,mpert,natom,dtset%nsym,pertsy,rfdir,rfpert,symq,symrec,dtset%symrel)
1259 : :
1260 : 720 : write(msg,'(a)') ' The list of irreducible perturbations for this q vector is:'
1261 [ + + ]: 2160 : call wrtout([std_out, ab_out] ,msg)
1262 : 720 : ii=1
1263 [ + + ]: 7461 : do ipert=1,mpert
1264 [ + + ]: 27684 : do idir=1,3
1265 [ + + + + ]: 26964 : if(rfpert(ipert)==1.and.rfdir(idir)==1)then
1266 [ + + ]: 3154 : if( pertsy(idir,ipert)==1 )then
1267 : 2193 : write(msg, '(i5,a,i2,a,i4)' )ii,') idir=',idir,' ipert=',ipert
1268 [ + + ]: 6579 : call wrtout([std_out, ab_out] ,msg)
1269 : 2193 : ii=ii+1
1270 : : end if
1271 : : end if
1272 : : end do
1273 : : end do
1274 : :
1275 : : !test if the user left default rfdir 0 0 0
1276 [ - + - - : 720 : if (ii==1 .and. rf2_dkdk==0 .and. rf2_dkde==0) then
- - ]
1277 : 0 : write(msg,'(5a)')ch10,&
1278 : 0 : & ' WARNING: no perturbations to be done at this q-point.',ch10,&
1279 : 0 : & ' You may have forgotten to set the rfdir or rfatpol variables. Continuing normally.',ch10
1280 : 0 : call wrtout(ab_out,msg)
1281 : 0 : ABI_WARNING(msg)
1282 : : end if
1283 : :
1284 [ + + + + : 720 : if (dtset%prepanl==1.and.(rf2_dkdk/=0 .or. rf2_dkde/=0)) then
+ + ]
1285 [ + - - + : 98 : ABI_MALLOC(rfpert_nl,(3,natom+2,3,natom+2,3,natom+2))
+ - + - -
+ + - + -
- + + - +
- + - - +
- + ]
1286 [ + + + + : 35182 : rfpert_nl = 0
+ + + + +
+ + + ]
1287 [ + + + + : 560 : rfpert_nl(:,natom+2,:,natom+2,:,natom+2) = 1
+ + ]
1288 [ + + + + : 1190 : rfpert_nl(:,1:natom,:,natom+2,:,natom+2) = 1
+ + + + ]
1289 [ + + + + : 1148 : rfpert_nl(:,natom+2,:,1:natom,:,natom+2) = 1
+ + + + ]
1290 [ + + + + : 1134 : rfpert_nl(:,natom+2,:,natom+2,:,1:natom) = 1
+ + + + ]
1291 : 14 : call sytens(indsym,natom+2,natom,dtset%nsym,rfpert_nl,symrec,dtset%symrel)
1292 : 14 : write(msg, '(a,a,a,a,a)' ) ch10, &
1293 : 14 : & ' The list of irreducible elements of the Raman and non-linear',&
1294 : 28 : & ch10,' optical susceptibility tensors is:',ch10
1295 : 14 : call wrtout(std_out,msg)
1296 : :
1297 : 14 : write(msg,'(12x,a)')'i1pert i1dir i2pert i2dir i3pert i3dir'
1298 : 14 : call wrtout(std_out,msg)
1299 : 14 : n1 = 0
1300 : 14 : rf2_dirs_from_rfpert_nl(:,:) = 0
1301 [ + + ]: 70 : do i1pert = 1, natom + 2
1302 [ + + ]: 238 : do i1dir = 1, 3
1303 [ + + ]: 896 : do i2pert = 1, natom + 2
1304 [ + + ]: 2856 : do i2dir = 1, 3
1305 [ + + ]: 10752 : do i3pert = 1, natom + 2
1306 [ + + ]: 34272 : do i3dir = 1,3
1307 [ + + ]: 32256 : if (rfpert_nl(i1dir,i1pert,i2dir,i2pert,i3dir,i3pert)==1) then
1308 : 582 : n1 = n1 + 1
1309 : 582 : write(msg,'(2x,i4,a,6(5x,i3))') n1,')', i1pert,i1dir,i2pert,i2dir,i3pert,i3dir
1310 : 582 : call wrtout(std_out,msg)
1311 [ + + ]: 582 : if (i2pert==natom+2) then
1312 [ + - ]: 398 : if (i3pert==natom+2) then
1313 : 398 : rf2_dirs_from_rfpert_nl(i3dir,i2dir) = 1
1314 [ # # ]: 0 : else if (i1pert==natom+2) then
1315 : 0 : rf2_dirs_from_rfpert_nl(i1dir,i2dir) = 1
1316 : : end if
1317 : : end if
1318 : : end if
1319 : : end do
1320 : : end do
1321 : : end do
1322 : : end do
1323 : : end do
1324 : : end do
1325 : 14 : write(msg,'(a,a)') ch10,ch10
1326 : 14 : call wrtout(std_out,msg)
1327 : :
1328 : 14 : call wrtout(std_out,'rf2_dirs_from_rfpert_nl :')
1329 [ + + ]: 56 : do i1dir = 1, 3
1330 [ + + ]: 888 : do i2dir = 1, 3
1331 : 126 : write(msg,'(3(a,i1))') ' ',i1dir,' ',i2dir,' : ',rf2_dirs_from_rfpert_nl(i1dir,i2dir)
1332 : 168 : call wrtout(std_out,msg)
1333 : : end do
1334 : : end do
1335 : : end if
1336 : :
1337 : : !For longwave calculation:
1338 : : !Get symmetries in cartesian coordinates
1339 [ - + + - : 2160 : ABI_MALLOC(symrel_cart, (3, 3, dtset%nsym))
+ - + - -
+ - + ]
1340 [ + + ]: 17805 : do isym =1,dtset%nsym
1341 : 17085 : call symredcart(rprimd, gprimd, symrel_cart(:,:,isym), dtset%symrel(:,:,isym))
1342 : : ! purify operations in cartesian coordinates.
1343 [ + + + + : 222825 : where (abs(symrel_cart(:,:,isym)) < tol14)
+ + ]
1344 : : symrel_cart(:,:,isym) = zero
1345 : : end where
1346 : : end do
1347 : :
1348 [ + + ]: 720 : if (dtset%prepalw/=0) then
1349 [ + - - + : 112 : ABI_MALLOC(rfpert_lw,(3,natom+8,3,natom+8,3,natom+8))
+ - + - -
+ + - + -
- + + - +
- + - - +
- + ]
1350 [ + + + + : 782952 : rfpert_lw=0
+ + + + +
+ + + ]
1351 [ + + ]: 16 : if (dtset%prepalw==1) then
1352 [ + + + + : 948 : rfpert_lw(:,1:natom+2,:,1:natom,:,natom+8)=1
+ + + + +
+ ]
1353 [ + + + + : 948 : rfpert_lw(:,1:natom+2,:,natom+3:natom+4,:,natom+8)=1
+ + + + +
+ ]
1354 [ + + ]: 13 : else if (dtset%prepalw==2) then
1355 [ + + + + : 1101 : rfpert_lw(:,natom+2,:,1:natom,:,natom+8)=1
+ + + + ]
1356 [ - + ]: 1 : else if (dtset%prepalw==3) then
1357 [ # # # # : 0 : rfpert_lw(:,1:natom+2,:,1:natom,:,natom+8)=1
# # # # #
# ]
1358 [ + - ]: 1 : else if (dtset%prepalw==4) then
1359 [ + + + + : 40 : rfpert_lw(:,natom+2,:,natom+2,:,natom+8)=1
+ + ]
1360 : : end if
1361 : :
1362 : : ! call sylwtens(indsym,natom+8,natom,dtset%nsym,rfpert_lw,symrec,dtset%symrel,symrel_cart)
1363 : 16 : call sylwtens(indsym,natom+8,natom,dtset%nsym,rfpert_lw,symrec,dtset%symrel)
1364 : :
1365 : 16 : write(msg,'(7a)') ch10, ' The following reducible perturbations will also be ', ch10, &
1366 : 16 : & ' explicitly calculated for a correct subsequent ', ch10, &
1367 : 32 : & ' execution of the longwave driver:', ch10
1368 : 16 : call wrtout(ab_out,msg,'COLL')
1369 : 16 : call wrtout(std_out,msg,'COLL')
1370 [ + + ]: 186 : do i3pert = 1,natom+8
1371 [ + + ]: 696 : do i3dir = 1, 3
1372 [ + + ]: 6254 : do i2pert = 1, natom+8
1373 [ + + ]: 22806 : do i2dir = 1,3
1374 [ + + ]: 212286 : do i1pert = 1,natom+8
1375 [ + + ]: 776682 : do i1dir = 1, 3
1376 [ + + ]: 759960 : if (rfpert_lw(i1dir,i1pert,i2dir,i2pert,i3dir,i3pert)==1) then
1377 [ + + ]: 930 : if (pertsy(i1dir,i1pert)==-1) then
1378 : 12 : pertsy(i1dir,i1pert)=1
1379 : 12 : write(msg,'(a,i2,a,i4)' )' idir=',i1dir,' ipert=',i1pert
1380 : 12 : call wrtout(ab_out,msg,'COLL')
1381 : 12 : call wrtout(std_out,msg,'COLL')
1382 : : end if
1383 [ + + ]: 930 : if (pertsy(i2dir,i2pert)==-1) then
1384 : 16 : pertsy(i2dir,i2pert)=1
1385 : 16 : write(msg,'(a,i2,a,i4)' )' idir=',i2dir,' ipert=',i2pert
1386 : 16 : call wrtout(ab_out,msg,'COLL')
1387 : 16 : call wrtout(std_out,msg,'COLL')
1388 : : end if
1389 : : end if
1390 : : end do
1391 : : end do
1392 : : end do
1393 : : end do
1394 : : end do
1395 : : end do
1396 : 16 : write(msg,'(a,a)') ch10,ch10
1397 : 16 : call wrtout(std_out,msg,'COLL')
1398 [ - + ]: 16 : ABI_FREE(rfpert_lw)
1399 : : end if
1400 : :
1401 : : !Contribution to the dynamical matrix from ion-ion energy
1402 [ + + ]: 720 : if(rfphon==1)then
1403 : 450 : sumg0_save= sumg0
1404 [ - + ]: 450 : if (dtset%icutcoul==55) sumg0= 0
1405 : : call dfpt_ewald(dyew,gmet,gsqcut,dtset%icutcoul,my_natom,natom,ngfftf,dtset%nkpt,qphon,dtset%rcut,rmet,&
1406 : : & rprimd,sumg0,dtset%typat,ucvol,dtset%vcutgeo,xred,psps%ziontypat, &
1407 : 450 : & mpi_atmtab=mpi_enreg%my_atmtab,comm_atom=mpi_enreg%comm_atom)
1408 : 450 : sumg0= sumg0_save
1409 : 450 : call q0dy3_apply(natom,dyewq0,dyew)
1410 : : end if
1411 : :
1412 : : !1-order contribution of the xc core correction to the dynamical matrix
1413 [ - + + - : 3600 : ABI_MALLOC(dyfrx1,(2,3,natom,3,natom))
+ - - + +
- + - + -
- + - + ]
1414 [ + + + + : 142294 : dyfrx1(:,:,:,:,:)=zero
+ + + + +
+ ]
1415 [ + + + + ]: 720 : if(rfphon==1.and.psps%n1xccc/=0)then
1416 : : ABI_NVTX_START_RANGE(NVTX_DFPT_DYXC)
1417 [ - + + - : 1435 : ABI_MALLOC(blkflgfrx1,(3,natom,3,natom))
+ - - + +
- + - + -
- + - + ]
1418 : : !FR non-collinear magnetism
1419 [ + + ]: 287 : if (dtset%nspden==4) then
1420 : : call dfpt_dyxc1(atindx,blkflgfrx1,dyfrx1,gmet,gsqcut,dtset%ixc,kxc,mgfftf,mpert,mpi_enreg,&
1421 : : & psps%mqgrid_vl,natom,nfftf,ngfftf,nkxc,non_magnetic_xc,dtset%nspden,&
1422 : : & ntypat,psps%n1xccc,psps,pawtab,ph1df,psps%qgrid_vl,qphon,&
1423 : 6 : & rfdir,rfpert,rprimd,timrev,dtset%typat,ucvol,psps%usepaw,psps%xcccrc,psps%xccc1d,xred,rhor=rhor,vxc=vxc,ixcrot=dtset%ixcrot)
1424 : : else
1425 : : call dfpt_dyxc1(atindx,blkflgfrx1,dyfrx1,gmet,gsqcut,dtset%ixc,kxc,mgfftf,mpert,mpi_enreg,&
1426 : : & psps%mqgrid_vl,natom,nfftf,ngfftf,nkxc,non_magnetic_xc,dtset%nspden,&
1427 : : & ntypat,psps%n1xccc,psps,pawtab,ph1df,psps%qgrid_vl,qphon,&
1428 : 281 : & rfdir,rfpert,rprimd,timrev,dtset%typat,ucvol,psps%usepaw,psps%xcccrc,psps%xccc1d,xred)
1429 : : end if
1430 : : ABI_NVTX_END_RANGE()
1431 : : end if
1432 : :
1433 : : !Deallocate the arrays that were needed only for the frozen wavefunction part
1434 [ - + ]: 720 : ABI_FREE(ph1d)
1435 [ - + ]: 720 : ABI_FREE(ph1df)
1436 [ - + ]: 720 : ABI_FREE(cg)
1437 [ - + ]: 720 : ABI_FREE(kg)
1438 [ - + ]: 720 : ABI_FREE(npwarr)
1439 : 720 : if(xmpi_paral==1) then
1440 [ - + ]: 720 : ABI_FREE(mpi_enreg%proc_distrb)
1441 : : end if
1442 : :
1443 [ - + + - : 3600 : ABI_MALLOC(blkflg,(3,mpert,3,mpert))
+ - - + +
- + - + -
- + - + ]
1444 [ - + + - : 3600 : ABI_MALLOC(d2eig0,(2,3,mpert,3,mpert))
+ - - + +
- + - + -
- + - + ]
1445 [ - + + - : 2160 : ABI_MALLOC(d2k0,(2,3,mpert,3,mpert))
- + + - -
+ - + ]
1446 [ - + + - : 2160 : ABI_MALLOC(d2lo,(2,3,mpert,3,mpert))
- + + - -
+ - + ]
1447 [ - + + - : 2160 : ABI_MALLOC(d2loc0,(2,3,mpert,3,mpert))
- + + - -
+ - + ]
1448 [ - + + - : 2160 : ABI_MALLOC(d2nfr,(2,3,mpert,3,mpert))
- + + - -
+ - + ]
1449 [ - + + - : 2160 : ABI_MALLOC(d2nl,(2,3,mpert,3,mpert))
- + + - -
+ - + ]
1450 [ - + + - : 2160 : ABI_MALLOC(d2nl0,(2,3,mpert,3,mpert))
- + + - -
+ - + ]
1451 [ - + + - : 2160 : ABI_MALLOC(d2nl1,(2,3,mpert,3,mpert))
- + + - -
+ - + ]
1452 [ - + + - : 2160 : ABI_MALLOC(d2vn,(2,3,mpert,3,mpert))
- + + - -
+ - + ]
1453 [ - + + - : 2880 : ABI_MALLOC(d2ovl,(2,3,mpert,3,mpert*psps%usepaw))
+ + + - +
- + + - +
- + ]
1454 [ + + + + : 820032 : blkflg(:,:,:,:)=0
+ + + + ]
1455 [ + + + + : 4016388 : d2eig0(:,:,:,:,:)=zero ; d2k0(:,:,:,:,:)=zero
+ + + + +
+ + + + +
+ + + + +
+ ]
1456 [ + + + + : 4016388 : d2lo(:,:,:,:,:)=zero ; d2loc0(:,:,:,:,:)=zero
+ + + + +
+ + + + +
+ + + + +
+ ]
1457 [ + + + + : 4016388 : d2nfr(:,:,:,:,:)=zero ; d2nl(:,:,:,:,:)=zero
+ + + + +
+ + + + +
+ + + + +
+ ]
1458 [ + + + + : 4016388 : d2nl0(:,:,:,:,:)=zero ; d2nl1(:,:,:,:,:)=zero
+ + + + +
+ + + + +
+ + + + +
+ ]
1459 [ + + + + : 2008554 : d2vn(:,:,:,:,:)=zero
+ + + + +
+ ]
1460 [ + + + + : 343170 : if (psps%usepaw==1) d2ovl(:,:,:,:,:)=zero
+ + + + +
+ + + ]
1461 : :
1462 : 720 : prtbbb=dtset%prtbbb
1463 [ - + + - : 3600 : ABI_MALLOC(d2bbb,(2,3,3,mpert,dtset%mband,dtset%mband*prtbbb))
- + + - +
+ + - + -
+ + - + -
+ ]
1464 [ - + + - : 2880 : ABI_MALLOC(d2cart_bbb,(2,3,3,mpert,dtset%mband,dtset%mband*prtbbb))
- + + - +
+ + - - +
- + ]
1465 [ + + ]: 720 : if(prtbbb==1)then
1466 [ + + + + : 71716 : d2cart_bbb(:,:,:,:,:,:)=zero
+ + + + +
+ + + ]
1467 [ + + + + : 71716 : d2bbb(:,:,:,:,:,:)=zero
+ + + + +
+ + + ]
1468 : : end if
1469 : :
1470 : 720 : dim_eig2nkq = 0
1471 [ + + ]: 720 : if(dtset%ieig2rf /= 0) dim_eig2nkq = 1
1472 [ - + + - : 5760 : ABI_MALLOC(eig2nkq,(2,dtset%mband*dtset%nsppol,dtset%nkpt,3,natom,3,natom*dim_eig2nkq))
- + + - +
- - + + -
+ - + + +
- + - + +
- + - + ]
1473 : 720 : dim_eigbrd=0
1474 [ + + + + ]: 720 : if(dtset%ieig2rf /= 0 .and. dtset%smdelta>0 ) dim_eigbrd = 1
1475 [ - + + - : 4320 : ABI_MALLOC(eigbrd,(2,dtset%mband*dtset%nsppol,dtset%nkpt,3,natom,3,natom*dim_eigbrd))
- + + - -
+ + - + +
+ - + - +
+ - + -
+ ]
1476 : :
1477 : 720 : call timab(137,2,tsec)
1478 : 720 : call pstat_proc%print(_PSTAT_ARGS_)
1479 : :
1480 : :
1481 : : !Check whether exiting was required by the user.
1482 : : !If found then do not start minimization steps
1483 : : !At this first call to exit_check, initialize cpus
1484 : 720 : cpus=dtset%cpus
1485 [ - + ]: 720 : if(abs(cpus)>1.0d-5)cpus=cpus+cpui
1486 [ + - ]: 720 : openexit=1; if(dtset%chkexit==0) openexit=0
1487 : 720 : call exit_check(cpus,dtfil%filnam_ds(1),iexit,ab_out,mpi_enreg%comm_cell,openexit)
1488 : :
1489 : : !TEMPORARY: for testing purpose only
1490 : : ! if (rfstrs/=0.and.dtset%usepaw==1) iexit=1
1491 : :
1492 [ + - ]: 720 : if (iexit==0) then
1493 : : ! #######################################################################
1494 [ + - + + ]: 58320 : write(msg,'(a,80a)')ch10,('=',mu=1,80)
1495 [ + + ]: 2160 : call wrtout([std_out, ab_out], msg)
1496 : :
1497 : 720 : ddkfil(:)=0
1498 : :
1499 : : ! MGNAG: WHY THIS? all these variables are declared as optional pointers in dfpt_looppert!
1500 : : ! but they are allocated here so why using pointers! Moreover OPTIONAL arguments MUST
1501 : : ! be passed by keyword for better clarity and robustness!
1502 : : ! People should learn how to program Fort90 before being allowed to change the code!
1503 : : ! v5[26] crashes in dfpt_looppert
1504 : : ! The best solution would be using a datatype to gather the results!
1505 [ - + + - : 1440 : ABI_MALLOC(clflg,(3,mpert))
- + - + ]
1506 [ + + ]: 720 : if(dtset%ieig2rf > 0) then
1507 [ - + + - : 252 : ABI_MALLOC(eigen0_pert,(dtset%mband*dtset%nkpt*dtset%nsppol))
+ - + - -
+ - + -
+ ]
1508 [ - + + - : 168 : ABI_MALLOC(eigenq_pert,(dtset%mband*dtset%nkpt*dtset%nsppol))
- + - + -
+ ]
1509 [ - + + - : 168 : ABI_MALLOC(occ_rbz_pert,(dtset%mband*dtset%nkpt*dtset%nsppol))
- + - + -
+ ]
1510 : : end if
1511 [ + + ]: 720 : if(dtset%efmas > 0) then
1512 [ - + + - : 51 : ABI_MALLOC(eigen0_pert,(dtset%mband*dtset%nkpt*dtset%nsppol))
+ - + - -
+ - + -
+ ]
1513 : : end if
1514 : : ! Note that kg, cg, eigen0, mpw and npwarr are NOT passed to dfpt_looppert :
1515 : : ! they will be reinitialized for each perturbation, with an eventually
1516 : : ! reduced set of k point, thanks to the use of symmetry operations.
1517 : : call dfpt_looppert(atindx,blkflg,codvsn,cpus,dim_eigbrd,dim_eig2nkq,doccde,&
1518 : : & ddkfil,dtfil,dtset,dyew,dyfrlo,dyfrnl,dyfrx1,dyfrx2,dyvdw,dyfr_cplex,dyfr_nondiag,&
1519 : : & d2bbb,d2lo,d2nl,d2ovl,efmasdeg,efmasval,eigbrd,eig2nkq,&
1520 : : & eltcore,elteew,eltfrhar,eltfrkin,eltfrloc,eltfrnl,eltfrxc,eltvdw,&
1521 : : & etotal,fermie,iexit,indsym,kxc,&
1522 : : & dtset%mkmem,mkqmem,mk1mem,mpert,mpi_enreg,my_natom,nattyp,&
1523 : : & nfftf,nhat,dtset%nkpt,nkxc,dtset%nspden,dtset%nsym,occ,&
1524 : : & paw_an,paw_ij,pawang,pawfgr,pawfgrtab,pawrad,pawrhoij,pawtab,&
1525 : : & pertsy,prtbbb,psps,rfpert,rf2_dirs_from_rfpert_nl,rhog,rhor,symq,symrec,timrev,&
1526 : : & usecprj,usevdw,usevxctau,vtrial,vxc,vxcavg,vxctau,xred,clflg,occ_rbz_pert,eigen0_pert,eigenq_pert,&
1527 : 720 : & eigen1_pert,nkpt_rbz,eigenq_fine,hdr_fine,hdr0)
1528 : :
1529 : : ! #####################################################################
1530 : : end if
1531 : :
1532 : 720 : call timab(138,1,tsec)
1533 : :
1534 [ + + ]: 58320 : write(msg, '(80a,a,a,a,a)' ) ('=',mu=1,80),ch10,ch10,&
1535 [ + - ]: 59040 : ' ---- first-order wavefunction calculations are completed ----',ch10
1536 [ + + ]: 2160 : call wrtout([std_out, ab_out], msg)
1537 : :
1538 [ - + ]: 720 : ABI_FREE(vxc)
1539 [ - + ]: 720 : ABI_FREE(vxctau)
1540 : :
1541 : : ! Cleaning GEMM nonlop data
1542 [ - + ]: 720 : if(gemm_nonlop_use_gemm) then
1543 : 0 : call destroy_gemm_nonlop(dtset%gpu_option)
1544 : 0 : gemm_nonlop_use_gemm = .false.
1545 : : end if
1546 : :
1547 [ + + + + : 720 : if (dtset%prepanl==1.and.(rf2_dkdk/=0 .or. rf2_dkde/=0)) then
+ + ]
1548 [ - + ]: 14 : ABI_FREE(rfpert_nl)
1549 : : end if
1550 : :
1551 : : !Output of the localization tensor
1552 [ + + + + : 720 : if ( rfpert(natom+1) /= 0 .and. (me == 0) .and. dtset%occopt<=2) then
+ + ]
1553 : 158 : call wrtloctens(blkflg,d2bbb,d2nl,dtset%mband,mpert,natom,dtset%prtbbb,rprimd,psps%usepaw)
1554 : : end if
1555 : :
1556 : : !The perturbation natom+1 was only an auxiliary perturbation,
1557 : : !needed to construct the electric field response, so its flag is now set to 0.
1558 : : !rfpert(natom+1)=0
1559 : :
1560 : : !Were 2DTE computed ?
1561 [ + + + + : 720 : if(rfphon==0 .and. (rf2_dkdk/=0 .or. rf2_dkde/=0 .or. rfddk/=0 .or. rfelfd==2) .and. rfstrs==0 .and. rfmagn==0)then
+ + + + +
+ + - ]
1562 : :
1563 : 231 : write(msg,'(a,a)' )ch10,' respfn : d/dk was computed, but no 2DTE, so no DDB output.'
1564 [ + + ]: 693 : call wrtout([std_out, ab_out], msg)
1565 : :
1566 : : ! If 2DTE were computed, only one processor must output them and compute
1567 : : ! frequencies.
1568 [ + + ]: 489 : else if(me==0)then
1569 : :
1570 : 418 : write(msg,'(a,a)' )ch10,' ==> Compute Derivative Database <== '
1571 [ + + ]: 1254 : call wrtout([std_out, ab_out], msg)
1572 : :
1573 : : ! In the RESPFN code, dfpt_nstdy and stady3 were called here
1574 [ + + + + : 1140800 : d2nfr(:,:,:,:,:)=d2lo(:,:,:,:,:)+d2nl(:,:,:,:,:)
+ + + + +
+ ]
1575 [ + + + + : 89800 : if (psps%usepaw==1) d2nfr(:,:,:,:,:)=d2nfr(:,:,:,:,:)+d2ovl(:,:,:,:,:)
+ + + + +
+ + + ]
1576 : :
1577 : 418 : zero_by_symm=1
1578 [ + + ]: 418 : if(dtset%rfmeth<0)zero_by_symm=0
1579 : :
1580 : : ! In case of bbb decomposition
1581 [ + + ]: 418 : if(prtbbb==1)then
1582 [ - + + - : 6 : ABI_MALLOC(blkflg1,(3,mpert,3,mpert))
- + + - -
+ - + ]
1583 [ - + + - : 6 : ABI_MALLOC(blkflg2,(3,mpert,3,mpert))
- + + - -
+ - + ]
1584 [ + + + + : 2018 : blkflg2(:,:,:,:) = blkflg(:,:,:,:)
+ + + + ]
1585 [ + + ]: 20 : do ipert = 1, mpert
1586 [ + + ]: 182 : do ipert2 = 1, mpert
1587 [ + + + + : 180 : if ((ipert /= natom + 2).and.(ipert>natom).and.(ipert2/=natom+2)) then
+ + ]
1588 [ + + + + ]: 1248 : blkflg2(:,ipert2,:,ipert) = 0
1589 : : end if
1590 : : end do
1591 : : end do
1592 [ - + + - : 6 : ABI_MALLOC(d2tmp,(2,3,mpert,3,mpert))
- + + - -
+ - + ]
1593 [ + + ]: 18 : do iband = 1,dtset%mband
1594 [ + + + + : 39472 : d2tmp(:,:,:,:,:)=zero
+ + + + +
+ ]
1595 [ + + + + : 16144 : blkflg1(:,:,:,:) = blkflg2(:,:,:,:)
+ + + + ]
1596 [ + + + + : 4480 : d2tmp(:,:,natom+2,:,:) = d2bbb(:,:,:,:,iband,iband)
+ + + + ]
1597 : : call d2sym3(blkflg1,d2tmp,indsym,mpert,natom,dtset%nsym,qphon,symq,&
1598 : 16 : & symrec,dtset%symrel,timrev,zero_by_symm)
1599 [ + + + + : 4482 : d2bbb(:,:,:,:,iband,iband) = d2tmp(:,:,natom+2,:,:)
+ + + + ]
1600 : : end do
1601 [ - + ]: 2 : ABI_FREE(blkflg1)
1602 [ - + ]: 2 : ABI_FREE(blkflg2)
1603 [ - + ]: 2 : ABI_FREE(d2tmp)
1604 : : end if
1605 : :
1606 : : ! Complete the d2nfr matrix by symmetrization of the existing elements
1607 : : !write(std_out,*)"blkflg before d2sym3: ", blkflg
1608 : : call d2sym3(blkflg,d2nfr,indsym,mpert,natom,dtset%nsym,qphon,symq,symrec,&
1609 : 418 : & dtset%symrel,timrev,zero_by_symm,eta=dtset%rfeta)
1610 : : !write(std_out,*)"blkflg after d2sym3: ", blkflg
1611 : :
1612 [ + + + + ]: 418 : if(rfphon==1.and.psps%n1xccc/=0)then
1613 : : ! Complete the dyfrx1 matrix by symmetrization of the existing elements
1614 : : call d2sym3(blkflgfrx1,dyfrx1,indsym,natom,natom,dtset%nsym,qphon,symq,&
1615 : 239 : & symrec,dtset%symrel,timrev,zero_by_symm,eta=dtset%rfeta)
1616 : : end if
1617 : :
1618 : : ! Note that d2sym3 usually complete the 2nd-order matrix
1619 : : ! with elements that are zero by symmetry, automatically,
1620 : : ! unless it has been explicitly asked not to do so.
1621 : : ! blkflg is then set to 1 for these matrix elements, even if there has be no calculation.
1622 : :
1623 : : ! Add the frozen-wf (dyfrwf) part to the ewald part (dyew),
1624 : : ! the part 1 of the frozen wf part of the xc core correction
1625 : : ! (dyfrx1) and the non-frozen part (dynfr) to get the second-order
1626 : : ! derivative matrix (d2matr), then
1627 : : ! take account of the non-cartesian coordinates (d2cart).
1628 [ - + + - : 1254 : ABI_MALLOC(d2cart,(2,3,mpert,3,mpert))
- + + - -
+ - + ]
1629 [ - + + - : 1254 : ABI_MALLOC(carflg,(3,mpert,3,mpert))
- + + - -
+ - + ]
1630 [ - + + - : 1254 : ABI_MALLOC(d2matr,(2,3,mpert,3,mpert))
- + + - -
+ - + ]
1631 : 418 : outd2=1
1632 : : call dfpt_gatherdy(asr,becfrnl,dtset%berryopt,blkflg,carflg,&
1633 : : & chneut,dyew,dyfrwf,dyfrx1,dyfr_cplex,dyfr_nondiag,dyvdw,d2bbb,d2cart,d2cart_bbb,d2matr,d2nfr,&
1634 : : & eltcore,elteew,eltfrhar,eltfrkin,eltfrloc,eltfrnl,eltfrxc,eltvdw,&
1635 : : & gprimd,dtset%mband,mpert,natom,ntypat,outd2,pawbec,pawpiezo,piezofrnl,dtset%prtbbb,&
1636 : 418 : & rfpert,rprimd,dtset%typat,ucvol,usevdw,psps%ziontypat)
1637 : :
1638 : : ! Output of the dynamical matrix (master only)
1639 : : call dfpt_dyout(becfrnl,dtset%berryopt,blkflg,carflg,ddkfil,dyew,dyfrlo,&
1640 : : & dyfrnl,dyfrx1,dyfrx2,dyfr_cplex,dyfr_nondiag,dyvdw,d2cart,d2cart_bbb,d2eig0,&
1641 : : & d2k0,d2lo,d2loc0,d2matr,d2nl,d2nl0,d2nl1,d2ovl,d2vn,&
1642 : : & eltcore,elteew,eltfrhar,eltfrkin,eltfrloc,eltfrnl,eltfrxc,eltvdw,&
1643 : : & has_full_piezo,has_allddk,ab_out,dtset%mband,mpert,natom,ntypat,&
1644 : : & outd2,pawbec,pawpiezo,piezofrnl,dtset%prtbbb,dtset%prtvol,qzero,&
1645 : 418 : & dtset%typat,rfdir,rfmagn,rfpert,rfphon,rfstrs,psps%usepaw,usevdw,psps%ziontypat)
1646 : :
1647 : :
1648 : : ! Initialize ddb header object
1649 : : call ddb_hdr%init(dtset,psps,pawtab, dscrpt=' Note : temporary (transfer) database ', &
1650 : 418 : nblok=1,xred=xred,occ=occ,ngfft=ngfft)
1651 : :
1652 : : ! Initialize ddb object
1653 : 418 : call ddb%init(dtset, nblok=1, mpert=mpert, with_d2E=.true.)
1654 : :
1655 : : ! Set the values for the 2nd order derivatives
1656 : 418 : call ddb%set_omega(iblok=1, omega=dtset%rfomega)
1657 : 418 : call ddb%set_qpt(iblok=1, qpt=qphon(1:3))
1658 : 418 : call ddb%set_d2matr(1, d2matr, blkflg)
1659 : :
1660 : : ! Output dynamical matrix
1661 : 418 : call ddb%write(ddb_hdr, dtfil%fnameabo_ddb)
1662 : :
1663 : : ! Deallocate ddb object
1664 : 418 : call ddb_hdr%free()
1665 : 418 : call ddb%free()
1666 : :
1667 : : ! In case of phonons, diagonalize the dynamical matrix
1668 [ + + ]: 418 : if(rfphon==1)then
1669 : :
1670 : : ! First, suppress the 'wings' elements,
1671 : : ! for which the diagonal element is not known
1672 : 382 : call wings3(carflg,d2cart,mpert)
1673 : :
1674 : : ! Check the analyticity of the dynamical matrix
1675 : 382 : analyt=0
1676 [ + + - + ]: 382 : if (rfpert(natom+2)==0 .or. rfpert(natom+2)==2 .or. sumg0==1 ) analyt=1
1677 : :
1678 : : ! Diagonalize the analytic part
1679 [ + - - + : 1146 : ABI_MALLOC(displ,(2*3*natom*3*natom))
+ - + - +
- - + - +
- + ]
1680 [ + - - + : 1146 : ABI_MALLOC(eigval,(3*natom))
+ - + - +
- - + -
+ ]
1681 [ - + + - : 764 : ABI_MALLOC(eigvec,(2*3*natom*3*natom))
- + - + ]
1682 [ - + + - : 764 : ABI_MALLOC(phfrq,(3*natom))
- + - + -
+ ]
1683 : 382 : qphnrm=one
1684 : : call dfpt_phfrq(dtset%amu_orig(:,1),displ,d2cart,eigval,eigvec,indsym,mpert,&
1685 : : & dtset%nsym,natom,dtset%nsym,ntypat,phfrq,qphnrm,qphon,&
1686 [ - + - - : 382 : & dtset%rprimd_orig(1:3,1:3,1),0,dtset%symrel,dtset%symafm,dtset%typat,ucvol)
- - ]
1687 : :
1688 : : ! Print the phonon frequencies
1689 : 382 : call dfpt_prtph(displ,0,dtset%enunit,ab_out,natom,phfrq,qphnrm,qphon)
1690 : :
1691 : : ! Check the completeness of the dynamical matrix and eventually send a warning
1692 : 382 : call chkph3(carflg,0,mpert,natom)
1693 : : end if ! end case of phonons
1694 : : end if !end me == 0
1695 : :
1696 : : !Compute the other terms for AHC dynamic and AHC full
1697 [ + + + + : 720 : if (.not.(rfphon==0 .and. (rf2_dkdk/=0 .or. rf2_dkde/=0.or. rfddk/=0 .or. rfelfd==2) .and. rfstrs==0 &
+ + + + +
+ + - -
+ ]
1698 : : & .and. rfmagn==0)) then
1699 [ + + ]: 489 : if(rfphon==1) then ! AHC can only be computed in case of phonons
1700 : :
1701 : : ! Stuff for parallelism
1702 [ + + ]: 450 : if(master /= me) then
1703 [ + - - + : 204 : ABI_MALLOC(phfrq,(3*natom))
+ - + - +
- - + - +
- + ]
1704 [ + - - + : 204 : ABI_MALLOC(displ,(2*3*natom*3*natom))
+ - + - +
- - + - +
- + ]
1705 : : end if
1706 : 450 : call xmpi_bcast (phfrq,master,mpi_enreg%comm_cell,ierr) !Broadcast phfrq and displ
1707 : 450 : call xmpi_bcast (displ,master,mpi_enreg%comm_cell,ierr) !to all processes
1708 : :
1709 [ + + ]: 450 : if(dtset%ieig2rf == 3 .or. dtset%ieig2rf == 4 .or. dtset%ieig2rf == 5 ) then
1710 : 54 : bdeigrf = dtset%bdeigrf
1711 [ + + ]: 54 : if(dtset%bdeigrf == -1) bdeigrf = dtset%mband
1712 : : ! if ((dtset%getwfkfine /= 0 .and. dtset%irdwfkfine ==0) .or.&
1713 : : ! & (dtset%getwfkfine == 0 .and. dtset%irdwfkfine /=0) ) then
1714 : : ! write(std_out,*)'Reading the dense grid WF file'
1715 : : ! call wfk_read_eigenvalues(dtfil%fnameabi_wfkfine,eigenq_fine,hdr_fine,mpi_enreg%comm_world)
1716 : : ! ABI_CHECK(SIZE(eigenq_fine,DIM=1)==Dtset%mband,"Size eigenq_fine != mband")
1717 : : ! endif
1718 [ + + + - ]: 54 : if(dtset%kptopt==3 .or. dtset%kptopt==0 .or. dtset%nsym==1)then
1719 : 54 : write(std_out,*) 'Entering: eig2tot'
1720 [ + - ]: 54 : if(dtset%smdelta>0)then
1721 [ - + - - : 54 : if ((dtset%getwfkfine /= 0 .and. dtset%irdwfkfine ==0) .or.&
+ - - + ]
1722 : : & (dtset%getwfkfine == 0 .and. dtset%irdwfkfine /=0) ) then
1723 : : call eig2tot(dtfil,xred,psps,pawtab,natom,bdeigrf,clflg,dim_eig2nkq,eigen0_pert,&
1724 : : & eigenq_pert,eigen1_pert,eig2nkq,dtset%elph2_imagden,dtset%esmear,dtset%ieig2rf,dtset%mband,mpert,&
1725 : : & dtset%natom,mpi_enreg,doccde,nkpt_rbz,dtset%nsppol,dtset%smdelta,rprimd,dtset,&
1726 [ # # ]: 0 : & occ_rbz_pert,hdr0,eigbrd,eigenq_fine,hdr_fine)
1727 : : else
1728 : : call eig2tot(dtfil,xred,psps,pawtab,natom,bdeigrf,clflg,dim_eig2nkq,eigen0_pert,&
1729 : : & eigenq_pert,eigen1_pert,eig2nkq,dtset%elph2_imagden,dtset%esmear,dtset%ieig2rf,dtset%mband,mpert,&
1730 : : & dtset%natom,mpi_enreg,doccde,nkpt_rbz,dtset%nsppol,dtset%smdelta,rprimd,dtset,&
1731 [ - + ]: 54 : & occ_rbz_pert,hdr0,eigbrd)
1732 : : end if
1733 : : else
1734 [ # # # # : 0 : if ((dtset%getwfkfine /= 0 .and. dtset%irdwfkfine ==0) .or.&
# # # # ]
1735 : : & (dtset%getwfkfine == 0 .and. dtset%irdwfkfine /=0) ) then
1736 : : call eig2tot(dtfil,xred,psps,pawtab,natom,bdeigrf,clflg,dim_eig2nkq,eigen0_pert,&
1737 : : & eigenq_pert,eigen1_pert,eig2nkq,dtset%elph2_imagden,dtset%esmear,dtset%ieig2rf,dtset%mband,mpert,&
1738 : : & dtset%natom,mpi_enreg,doccde,nkpt_rbz,dtset%nsppol,dtset%smdelta,rprimd,dtset,&
1739 [ # # ]: 0 : & occ_rbz_pert,hdr0,eigbrd,eigenq_fine,hdr_fine)
1740 : : else
1741 : : call eig2tot(dtfil,xred,psps,pawtab,natom,bdeigrf,clflg,dim_eig2nkq,eigen0_pert,&
1742 : : & eigenq_pert,eigen1_pert,eig2nkq,dtset%elph2_imagden,dtset%esmear,dtset%ieig2rf,dtset%mband,mpert,&
1743 : : & dtset%natom,mpi_enreg,doccde,nkpt_rbz,dtset%nsppol,dtset%smdelta,rprimd,dtset,&
1744 [ # # ]: 0 : & occ_rbz_pert,hdr0)
1745 : : end if
1746 : : end if
1747 : 54 : write(std_out,*) 'Leaving: eig2tot'
1748 : : end if
1749 : : end if
1750 [ + + ]: 450 : if (dtset%ieig2rf > 0) then
1751 [ - + ]: 84 : ABI_FREE(eigen0_pert)
1752 [ - + ]: 84 : ABI_FREE(eigenq_pert)
1753 [ - + ]: 84 : ABI_FREE(occ_rbz_pert)
1754 [ - + ]: 84 : ABI_FREE(eigen1_pert)
1755 : 84 : call hdr0%free()
1756 [ + + - + : 84 : if ((dtset%getwfkfine /= 0 .and. dtset%irdwfkfine ==0) .or.&
+ - + + ]
1757 : : & (dtset%getwfkfine == 0 .and. dtset%irdwfkfine /=0) ) then
1758 : 3 : call hdr_fine%free()
1759 [ - + ]: 3 : ABI_FREE(eigenq_fine)
1760 : : end if
1761 : : end if ! ieig2rf == 3 or %ieig2rf == 4 or %ieig2rf == 5
1762 : : end if ! rfphon==1
1763 : : end if
1764 [ + + ]: 720 : if(dtset%efmas>0) then
1765 [ - + ]: 17 : ABI_FREE(eigen0_pert)
1766 [ - + ]: 17 : ABI_FREE(eigen1_pert)
1767 : : end if
1768 : :
1769 [ - + ]: 720 : ABI_FREE(doccde)
1770 : :
1771 [ + + ]: 720 : if(me==0)then
1772 [ + + + + : 623 : if (.not.(rfphon==0 .and. (rf2_dkdk/=0 .or. rf2_dkde/=0 .or. rfddk/=0 .or. rfelfd==2) .and. rfstrs==0 &
+ + + + +
+ + - -
+ ]
1773 : : & .and. rfmagn==0) )then
1774 [ + + ]: 418 : if(rfphon==1)then
1775 : : ! Compute and print the T=0 Fan, and possibly DDW contributions to the eigenenergies.
1776 [ + + ]: 382 : if(dtset%ieig2rf > 0) then
1777 [ + + ]: 5508 : write(msg, '(80a,9a)' ) ('=',mu=1,80),ch10,ch10,&
1778 : 68 : & ' ---- T=0 shift of eigenenergies due to electron-phonon interation at q ---- ',ch10,&
1779 : 68 : & ' Warning : the total shift must be computed through anaddb, ',ch10,&
1780 : 68 : & ' here, only the contribution of one q point is printed. ',ch10,&
1781 [ + - ]: 5576 : & ' Print first the electronic eigenvalues, then the q-dependent Fan shift of eigenvalues.'
1782 [ + + ]: 204 : call wrtout([std_out, ab_out], msg)
1783 : :
1784 [ + + ]: 68 : if(qeq0)then
1785 : 21 : write(msg, '(a)' )' Phonons at gamma, also compute the Diagonal Debye-Waller shift of eigenvalues.'
1786 [ + + ]: 63 : call wrtout([std_out, ab_out], msg)
1787 : : end if
1788 : :
1789 : 68 : write(msg, '(a)' ) ' '
1790 [ + + ]: 204 : call wrtout([std_out, ab_out], msg)
1791 : :
1792 : : call prteigrs(eigen0,dtset%enunit,fermie,fermih,dtfil%fnameabo_eig,ab_out,-1,dtset%kptns,dtset%kptopt,&
1793 : : & dtset%mband,dtset%nband,dtset%nbdbuf,dtset%nkpt,1,dtset%nsppol,occ,dtset%occopt,3,0,dtset%prtvol,&
1794 : 68 : & eigen0,zero,zero,dtset%wtk)
1795 : :
1796 : 68 : write(msg, '(a)' ) ch10
1797 [ + + ]: 204 : call wrtout([std_out, ab_out], msg)
1798 : :
1799 : : ! Compute and print Fan contribution
1800 [ - + + - : 204 : ABI_MALLOC(eigen_fan,(dtset%mband*dtset%nkpt*dtset%nsppol))
+ - + - -
+ - + ]
1801 [ - + + - : 136 : ABI_MALLOC(eigen_fan_mean,(dtset%mband*dtset%nkpt*dtset%nsppol))
- + - + ]
1802 : : call elph2_fanddw(dim_eig2nkq,displ,eig2nkq,eigen_fan,gprimd,&
1803 : 68 : & dtset%mband,natom,dtset%nkpt,dtset%nsppol,1,phfrq,dtset%prtvol)
1804 : 68 : call eigen_meandege(eigen0,eigen_fan,eigen_fan_mean,dtset%mband,dtset%nband,dtset%nkpt,dtset%nsppol,2)
1805 : : call prteigrs(eigen_fan_mean,dtset%enunit,fermie,fermih,dtfil%fnameabo_eig,ab_out,-1,dtset%kptns,dtset%kptopt,&
1806 : : & dtset%mband,dtset%nband,dtset%nbdbuf,dtset%nkpt,1,dtset%nsppol,occ,dtset%occopt,5,0,dtset%prtvol,&
1807 : 68 : & eigen0,zero,zero,dtset%wtk)
1808 : :
1809 [ + + + + ]: 68 : if(qeq0 .or. dtset%getgam_eig2nkq>0)then
1810 : :
1811 : 29 : write(msg, '(a)' ) ch10
1812 [ + + ]: 87 : call wrtout([std_out, ab_out], msg)
1813 : :
1814 : : ! Compute and print Diagonal Debye-Waller contribution
1815 [ - + + - : 58 : ABI_MALLOC(eigen_ddw,(dtset%mband*dtset%nkpt*dtset%nsppol))
- + - + ]
1816 [ - + + - : 58 : ABI_MALLOC(eigen_ddw_mean,(dtset%mband*dtset%nkpt*dtset%nsppol))
- + - + ]
1817 [ + + ]: 29 : if(qeq0)then
1818 : : call elph2_fanddw(dim_eig2nkq,displ,eig2nkq,eigen_ddw,gprimd,&
1819 : 21 : & dtset%mband,natom,dtset%nkpt,dtset%nsppol,2,phfrq,dtset%prtvol)
1820 [ + + ]: 21 : if(results_respfn%gam_jdtset == -dtset%jdtset)then
1821 : 2 : sz1=dtset%mband*dtset%nsppol
1822 : 2 : sz2=natom*dim_eig2nkq
1823 [ - + + - : 14 : ABI_MALLOC(results_respfn%gam_eig2nkq,(2,sz1,dtset%nkpt,3,natom,3,sz2))
- + + - -
+ + - + -
- + + - +
- + - - +
- + - + ]
1824 [ + + + + : 8210 : results_respfn%gam_eig2nkq(:,:,:,:,:,:,:)=eig2nkq(:,:,:,:,:,:,:)
+ + + + +
+ + + +
+ ]
1825 : 2 : results_respfn%gam_jdtset=dtset%jdtset
1826 : : end if
1827 [ + - ]: 8 : else if(dtset%getgam_eig2nkq>0)then
1828 [ + - ]: 8 : if(results_respfn%gam_jdtset==dtset%getgam_eig2nkq)then
1829 : : call elph2_fanddw(dim_eig2nkq,displ,results_respfn%gam_eig2nkq,eigen_ddw,&
1830 : 8 : & gprimd,dtset%mband,natom,dtset%nkpt,dtset%nsppol,2,phfrq,dtset%prtvol)
1831 : : else
1832 : : write(msg,'(a,i0,2a,i0,2a)')&
1833 : 0 : & 'results_respfn%gam_jdtset=',results_respfn%gam_jdtset,ch10,&
1834 : 0 : & 'dtset%getgam_eig2nkq=',dtset%getgam_eig2nkq,ch10,&
1835 : 0 : & 'So, it seems eig2nkq at gamma has not yet been computed, while it is needed now.'
1836 : 0 : ABI_BUG(msg)
1837 : : end if
1838 : : end if
1839 : 29 : call eigen_meandege(eigen0,eigen_ddw,eigen_ddw_mean,dtset%mband,dtset%nband,dtset%nkpt,dtset%nsppol,2)
1840 : : call prteigrs(eigen_ddw_mean,dtset%enunit,fermie,fermih,dtfil%fnameabo_eig,ab_out,-1,dtset%kptns,dtset%kptopt,&
1841 : : & dtset%mband,dtset%nband,dtset%nbdbuf,dtset%nkpt,1,dtset%nsppol,occ,dtset%occopt,6,0,dtset%prtvol,&
1842 : 29 : & eigen0,zero,zero,dtset%wtk)
1843 : 29 : write(msg, '(a)' ) ch10
1844 [ + + ]: 87 : call wrtout([std_out, ab_out], msg)
1845 : :
1846 : : ! Print sum of mean Fan and DDW
1847 [ - + + - : 87 : ABI_MALLOC(eigen_fanddw,(dtset%mband*dtset%nkpt*dtset%nsppol))
+ - + - -
+ - + ]
1848 [ + - - + : 3338 : eigen_fanddw=eigen_fan_mean+eigen_ddw_mean
- - + + ]
1849 : : call prteigrs(eigen_fanddw,dtset%enunit,fermie,fermih,dtfil%fnameabo_eig,ab_out,-1,dtset%kptns,dtset%kptopt,&
1850 : : & dtset%mband,dtset%nband,dtset%nbdbuf,dtset%nkpt,1,dtset%nsppol,occ,dtset%occopt,7,0,dtset%prtvol,&
1851 : 29 : & eigen0,zero,zero,dtset%wtk)
1852 : :
1853 [ - + ]: 29 : ABI_FREE(eigen_ddw)
1854 [ - + ]: 29 : ABI_FREE(eigen_ddw_mean)
1855 [ - + ]: 29 : ABI_FREE(eigen_fanddw)
1856 : :
1857 : : end if
1858 : :
1859 [ - + ]: 68 : ABI_FREE(eigen_fan)
1860 [ - + ]: 68 : ABI_FREE(eigen_fan_mean)
1861 : : end if
1862 : :
1863 : : ! In case of a non-analytical part,
1864 : : ! get the phonon frequencies for three different directions (in cartesian coordinates)
1865 [ + + ]: 382 : if(analyt==0)then
1866 : 76 : qphnrm=zero
1867 [ + + ]: 304 : do idir=1,3
1868 : : ! Need to know the corresponding dielectric constant
1869 [ + + ]: 304 : if(carflg(idir,natom+2,idir,natom+2)==1)then
1870 : 219 : qphon(:)=zero ; qphon(idir)=one
1871 : : ! Get the phonon frequencies
1872 : : call dfpt_phfrq(dtset%amu_orig(:,1),displ,d2cart,eigval,eigvec,indsym,mpert,&
1873 : : & dtset%nsym,natom,dtset%nsym,ntypat,phfrq,qphnrm,qphon,&
1874 [ - + - - : 219 : & dtset%rprimd_orig(1:3,1:3,1),0,dtset%symrel,dtset%symafm,dtset%typat,ucvol)
- - ]
1875 : : ! Print the phonon frequencies
1876 : 219 : call dfpt_prtph(displ,0,dtset%enunit,ab_out,natom,phfrq,qphnrm,qphon)
1877 : : ! Check the completeness of the dynamical matrix
1878 : : ! and eventually send a warning
1879 : 219 : call chkph3(carflg,idir,mpert,natom)
1880 : : end if
1881 : : end do
1882 : : if (idir < 4) then
1883 : : qphon(idir)=zero
1884 : : end if
1885 : : end if
1886 : :
1887 [ - + ]: 382 : ABI_FREE(displ)
1888 [ - + ]: 382 : ABI_FREE(eigval)
1889 [ - + ]: 382 : ABI_FREE(eigvec)
1890 [ - + ]: 382 : ABI_FREE(phfrq)
1891 : : end if ! rfphon == 1
1892 [ - + ]: 418 : ABI_FREE(carflg)
1893 [ - + ]: 418 : ABI_FREE(d2cart)
1894 [ - + ]: 418 : ABI_FREE(d2matr)
1895 : : end if ! End condition on if.not.
1896 : : end if ! master node
1897 : :
1898 : : !Deallocate arrays
1899 [ + + ]: 720 : ABI_SFREE(displ)
1900 [ - + ]: 720 : ABI_SFREE(eigval)
1901 [ - + ]: 720 : ABI_SFREE(eigvec)
1902 [ + + ]: 720 : ABI_SFREE(phfrq)
1903 : :
1904 [ - + ]: 720 : ABI_FREE(clflg)
1905 [ - + ]: 720 : ABI_FREE(atindx)
1906 [ - + ]: 720 : ABI_FREE(atindx1)
1907 [ - + ]: 720 : ABI_FREE(blkflg)
1908 [ - + ]: 720 : ABI_FREE(dyew)
1909 [ - + ]: 720 : ABI_FREE(dyewq0)
1910 [ - + ]: 720 : ABI_FREE(dyfrlo)
1911 [ - + ]: 720 : ABI_FREE(dyfrnl)
1912 [ - + ]: 720 : ABI_FREE(dyfrwf)
1913 [ - + ]: 720 : ABI_FREE(dyfrx1)
1914 [ - + ]: 720 : ABI_FREE(dyfrx2)
1915 [ - + ]: 720 : ABI_FREE(dyvdw)
1916 [ - + ]: 720 : ABI_FREE(d2bbb)
1917 [ - + ]: 720 : ABI_FREE(d2cart_bbb)
1918 [ - + ]: 720 : ABI_FREE(d2eig0)
1919 [ - + ]: 720 : ABI_FREE(d2k0)
1920 [ - + ]: 720 : ABI_FREE(d2lo)
1921 [ - + ]: 720 : ABI_FREE(d2loc0)
1922 [ - + ]: 720 : ABI_FREE(d2nfr)
1923 [ - + ]: 720 : ABI_FREE(d2nl)
1924 [ - + ]: 720 : ABI_FREE(d2nl0)
1925 [ - + ]: 720 : ABI_FREE(d2nl1)
1926 [ - + ]: 720 : ABI_FREE(d2ovl)
1927 [ - + ]: 720 : ABI_FREE(d2vn)
1928 [ - + ]: 720 : ABI_FREE(eigen0)
1929 [ - + ]: 720 : ABI_FREE(eig2nkq)
1930 [ - + ]: 720 : ABI_FREE(eigbrd)
1931 [ - + ]: 720 : ABI_FREE(eltcore)
1932 [ - + ]: 720 : ABI_FREE(elteew)
1933 [ - + ]: 720 : ABI_FREE(eltfrhar)
1934 [ - + ]: 720 : ABI_FREE(eltfrnl)
1935 [ - + ]: 720 : ABI_FREE(eltfrloc)
1936 [ - + ]: 720 : ABI_FREE(eltfrkin)
1937 [ - + ]: 720 : ABI_FREE(eltfrxc)
1938 [ - + ]: 720 : ABI_FREE(eltvdw)
1939 [ - + ]: 720 : ABI_FREE(becfrnl)
1940 [ - + ]: 720 : ABI_FREE(piezofrnl)
1941 : 720 : call efmasdeg_free_array(efmasdeg)
1942 : 720 : call efmasval_free_array(efmasval)
1943 [ - + ]: 720 : ABI_FREE(grxc)
1944 [ - + ]: 720 : ABI_FREE(indsym)
1945 [ - + ]: 720 : ABI_FREE(kxc)
1946 [ - + ]: 720 : ABI_FREE(nattyp)
1947 [ - + ]: 720 : ABI_FREE(pertsy)
1948 : 720 : ABI_FREE(rfpert)
1949 [ - + ]: 720 : ABI_FREE(rhog)
1950 [ - + ]: 720 : ABI_FREE(rhor)
1951 [ - + ]: 720 : ABI_FREE(taug)
1952 [ - + ]: 720 : ABI_FREE(taur)
1953 [ - + ]: 720 : ABI_FREE(symq)
1954 [ - + ]: 720 : ABI_FREE(symrec)
1955 [ - + ]: 720 : ABI_FREE(symrel_cart)
1956 [ - + ]: 720 : ABI_FREE(vtrial)
1957 [ - + ]: 720 : ABI_FREE(ylm)
1958 [ - + ]: 720 : ABI_FREE(ylmgr)
1959 : 720 : call pawfgr_destroy(pawfgr)
1960 [ + + ]: 720 : if (psps%usepaw==1) then
1961 : 116 : call pawrhoij_free(pawrhoij)
1962 : 116 : call paw_an_free(paw_an)
1963 : 116 : call paw_ij_free(paw_ij)
1964 : 116 : call pawfgrtab_free(pawfgrtab)
1965 : : end if
1966 [ - + ]: 720 : ABI_FREE(nhat)
1967 [ - + ]: 720 : ABI_FREE(nhatgr)
1968 [ + - + + : 912 : ABI_FREE(pawrhoij)
- + - + -
+ - + - +
- + - + ]
1969 [ + - + + : 912 : ABI_FREE(paw_an)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + -
+ ]
1970 [ + - + + : 912 : ABI_FREE(paw_ij)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + ]
1971 [ + - + + : 912 : ABI_FREE(pawfgrtab)
- + - + -
+ - + - +
- + - + -
+ - + ]
1972 [ + + + + ]: 720 : if(rfphon==1.and.psps%n1xccc/=0)then
1973 [ - + ]: 287 : ABI_FREE(blkflgfrx1)
1974 : : end if
1975 : :
1976 : : ! Clean the header
1977 : 720 : call hdr%free()
1978 : :
1979 : : !Clean GPU data
1980 : : #if defined HAVE_GPU
1981 : : if (dtset%gpu_option/=ABI_GPU_DISABLED) then
1982 : : call dealloc_hamilt_gpu(0,dtset%gpu_option)
1983 : : end if
1984 : : #endif
1985 : :
1986 : : ABI_NVTX_END_RANGE()
1987 : 720 : call timab(138,2,tsec)
1988 : 720 : call timab(132,2,tsec)
1989 : :
1990 : : DBG_EXIT("COLL")
1991 : :
1992 [ - + - + : 5040 : end subroutine respfn
- + - + -
+ - + - +
- + - + -
+ - - - -
- - - - -
- - - - -
- + - - -
- - - - -
- - - - -
- - + - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - +
- + - + -
+ - + - -
- - - - -
- - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - -
- - - - -
- - - - -
- - - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
- - - - -
- - - - -
- - - - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- - - - -
- - - - -
- - - - -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - - - -
- - - - -
- - - - -
- + - + -
+ - - - -
- - - + -
- - - - -
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- - - - -
- - - - -
- - - - -
- - - - -
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + ]
1993 : : !!***
1994 : :
1995 : : !!****f* m_respfn_driver/wrtloctens
1996 : : !! NAME
1997 : : !! wrtloctens
1998 : : !!
1999 : : !! FUNCTION
2000 : : !! Output of the localisation tensor
2001 : : !!
2002 : : !! INPUTS
2003 : : !! blkflg = flags for each element of the 2DTE (=1 if computed)
2004 : : !! d2bbb = band by band decomposition of second order derivatives
2005 : : !! d2nl = non-local contributions to the 2DTEs
2006 : : !! mband = maximum number of bands
2007 : : !! mpert = maximum number of ipert
2008 : : !! natom = number of atoms in unit cell
2009 : : !! prtbbb = if = 1, write the band by band decomposition of the localization tensor
2010 : : !! rprimd = dimensional primitive translations for real space (bohr)
2011 : : !! usepaw = flag for PAW
2012 : : !!
2013 : : !! OUTPUT
2014 : : !! (only writing)
2015 : : !!
2016 : : !! TODO
2017 : : !! The localization tensor cannot be defined in the metallic case. It should not be computed.
2018 : : !!
2019 : : !! SOURCE
2020 : :
2021 : 158 : subroutine wrtloctens(blkflg,d2bbb,d2nl,mband,mpert,natom,prtbbb,rprimd,usepaw)
2022 : :
2023 : : !Arguments ------------------------------------
2024 : : !scalars
2025 : : integer,intent(in) :: mband,mpert,natom,prtbbb,usepaw
2026 : : !arrays
2027 : : integer,intent(in) :: blkflg(3,mpert,3,mpert)
2028 : : real(dp),intent(in) :: rprimd(3,3)
2029 : : real(dp),intent(inout) :: d2bbb(2,3,3,mpert,mband,mband*prtbbb)
2030 : : real(dp),intent(inout) :: d2nl(2,3,mpert,3,mpert)
2031 : :
2032 : : !Local variables ------------------------------
2033 : : !scalars
2034 : : integer :: flag,iband,idir,idir2,jband
2035 : : character(len=500) :: msg
2036 : : !arrays
2037 : : real(dp) :: loctenscart(2,3,3)
2038 : 158 : real(dp),allocatable :: loctenscart_bbb(:,:,:,:,:)
2039 : :
2040 : : ! *********************************************************************
2041 : :
2042 : : !This feature is disabled in the PAW case
2043 [ + + ]: 158 : if (usepaw==1) return
2044 : :
2045 [ + + ]: 119 : if(prtbbb==1)then
2046 [ - + + - : 8 : ABI_MALLOC(loctenscart_bbb,(2,3,3,mband,mband*prtbbb))
- + + - +
- + - - +
- + ]
2047 [ + + + + : 3986 : loctenscart_bbb(:,:,:,:,:)=zero
+ + + + +
+ ]
2048 : : end if
2049 : :
2050 : : !complete missing elements
2051 : 119 : flag = 0
2052 [ + + ]: 476 : do idir2 = 1,3
2053 [ + + ]: 1547 : do idir = 1,3
2054 : :
2055 [ + + ]: 1428 : if (blkflg(idir2,natom+1,idir,natom+1)==0) then
2056 [ + + ]: 627 : if (blkflg(idir,natom+1,idir2,natom+1)==0) then
2057 : : flag = 1
2058 : : else
2059 : 195 : d2nl(1,idir2,natom+1,idir,natom+1) = d2nl(1,idir,natom+1,idir2,natom+1)
2060 : 195 : d2nl(2,idir2,natom+1,idir,natom+1) =-d2nl(2,idir,natom+1,idir2,natom+1)
2061 [ + + ]: 195 : if(prtbbb==1)then
2062 [ + + + + ]: 438 : d2bbb(1,idir2,idir,natom+1,:,:) = d2bbb(1,idir,idir2,natom+1,:,:)
2063 [ + + + + ]: 438 : d2bbb(2,idir2,idir,natom+1,:,:) =-d2bbb(2,idir,idir2,natom+1,:,:)
2064 : : end if
2065 : :
2066 : : end if
2067 : : end if
2068 : :
2069 : : end do ! idir=1,3
2070 : : end do ! idir2=1,3
2071 : :
2072 : : !Transform the tensor to cartesian coordinates
2073 : :
2074 [ + + + + : 6188 : loctenscart(1,:,:) = matmul(rprimd,d2nl(1,:,natom+1,:,natom+1))
+ + + + +
+ ]
2075 [ + + + + : 6188 : loctenscart(2,:,:) = matmul(rprimd,d2nl(2,:,natom+1,:,natom+1))
+ + + + +
+ ]
2076 : :
2077 [ + + + + : 7616 : loctenscart(1,:,:) = matmul(loctenscart(1,:,:),transpose(rprimd))
+ + + + +
+ + + +
+ ]
2078 [ + + + + : 7616 : loctenscart(2,:,:) = matmul(loctenscart(2,:,:),transpose(rprimd))
+ + + + +
+ + + +
+ ]
2079 : :
2080 [ + + + + : 3689 : loctenscart(:,:,:) = loctenscart(:,:,:)/(two_pi**2)
+ + ]
2081 : :
2082 [ + + ]: 119 : if (prtbbb == 1) then
2083 : :
2084 : 2 : write(msg,'(a,a)')ch10, ' Band by band decomposition of the localisation tensor (bohr^2)'
2085 [ + + ]: 6 : call wrtout([std_out, ab_out], msg)
2086 : :
2087 [ + + ]: 18 : do iband = 1,mband
2088 [ + + ]: 146 : do jband = 1,mband
2089 : :
2090 [ + + + + : 6656 : loctenscart_bbb(1,:,:,iband,jband) = matmul(rprimd,d2bbb(1,:,:,natom+1,iband,jband))
+ + + + +
+ ]
2091 [ + + + + : 6656 : loctenscart_bbb(2,:,:,iband,jband) = matmul(rprimd,d2bbb(2,:,:,natom+1,iband,jband))
+ + + + +
+ ]
2092 : :
2093 [ + + + + : 8192 : loctenscart_bbb(1,:,:,iband,jband) = matmul(loctenscart_bbb(1,:,:,iband,jband),transpose(rprimd))
+ + + + +
+ + + + +
+ - ]
2094 [ + + + + : 8192 : loctenscart_bbb(2,:,:,iband,jband) = matmul(loctenscart_bbb(2,:,:,iband,jband),transpose(rprimd))
+ + + + +
+ + + + +
+ - ]
2095 : :
2096 [ + + + + : 3968 : loctenscart_bbb(:,:,:,iband,jband) = loctenscart_bbb(:,:,:,iband,jband)/(two_pi**2)
+ + ]
2097 : :
2098 : :
2099 : 128 : write(msg,'(a,a,i5,a,i5,a)')ch10, &
2100 : 128 : ' Localisation tensor (bohr^2) for band ',iband,',',jband, &
2101 : 256 : ' in cartesian coordinates'
2102 [ + + ]: 384 : call wrtout([std_out, ab_out], msg)
2103 : :
2104 : 128 : write(ab_out,*)' direction matrix element'
2105 : 128 : write(ab_out,*)' alpha beta real part imaginary part'
2106 [ + + ]: 528 : do idir2 = 1,3
2107 [ + + ]: 1664 : do idir = 1,3
2108 : 1152 : write(ab_out,'(5x,i1,8x,i1,3x,2f16.10)')idir2,idir,&
2109 : 1152 : loctenscart_bbb(1,idir2,idir,iband,jband),&
2110 : 2688 : loctenscart_bbb(2,idir2,idir,iband,jband)
2111 : : end do
2112 : : end do
2113 : :
2114 : : end do !jband
2115 : : end do !iband
2116 : :
2117 : : end if !prtbbb
2118 : :
2119 [ + - ]: 119 : if (usepaw==0) then
2120 : 119 : write(msg,'(a,a,a,a)')ch10, &
2121 : 119 : & ' Total localisation tensor (bohr^2) in cartesian coordinates',ch10,&
2122 : 238 : & ' WARNING : still subject to testing - especially symmetries.'
2123 : : else
2124 : 0 : write(msg,'(a,a,a,a,a,a)')ch10, &
2125 : 0 : & ' Total localisation tensor (bohr^2) in cartesian coordinates',ch10,&
2126 : 0 : & ' WARNING : probably wrong for PAW (printing for testing purpose)',ch10,&
2127 : 0 : & ' WARNING : still subject to testing - especially symmetries.'
2128 : : end if
2129 [ + + ]: 357 : call wrtout([std_out, ab_out], msg)
2130 : :
2131 : 119 : write(ab_out,*)' direction matrix element'
2132 : 119 : write(ab_out,*)' alpha beta real part imaginary part'
2133 [ + + ]: 476 : do idir2 = 1,3
2134 [ + + ]: 1547 : do idir = 1,3
2135 : 1071 : write(ab_out,'(5x,i1,8x,i1,3x,2f16.10)')idir2,idir,&
2136 : 1071 : & loctenscart(1,idir2,idir),&
2137 : 2499 : & loctenscart(2,idir2,idir)
2138 : : end do
2139 : : end do
2140 : :
2141 [ + + ]: 119 : if (flag == 1) then
2142 : 54 : write(msg,'(6a)')ch10,&
2143 : 54 : & ' WARNING : Localization tensor calculation (this does not apply to other properties).',ch10,&
2144 : 54 : & ' Not all d/dk perturbations were computed. So the localization tensor in reciprocal space is incomplete,',ch10,&
2145 : 108 : & ' and transformation to cartesian coordinates may be wrong. Check input variable rfdir.'
2146 [ + + ]: 162 : call wrtout([std_out, ab_out], msg)
2147 : : end if
2148 : :
2149 [ + + ]: 119 : ABI_SFREE(loctenscart_bbb)
2150 : :
2151 : : end subroutine wrtloctens
2152 : : !!***
2153 : :
2154 : : !!****f* ABINIT/dfpt_dyout
2155 : : !! NAME
2156 : : !! dfpt_dyout
2157 : : !!
2158 : : !! FUNCTION
2159 : : !! Output of all quantities related to the 2nd-order matrix:
2160 : : !! Ewald part, local and non-local frozen wf part, core contributions,
2161 : : !! local and non-local variational part, 2nd-order matrix itself, and, for the phonon part,
2162 : : !! eigenfrequencies, in Hartree, meV and cm-1.
2163 : : !! Also output unformatted 2nd-order matrix for later use in the Brillouin-zone interpolation
2164 : : !!
2165 : : !! INPUTS
2166 : : !! becfrnl(3,natom,3*pawbec)=NL frozen contribution to Born Effective Charges (PAW only)
2167 : : !! blkflg(3,mpert,3,mpert)= ( 1 if the element of the dynamical
2168 : : !! matrix has been calculated ; 0 otherwise )
2169 : : !! carflg(3,mpert,3,mpert)= ( 1 if the element of the cartesian
2170 : : !! 2DTE matrix has been calculated correctly ; 0 otherwise )
2171 : : !! ddkfil(3)=components are 1 if corresponding d/dk file exists, otherwise 0
2172 : : !! (in what follows, DYMX means dynamical matrix, and D2MX means 2nd-order matrix)
2173 : : !! dyew(2,3,natom,3,natom)=Ewald part of the DYMX
2174 : : !! dyfrlo(3,3,natom)=frozen wf local part of the DYMX
2175 : : !! dyfrnl(dyfr_cplex,3,3,natom,1+(natom-1)*dyfr_nondiag)=frozen wf nonloc part of the DYMX
2176 : : !! dyfrx1(2,3,natom,3,natom)=frozen wf nonlin. xc core corr.(1)
2177 : : !! part of the DYMX
2178 : : !! dyfrx2(3,3,natom)=frozen wf nonlin. xc core corr.(2) part of the DYMX
2179 : : !! dyfr_cplex=1 if dyfrnl is real, 2 if it is complex
2180 : : !! dyfr_nondiag=1 if dyfrnl is non diagonal with respect to atoms; 0 otherwise
2181 : : !! dyvdw(2,3,natom,3,natom*usevdw)=vdw DFT-D part of the dynamical matrix
2182 : : !! d2cart(2,3,mpert,3,mpert)=D2MX in cartesian coordinates
2183 : : !! d2cart_bbb(2,3,3,mpert,mband,mband*prtbbb)=
2184 : : !! band by band decomposition of Born effective charges
2185 : : !! (calculated from phonon-type perturbation) in cartesian coordinates
2186 : : !! d2eig0(2,3,mpert,3,mpert)=0-order eigen. station. part of the D2MX
2187 : : !! d2k0(2,3,mpert,3,mpert)=0-order kinet. station. part of the D2MX
2188 : : !! d2lo(2,3,mpert,3,mpert)=nonstation. local part of the D2MX
2189 : : !! d2loc0(2,3,mpert,3,mpert)=0-order loc station. part of the D2MX
2190 : : !! d2matr(2,3,mpert,3,mpert)=D2MX in non-cartesian coordinates
2191 : : !! d2nl(2,3,mpert,3,mpert)=nonstation. nonloc part of the D2MX
2192 : : !! d2nl0(2,3,mpert,3,mpert)=0-order nonloc station. part of the D2MX
2193 : : !! d2nl1(2,3,mpert,3,mpert)=1-order nonloc station. part of the D2MX
2194 : : !! d2ovl(2,mpert,3,mpert*usepaw)=1st-order change of WF overlap contributions to the 2DTEs (PAW)
2195 : : !! d2vn(2,3,mpert,3,mpert)=potential*dens station. part of the D2MX and without masses included)
2196 : : !! eltcore(6,6)=core contribution to the elastic tensor
2197 : : !! elteew(6+3*natom,6)=Ewald contribution to the elastic tsenor
2198 : : !! eltfrhar(6,6)=hartree contribution to the elastic tensor
2199 : : !! eltfrkin(6,6)=kinetic contribution to the elastic tensor
2200 : : !! eltfrloc(6+3*natom,6)=local psp contribution to the elastic tensor
2201 : : !! eltfrnl(6+3*natom,6)=non-local psp contribution to the elastic tensor
2202 : : !! eltfrxc(6+3*natom,6)=exchange-correlation contribution to the elastic tensor
2203 : : !! eltvdw(6+3*natom,6*usevdw)=vdw DFT-D part of the elastic tensor
2204 : : !! has_full_piezo=the full calculation of the piezoelectric tensor from electric field perturbation
2205 : : !! is only available if nsym=1 (strain perturbation is not symmetrized)
2206 : : !! has_allddk= True if all ddk file are present on disk, so the effective charge or piezzo
2207 : : !! electric tensor are correctly computed (PAW ONLY)
2208 : : !! iout=unit number for long write-up
2209 : : !! mband=maximum number of bands
2210 : : !! mpert =maximum number of ipert
2211 : : !! natom=number of atoms
2212 : : !! ntypat=number of atom types
2213 : : !! outd2=option for the output of the 2nd-order matrix :
2214 : : !! if outd2=1, non-stationary part
2215 : : !! if outd2=2, stationary part.
2216 : : !! pawbec= flag for the computation of frozen part of Born Effective Charges (PAW only)
2217 : : !! pawpiezo= flag for the computation of frozen part of Piezoelectric tensor (PAW only)
2218 : : !! prtbbb=if 1, print the band-by-band decomposition
2219 : : !! prtvol=print volume
2220 : : !! qzero=1 if zero phonon wavevector
2221 : : !! rfdir(3)=defines the directions for the perturbations
2222 : : !! rfmagn= if 1 (2), there are response to uniform (local) spin fields
2223 : : !! rfpert(mpert)=defines the perturbations
2224 : : !! rfphon=if 1, there are phonon perturbations
2225 : : !! rfstrs=if 1,2,3 there are strain perturbations
2226 : : !! typat(natom)=integer label of each type of atom (1,2,...)
2227 : : !! usepaw=1 if PAW, 0 otherwise
2228 : : !! usevdw= flag set to 1 if vdw DFT-D semi-empirical potential is in use
2229 : : !! zion(ntypat)=charge corresponding to the atom type
2230 : : !!
2231 : : !! SIDE EFFECTS
2232 : : !! d2cart_bbb(2,3,3,mpert,mband,mband*prtbbb)
2233 : : !!
2234 : : !! NOTES
2235 : : !! This routine is called only by the processor me==0 .
2236 : : !! In consequence, no use of message and wrtout routine.
2237 : : !!
2238 : : !! SOURCE
2239 : :
2240 : 418 : subroutine dfpt_dyout(becfrnl,berryopt,blkflg,carflg,ddkfil,dyew,dyfrlo,dyfrnl,&
2241 : 418 : & dyfrx1,dyfrx2,dyfr_cplex,dyfr_nondiag,dyvdw,d2cart,d2cart_bbb,&
2242 : 418 : & d2eig0,d2k0,d2lo,d2loc0,d2matr,d2nl,d2nl0,d2nl1,d2ovl,d2vn,&
2243 : 418 : & eltcore,elteew,eltfrhar,eltfrkin,eltfrloc,eltfrnl,eltfrxc,eltvdw,&
2244 : : & has_full_piezo,has_allddk,iout,mband,mpert,natom,ntypat,&
2245 : 418 : & outd2,pawbec,pawpiezo,piezofrnl,prtbbb,prtvol,qzero,typat,rfdir,&
2246 : 418 : & rfmagn,rfpert,rfphon,rfstrs,usepaw,usevdw,zion)
2247 : :
2248 : : !Arguments -------------------------------
2249 : : !scalars
2250 : : integer,intent(in) :: berryopt,dyfr_cplex,dyfr_nondiag,iout,mband,mpert
2251 : : integer,intent(in) :: natom,ntypat,outd2,pawbec,pawpiezo,prtbbb,prtvol,qzero
2252 : : integer, intent(in) :: rfmagn,rfphon,rfstrs,usepaw,usevdw
2253 : : !arrays
2254 : : integer,intent(in) :: blkflg(3,mpert,3,mpert),carflg(3,mpert,3,mpert)
2255 : : integer,intent(in) :: ddkfil(3),rfdir(3),rfpert(mpert),typat(natom)
2256 : : real(dp),intent(in) :: becfrnl(3,natom,3*pawbec)
2257 : : real(dp),intent(in) :: d2cart(2,3,mpert,3,mpert),d2eig0(2,3,mpert,3,mpert)
2258 : : real(dp),intent(in) :: d2k0(2,3,mpert,3,mpert),d2lo(2,3,mpert,3,mpert)
2259 : : real(dp),intent(in) :: d2loc0(2,3,mpert,3,mpert),d2matr(2,3,mpert,3,mpert)
2260 : : real(dp),intent(in) :: d2nl(2,3,mpert,3,mpert),d2nl0(2,3,mpert,3,mpert)
2261 : : real(dp),intent(in) :: d2nl1(2,3,mpert,3,mpert),d2ovl(2,3,mpert,3,mpert*usepaw)
2262 : : real(dp),intent(in) :: d2vn(2,3,mpert,3,mpert)
2263 : : real(dp),intent(in) :: dyew(2,3,natom,3,natom),dyfrlo(3,3,natom)
2264 : : real(dp),intent(in) :: dyfrnl(dyfr_cplex,3,3,natom,1+(natom-1)*dyfr_nondiag)
2265 : : real(dp),intent(in) :: dyfrx1(2,3,natom,3,natom),dyfrx2(3,3,natom)
2266 : : real(dp),intent(in) :: dyvdw(2,3,natom,3,natom*usevdw)
2267 : : real(dp),intent(in) :: eltcore(6,6),elteew(6+3*natom,6)
2268 : : real(dp),intent(in) :: eltfrhar(6,6),eltfrkin(6,6),eltfrloc(6+3*natom,6)
2269 : : real(dp),intent(in) :: eltfrnl(6+3*natom,6),eltfrxc(6+3*natom,6)
2270 : : real(dp),intent(in) :: eltvdw(6+3*natom,6*usevdw),piezofrnl(6,3*pawpiezo)
2271 : : real(dp),intent(in) :: zion(ntypat)
2272 : : real(dp),intent(inout) :: d2cart_bbb(2,3,3,mpert,mband,mband*prtbbb)
2273 : : logical,intent(in) :: has_allddk,has_full_piezo
2274 : :
2275 : : !Local variables -------------------------
2276 : : !scalars
2277 : : integer :: iband,idir1,idir2,ii,ipert1,ipert2,jj,nelmts,nline
2278 : : real(dp) :: zi,zr
2279 : : !arrays
2280 : : real(dp) :: delta(3,3)
2281 : :
2282 : : ! *********************************************************************
2283 : :
2284 : : ! GA: As much as I can tell, the option outd2 is always set to 1. This variable should be removed
2285 : :
2286 : : !Long print : includes detail of every part of the 2nd-order energy
2287 [ + + ]: 418 : if(prtvol>=10)then
2288 : :
2289 : : ! In case of phonon
2290 [ + + ]: 33 : if (rfphon==1)then
2291 : :
2292 : : ! write the Ewald part of the dynamical matrix
2293 : 28 : write(iout,*)' '
2294 : 28 : write(iout,*)' Ewald part of the dynamical matrix'
2295 : 28 : write(iout,*)' j1 j2 matrix element'
2296 : 28 : write(iout,*)' dir pert dir pert real part imaginary part'
2297 [ + + ]: 95 : do ipert1=1,natom
2298 [ + + ]: 296 : do idir1=1,3
2299 [ + + + + : 268 : if ( (rfpert(ipert1)==1.and.rfdir(idir1)==1) .or. outd2==1) then
+ - ]
2300 : 201 : write(iout,*)' '
2301 [ + + ]: 762 : do ipert2=1,natom
2302 [ + + ]: 2445 : do idir2=1,3
2303 [ + + + + ]: 2244 : if (rfpert(ipert2)==1.and.rfdir(idir2)==1)then
2304 : 1395 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
2305 : 1395 : dyew(1,idir1,ipert1,idir2,ipert2),&
2306 : 2790 : dyew(2,idir1,ipert1,idir2,ipert2)
2307 : : end if
2308 : : end do
2309 : : end do
2310 : : end if
2311 : : end do
2312 : : end do
2313 : :
2314 : : ! Now the local frozen wf part
2315 : 28 : write(iout,*)' '
2316 : 28 : write(iout,*)' Frozen wf local part of the dynamical matrix'
2317 : 28 : write(iout,*)' j1 j2 matrix element'
2318 : 28 : write(iout,*)' dir pert dir pert real part imaginary part'
2319 [ + + ]: 95 : do ipert1=1,natom
2320 [ + + ]: 296 : do idir1=1,3
2321 [ + + + + : 268 : if ( (rfpert(ipert1)==1.and.rfdir(idir1)==1) .or. outd2==1) then
+ - ]
2322 : 201 : write(iout,*)' '
2323 [ + + ]: 762 : do ipert2=1,natom
2324 [ + + ]: 2445 : do idir2=1,3
2325 [ + + + + ]: 2244 : if(rfpert(ipert2)==1.and.rfdir(idir2)==1)then
2326 [ + + ]: 1395 : if(ipert1==ipert2)then
2327 : 459 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,dyfrlo(idir1,idir2,ipert2),zero
2328 : : else
2329 : 936 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,zero,zero
2330 : : end if
2331 : : end if
2332 : : end do
2333 : : end do
2334 : : end if
2335 : : end do
2336 : : end do
2337 : :
2338 : : ! Now the nonlo frozen wf part
2339 : 28 : write(iout,*)' '
2340 : 28 : write(iout,*)' Frozen wf non-local part of the dynamical matrix'
2341 : 28 : write(iout,*)' j1 j2 matrix element'
2342 : 28 : write(iout,*)' dir pert dir pert real part imaginary part'
2343 [ + + ]: 95 : do ipert1=1,natom
2344 [ + + ]: 296 : do idir1=1,3
2345 [ + + + + : 268 : if ( (rfpert(ipert1)==1.and.rfdir(idir1)==1) .or. outd2==1) then
+ - ]
2346 : 201 : write(iout,*)' '
2347 [ + + ]: 762 : do ipert2=1,natom
2348 [ + + ]: 2445 : do idir2=1,3
2349 [ + + + + ]: 2244 : if(rfpert(ipert2)==1.and.rfdir(idir2)==1)then
2350 [ + + + + ]: 1395 : if(ipert1==ipert2.or.dyfr_nondiag==1)then
2351 [ + - ]: 1107 : if (dyfr_cplex==1) then
2352 : 1107 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
2353 : 2214 : dyfrnl(1,idir1,idir2,ipert1,1+(ipert2-1)*dyfr_nondiag),zero
2354 : : else
2355 : 0 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
2356 : 0 : dyfrnl(:,idir1,idir2,ipert1,1+(ipert2-1)*dyfr_nondiag)
2357 : : end if
2358 : : else
2359 : 288 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,zero,zero
2360 : : end if
2361 : : end if
2362 : : end do
2363 : : end do
2364 : : end if
2365 : : end do
2366 : : end do
2367 : :
2368 : : ! Now the nonlinear xc core correction(1) part
2369 : 28 : write(iout,*)' '
2370 : 28 : write(iout,*)' Frozen wf xc core (1) part',' of the dynamical matrix'
2371 : 28 : write(iout,*)' j1 j2 matrix element'
2372 : 28 : write(iout,*)' dir pert dir pert real part imaginary part'
2373 [ + + ]: 95 : do ipert1=1,natom
2374 [ + + ]: 296 : do idir1=1,3
2375 [ + + + + : 268 : if ( (rfpert(ipert1)==1.and.rfdir(idir1)==1) .or. outd2==1) then
+ - ]
2376 : 201 : write(iout,*)' '
2377 [ + + ]: 762 : do ipert2=1,natom
2378 [ + + ]: 2445 : do idir2=1,3
2379 [ + + + + ]: 2244 : if (rfpert(ipert2)==1.and.rfdir(idir2)==1)then
2380 : 1395 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
2381 : 1395 : dyfrx1(1,idir1,ipert1,idir2,ipert2),&
2382 : 2790 : dyfrx1(2,idir1,ipert1,idir2,ipert2)
2383 : : end if
2384 : : end do
2385 : : end do
2386 : : end if
2387 : : end do
2388 : : end do
2389 : :
2390 : : ! Now the nonlinear xc core correction(2) part
2391 : 28 : write(iout,*)' '
2392 : 28 : write(iout,*)' Frozen wf xc core (2) part',' of the dynamical matrix'
2393 : 28 : write(iout,*)' j1 j2 matrix element'
2394 : 28 : write(iout,*)' dir pert dir pert real part imaginary part'
2395 [ + + ]: 95 : do ipert1=1,natom
2396 [ + + ]: 296 : do idir1=1,3
2397 [ + + + + : 268 : if ( (rfpert(ipert1)==1.and.rfdir(idir1)==1) .or. outd2==1) then
+ - ]
2398 : 201 : write(iout,*)' '
2399 [ + + ]: 762 : do ipert2=1,natom
2400 [ + + ]: 2445 : do idir2=1,3
2401 [ + + + + ]: 2244 : if(rfpert(ipert2)==1.and.rfdir(idir2)==1)then
2402 [ + + ]: 1395 : if(ipert1==ipert2)then
2403 : 459 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,dyfrx2(idir1,idir2,ipert2),zero
2404 : : else
2405 : 936 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,zero,zero
2406 : : end if
2407 : : end if
2408 : : end do
2409 : : end do
2410 : : end if
2411 : : end do
2412 : : end do
2413 : :
2414 : : ! Now the DFT-D vdw part of the dynamical matrix
2415 [ - + ]: 28 : if (usevdw==1) then
2416 : 0 : write(iout,*)' '
2417 : 0 : write(iout,*)' DFT-D van der Waals part of the dynamical matrix'
2418 : 0 : write(iout,*)' j1 j2 matrix element'
2419 : 0 : write(iout,*)' dir pert dir pert real part imaginary part'
2420 [ # # ]: 0 : do ipert1=1,natom
2421 [ # # ]: 0 : do idir1=1,3
2422 [ # # # # : 0 : if ( (rfpert(ipert1)==1.and.rfdir(idir1)==1) .or. outd2==1) then
# # ]
2423 : 0 : write(iout,*)' '
2424 [ # # ]: 0 : do ipert2=1,natom
2425 [ # # ]: 0 : do idir2=1,3
2426 [ # # # # ]: 0 : if (rfpert(ipert2)==1.and.rfdir(idir2)==1)then
2427 : 0 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
2428 : 0 : dyvdw(1,idir1,ipert1,idir2,ipert2),&
2429 : 0 : dyvdw(2,idir1,ipert1,idir2,ipert2)
2430 : : end if
2431 : : end do
2432 : : end do
2433 : : end if
2434 : : end do
2435 : : end do
2436 : : end if
2437 : :
2438 : : ! End of the phonon condition
2439 : : end if
2440 : :
2441 : : ! In case of atom. strain/electric field perturbation (piezoelectric tensor)
2442 [ + + + + : 33 : if (pawpiezo==1.and.(rfpert(natom+2)==1.or.rfstrs/=0).and.outd2==1)then
+ - + - ]
2443 : 8 : write(iout,*)' '
2444 : 8 : write(iout,*)' Frozen wf part of the piezoelectric tensor'
2445 : 8 : write(iout,*)' j1 j2 matrix element'
2446 : 8 : write(iout,*)' dir pert dir pert real part imaginary part'
2447 : 8 : ipert1=natom+2
2448 [ + + ]: 32 : do idir1=1,3
2449 : 24 : write(iout,*)' '
2450 : 24 : ii=1
2451 [ + + ]: 80 : do ipert2=natom+3,natom+4
2452 [ + + ]: 216 : do idir2=1,3
2453 : 144 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,piezofrnl(ii,idir1),zero
2454 : 192 : ii=ii+1
2455 : : end do
2456 : : end do
2457 : : end do
2458 : : end if
2459 : :
2460 : : ! In case of atom. displ/electric field perturbation (Born Effective Charges)
2461 [ + + + + : 33 : if (pawbec==1.and.(rfpert(natom+2)==1.or.rfphon==1).and.outd2==1)then
+ - + - ]
2462 : 8 : write(iout,*)' '
2463 : 8 : write(iout,*)' Frozen wf part of the Born Effective Charges'
2464 : 8 : write(iout,*)' j1 j2 matrix element'
2465 : 8 : write(iout,*)' dir pert dir pert real part imaginary part'
2466 : 8 : ipert1 = natom+2
2467 [ + + ]: 34 : do ipert2=1,natom
2468 [ + + ]: 112 : do idir1=1,3
2469 : 78 : write(iout,*)' '
2470 [ + + ]: 338 : do idir2=1,3
2471 : 312 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,becfrnl(idir2,ipert2,idir1),zero
2472 : : end do
2473 : : end do
2474 : : end do
2475 : : end if
2476 : :
2477 : : ! In case of strain
2478 [ + + ]: 33 : if (rfstrs/=0)then
2479 : :
2480 : : ! Write the Ewald part of the elastic tensor
2481 : 15 : write(iout,*)' '
2482 : 15 : write(iout,*)' Ewald part of the elastic tensor in cartesian coordinates'
2483 : 15 : write(iout,*)' j1 j2 matrix element'
2484 : 15 : write(iout,*)' dir pert dir pert real part imaginary part'
2485 [ + + ]: 45 : do ipert1=natom+3,natom+4
2486 [ + + ]: 135 : do idir1=1,3
2487 [ + + + + : 120 : if ( (rfpert(ipert1)==1.and.rfdir(idir1)==1) .or. outd2==1) then
+ - ]
2488 : 90 : ii=idir1+3*(ipert1-natom-3)
2489 : 90 : write(iout,*)' '
2490 [ + + ]: 270 : do ipert2=natom+3,natom+4
2491 [ + + ]: 810 : do idir2=1,3
2492 [ + + + + ]: 720 : if (rfpert(ipert2)==1.and.rfdir(idir2)==1)then
2493 : 420 : jj=idir2+3*(ipert2-natom-3)
2494 : 420 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,elteew(ii,jj),zero
2495 : : end if
2496 : : end do
2497 : : end do
2498 : : end if
2499 : : end do
2500 : : end do
2501 : :
2502 : : ! Write the Ewald part of the internal strain coupling parameters
2503 : 15 : write(iout,*)' '
2504 : 15 : write(iout,*)' Ewald part of the internal strain coupling parameters'
2505 : 15 : write(iout,*)' (cartesian strain, reduced atomic coordinates)'
2506 : 15 : write(iout,*)' j1 j2 matrix element'
2507 : 15 : write(iout,*)' dir pert dir pert real part imaginary part'
2508 [ + + ]: 58 : do ipert1=1,natom
2509 [ + + ]: 187 : do idir1=1,3
2510 [ + + - + : 172 : if ( (rfpert(ipert1)==1.and.rfdir(idir1)==1) .or. outd2==1) then
+ - ]
2511 : 129 : ii=idir1+6+3*(ipert1-1)
2512 : 129 : write(iout,*)' '
2513 [ + + ]: 387 : do ipert2=natom+3,natom+4
2514 [ + + ]: 1161 : do idir2=1,3
2515 [ + + + + ]: 1032 : if (rfpert(ipert2)==1.and.rfdir(idir2)==1)then
2516 : 642 : jj=idir2+3*(ipert2-natom-3)
2517 : 642 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,elteew(ii,jj),zero
2518 : : end if
2519 : : end do
2520 : : end do
2521 : : end if
2522 : : end do
2523 : : end do
2524 : :
2525 : : ! Now the local frozen wf part
2526 : 15 : write(iout,*)' '
2527 : 15 : write(iout,*)' Frozen wf local part of the elastic tensor in cartesian coordinates'
2528 : 15 : write(iout,*)' j1 j2 matrix element'
2529 : 15 : write(iout,*)' dir pert dir pert real part imaginary part'
2530 [ + + ]: 45 : do ipert1=natom+3,natom+4
2531 [ + + ]: 135 : do idir1=1,3
2532 [ + + + + : 120 : if ( (rfpert(ipert1)==1.and.rfdir(idir1)==1) .or. outd2==1) then
+ - ]
2533 : 90 : ii=idir1+3*(ipert1-natom-3)
2534 : 90 : write(iout,*)' '
2535 [ + + ]: 270 : do ipert2=natom+3,natom+4
2536 [ + + ]: 810 : do idir2=1,3
2537 [ + + + + ]: 720 : if (rfpert(ipert2)==1.and.rfdir(idir2)==1)then
2538 : 420 : jj=idir2+3*(ipert2-natom-3)
2539 : 420 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2, eltfrloc(ii,jj),zero
2540 : : end if
2541 : : end do
2542 : : end do
2543 : : end if
2544 : : end do
2545 : : end do
2546 : :
2547 : 15 : write(iout,*)' '
2548 : 15 : write(iout,*)' Frozen wf local part of the internal strain coupling parameters '
2549 : 15 : write(iout,*)' (cartesian strain, reduced atomic coordinates)'
2550 : 15 : write(iout,*)' j1 j2 matrix element'
2551 : 15 : write(iout,*)' dir pert dir pert real part imaginary part'
2552 [ + + ]: 58 : do ipert1=1,natom
2553 [ + + ]: 187 : do idir1=1,3
2554 [ + + - + : 172 : if ( (rfpert(ipert1)==1.and.rfdir(idir1)==1) .or. outd2==1) then
+ - ]
2555 : 129 : ii=idir1+6+3*(ipert1-1)
2556 : 129 : write(iout,*)' '
2557 [ + + ]: 387 : do ipert2=natom+3,natom+4
2558 [ + + ]: 1161 : do idir2=1,3
2559 [ + + + + ]: 1032 : if (rfpert(ipert2)==1.and.rfdir(idir2)==1)then
2560 : 642 : jj=idir2+3*(ipert2-natom-3)
2561 : 642 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2, eltfrloc(ii,jj),zero
2562 : : end if
2563 : : end do
2564 : : end do
2565 : : end if
2566 : : end do
2567 : : end do
2568 : :
2569 : : ! Now the nonlo frozen wf part
2570 : 15 : write(iout,*)' '
2571 : 15 : write(iout,*)' Frozen wf nonlocal part of the elastic tensor in cartesian coordinates'
2572 : 15 : write(iout,*)' j1 j2 matrix element'
2573 : 15 : write(iout,*)' dir pert dir pert real part imaginary part'
2574 [ + + ]: 45 : do ipert1=natom+3,natom+4
2575 [ + + ]: 135 : do idir1=1,3
2576 [ + + + + : 120 : if ( (rfpert(ipert1)==1.and.rfdir(idir1)==1) .or. outd2==1) then
+ - ]
2577 : 90 : ii=idir1+3*(ipert1-natom-3)
2578 : 90 : write(iout,*)' '
2579 [ + + ]: 270 : do ipert2=natom+3,natom+4
2580 [ + + ]: 810 : do idir2=1,3
2581 [ + + + + ]: 720 : if (rfpert(ipert2)==1.and.rfdir(idir2)==1)then
2582 : 420 : jj=idir2+3*(ipert2-natom-3)
2583 : 420 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2, eltfrnl(ii,jj),zero
2584 : : end if
2585 : : end do
2586 : : end do
2587 : : end if
2588 : : end do
2589 : : end do
2590 : :
2591 : 15 : write(iout,*)' '
2592 : 15 : write(iout,*)' Frozen wf nonlocal part of the internal strain coupling parameters '
2593 : 15 : write(iout,*)' (cartesian strain, reduced atomic coordinates)'
2594 : 15 : write(iout,*)' j1 j2 matrix element'
2595 : 15 : write(iout,*)' dir pert dir pert real part imaginary part'
2596 [ + + ]: 58 : do ipert1=1,natom
2597 [ + + ]: 187 : do idir1=1,3
2598 [ + + - + : 172 : if ( (rfpert(ipert1)==1.and.rfdir(idir1)==1) .or. outd2==1) then
+ - ]
2599 : 129 : ii=idir1+6+3*(ipert1-1)
2600 : 129 : write(iout,*)' '
2601 [ + + ]: 387 : do ipert2=natom+3,natom+4
2602 [ + + ]: 1161 : do idir2=1,3
2603 [ + + + + ]: 1032 : if (rfpert(ipert2)==1.and.rfdir(idir2)==1)then
2604 : 642 : jj=idir2+3*(ipert2-natom-3)
2605 : 642 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,eltfrnl(ii,jj),zero
2606 : : end if
2607 : : end do
2608 : : end do
2609 : : end if
2610 : : end do
2611 : : end do
2612 : :
2613 : : ! Now the xc part
2614 : 15 : write(iout,*)' '
2615 : 15 : write(iout,*)' Frozen wf xc part of the elastic tensor in cartesian coordinates'
2616 : 15 : write(iout,*)' j1 j2 matrix element'
2617 : 15 : write(iout,*)' dir pert dir pert real part imaginary part'
2618 [ + + ]: 45 : do ipert1=natom+3,natom+4
2619 [ + + ]: 135 : do idir1=1,3
2620 [ + + + + : 120 : if ( (rfpert(ipert1)==1.and.rfdir(idir1)==1) .or. outd2==1) then
+ - ]
2621 : 90 : ii=idir1+3*(ipert1-natom-3)
2622 : 90 : write(iout,*)' '
2623 [ + + ]: 270 : do ipert2=natom+3,natom+4
2624 [ + + ]: 810 : do idir2=1,3
2625 [ + + + + ]: 720 : if (rfpert(ipert2)==1.and.rfdir(idir2)==1)then
2626 : 420 : jj=idir2+3*(ipert2-natom-3)
2627 : 420 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2, eltfrxc(ii,jj),zero
2628 : : end if
2629 : : end do
2630 : : end do
2631 : : end if
2632 : : end do
2633 : : end do
2634 : :
2635 : 15 : write(iout,*)' '
2636 : 15 : write(iout,*)' Frozen wf xc part of the internal strain coupling parameters '
2637 : 15 : write(iout,*)' (cartesian strain, reduced atomic coordinates)'
2638 : 15 : write(iout,*)' j1 j2 matrix element'
2639 : 15 : write(iout,*)' dir pert dir pert real part imaginary part'
2640 [ + + ]: 58 : do ipert1=1,natom
2641 [ + + ]: 187 : do idir1=1,3
2642 [ + + - + : 172 : if ( (rfpert(ipert1)==1.and.rfdir(idir1)==1) .or. outd2==1) then
+ - ]
2643 : 129 : ii=idir1+6+3*(ipert1-1)
2644 : 129 : write(iout,*)' '
2645 [ + + ]: 387 : do ipert2=natom+3,natom+4
2646 [ + + ]: 1161 : do idir2=1,3
2647 [ + + + + ]: 1032 : if (rfpert(ipert2)==1.and.rfdir(idir2)==1)then
2648 : 642 : jj=idir2+3*(ipert2-natom-3)
2649 : 642 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,eltfrxc(ii,jj),zero
2650 : : end if
2651 : : end do
2652 : : end do
2653 : : end if
2654 : : end do
2655 : : end do
2656 : :
2657 : : ! Now the kinetic frozen wf part
2658 : 15 : write(iout,*)' '
2659 : 15 : write(iout,*)' Frozen wf kinetic part of the elastic tensor in cartesian coordinates'
2660 : 15 : write(iout,*)' j1 j2 matrix element'
2661 : 15 : write(iout,*)' dir pert dir pert real part imaginary part'
2662 [ + + ]: 45 : do ipert1=natom+3,natom+4
2663 [ + + ]: 135 : do idir1=1,3
2664 [ + + + + : 120 : if ( (rfpert(ipert1)==1.and.rfdir(idir1)==1) .or. outd2==1) then
+ - ]
2665 : 90 : ii=idir1+3*(ipert1-natom-3)
2666 : 90 : write(iout,*)' '
2667 [ + + ]: 270 : do ipert2=natom+3,natom+4
2668 [ + + ]: 810 : do idir2=1,3
2669 [ + + + + ]: 720 : if (rfpert(ipert2)==1.and.rfdir(idir2)==1)then
2670 : 420 : jj=idir2+3*(ipert2-natom-3)
2671 : 420 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,eltfrkin(ii,jj),zero
2672 : : end if
2673 : : end do
2674 : : end do
2675 : : end if
2676 : : end do
2677 : : end do
2678 : :
2679 : : ! Now the hartree frozen wf part
2680 : 15 : write(iout,*)' '
2681 : 15 : write(iout,*)' Frozen wf hartree part of the elastic tensor in cartesian coordinates'
2682 : 15 : write(iout,*)' j1 j2 matrix element'
2683 : 15 : write(iout,*)' dir pert dir pert real part imaginary part'
2684 [ + + ]: 45 : do ipert1=natom+3,natom+4
2685 [ + + ]: 135 : do idir1=1,3
2686 [ + + + + : 120 : if ( (rfpert(ipert1)==1.and.rfdir(idir1)==1) .or. outd2==1) then
+ - ]
2687 : 90 : ii=idir1+3*(ipert1-natom-3)
2688 : 90 : write(iout,*)' '
2689 [ + + ]: 270 : do ipert2=natom+3,natom+4
2690 [ + + ]: 810 : do idir2=1,3
2691 [ + + + + ]: 720 : if (rfpert(ipert2)==1.and.rfdir(idir2)==1)then
2692 : 420 : jj=idir2+3*(ipert2-natom-3)
2693 : 420 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2, eltfrhar(ii,jj),zero
2694 : : end if
2695 : : end do
2696 : : end do
2697 : : end if
2698 : : end do
2699 : : end do
2700 : :
2701 : : ! Now the psp core part
2702 : 15 : write(iout,*)' '
2703 : 15 : write(iout,*)' Psp core part of the elastic tensor in cartesian coordinates'
2704 : 15 : write(iout,*)' j1 j2 matrix element'
2705 : 15 : write(iout,*)' dir pert dir pert real part imaginary part'
2706 [ + + ]: 45 : do ipert1=natom+3,natom+4
2707 [ + + ]: 135 : do idir1=1,3
2708 [ + + + + : 120 : if ( (rfpert(ipert1)==1.and.rfdir(idir1)==1) .or. outd2==1) then
+ - ]
2709 : 90 : ii=idir1+3*(ipert1-natom-3)
2710 : 90 : write(iout,*)' '
2711 [ + + ]: 270 : do ipert2=natom+3,natom+4
2712 [ + + ]: 810 : do idir2=1,3
2713 [ + + + + ]: 720 : if (rfpert(ipert2)==1.and.rfdir(idir2)==1)then
2714 : 420 : jj=idir2+3*(ipert2-natom-3)
2715 : 420 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,eltcore(ii,jj),zero
2716 : : end if
2717 : : end do
2718 : : end do
2719 : : end if
2720 : : end do
2721 : : end do
2722 : :
2723 : : ! Now the DFT-D vdw part
2724 [ - + ]: 15 : if (usevdw==1) then
2725 : 0 : write(iout,*)' '
2726 : 0 : write(iout,*)' DFT-D van der Waals part of the elastic tensor in cartesian coordinates'
2727 : 0 : write(iout,*)' j1 j2 matrix element'
2728 : 0 : write(iout,*)' dir pert dir pert real part imaginary part'
2729 [ # # ]: 0 : do ipert1=natom+3,natom+4
2730 [ # # ]: 0 : do idir1=1,3
2731 [ # # # # : 0 : if ( (rfpert(ipert1)==1.and.rfdir(idir1)==1) .or. outd2==1)then
# # ]
2732 : 0 : ii=idir1+3*(ipert1-natom-3)
2733 : 0 : write(iout,*)' '
2734 [ # # ]: 0 : do ipert2=natom+3,natom+4
2735 [ # # ]: 0 : do idir2=1,3
2736 [ # # # # ]: 0 : if (rfpert(ipert2)==1.and.rfdir(idir2)==1)then
2737 : 0 : jj=idir2+3*(ipert2-natom-3)
2738 : 0 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,eltvdw(ii,jj),zero
2739 : : end if
2740 : : end do
2741 : : end do
2742 : : end if
2743 : : end do
2744 : : end do
2745 : :
2746 : 0 : write(iout,*)' '
2747 : 0 : write(iout,*)' DFT-D2 van der Waals part of the internal strain coupling parameters'
2748 : 0 : write(iout,*)' (cartesian strain, reduced atomic coordinates)'
2749 : 0 : write(iout,*)' j1 j2 matrix element'
2750 : 0 : write(iout,*)' dir pert dir pert real part imaginary part'
2751 [ # # ]: 0 : do ipert1=1,natom
2752 [ # # ]: 0 : do idir1=1,3
2753 [ # # # # : 0 : if ( (rfpert(ipert1)==1.and.rfdir(idir1)==1) .or. outd2==1 )then
# # ]
2754 : 0 : ii=idir1+6+3*(ipert1-1)
2755 : 0 : write(iout,*)' '
2756 [ # # ]: 0 : do ipert2=natom+3,natom+4
2757 [ # # ]: 0 : do idir2=1,3
2758 [ # # # # ]: 0 : if (rfpert(ipert2)==1.and.rfdir(idir2)==1)then
2759 : 0 : jj=idir2+3*(ipert2-natom-3)
2760 : 0 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,eltvdw(ii,jj),zero
2761 : : end if
2762 : : end do
2763 : : end do
2764 : : end if
2765 : : end do
2766 : : end do
2767 : : end if ! usevdw
2768 : :
2769 : : end if ! strain condition
2770 : :
2771 : : ! Now the local nonstationary nonfrozenwf part
2772 [ + - ]: 33 : if (outd2==1)then
2773 : 33 : write(iout,*)' '
2774 : 33 : write(iout,*)' Non-stationary local part of the 2-order matrix'
2775 : 33 : write(iout,*)' j1 j2 matrix element'
2776 : 33 : write(iout,*)' dir pert dir pert real part imaginary part'
2777 [ + + ]: 342 : do ipert1=1,mpert
2778 [ + + ]: 1269 : do idir1=1,3
2779 : : if ((ipert1<=natom .or.&
2780 [ + + + + : 927 : & (ipert1==natom+2.and.qzero==1.and.ddkfil(idir1)/=0)).or.&
+ + + + +
+ + + + +
+ - ]
2781 : : & ((ipert1==natom+3.or.ipert1==natom+4).and.&
2782 : 309 : & (rfpert(natom+3)==1.or.rfpert(natom+4)==1)))then
2783 : 346 : write(iout,*)' '
2784 [ + + ]: 3748 : do ipert2=1,mpert
2785 [ + + ]: 14535 : do idir2=1,3
2786 [ + + + + ]: 13608 : if(rfpert(ipert2)==1.and.rfdir(idir2)==1)then
2787 : 3668 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
2788 : 3668 : & d2lo(1,idir1,ipert1,idir2,ipert2),&
2789 : 7336 : & d2lo(2,idir1,ipert1,idir2,ipert2)
2790 : : end if
2791 : : end do
2792 : : end do
2793 : : end if
2794 : : end do
2795 : : end do
2796 : : end if
2797 : :
2798 : : ! Now the nonlocal nonstationary nonfrozenwf part
2799 [ + - ]: 33 : if (outd2==1)then
2800 : 33 : write(iout,*)' '
2801 : 33 : write(iout,*)' Non-stationary non-local part of the 2nd-order matrix'
2802 : 33 : write(iout,*)' j1 j2 matrix element'
2803 : 33 : write(iout,*)' dir pert dir pert real part imaginary part'
2804 [ + + ]: 342 : do ipert1=1,mpert
2805 [ + + ]: 1269 : do idir1=1,3
2806 : : if ((ipert1<=natom .or.&
2807 [ + + + + : 927 : & (ipert1==natom+2.and.qzero==1.and.ddkfil(idir1)/=0)).or.&
+ + + + +
+ + + + +
+ - ]
2808 : : & ((ipert1==natom+3.or.ipert1==natom+4).and.&
2809 : 309 : & (rfpert(natom+3)==1.or.rfpert(natom+4)==1)))then
2810 : 346 : write(iout,*)' '
2811 [ + + ]: 3748 : do ipert2=1,mpert
2812 [ + + ]: 14535 : do idir2=1,3
2813 [ + + + + ]: 13608 : if(rfpert(ipert2)==1.and.rfdir(idir2)==1)then
2814 : 3668 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
2815 : 3668 : & d2nl(1,idir1,ipert1,idir2,ipert2),&
2816 : 7336 : & d2nl(2,idir1,ipert1,idir2,ipert2)
2817 : : end if
2818 : : end do
2819 : : end do
2820 : : end if
2821 : : end do
2822 : : end do
2823 : : end if
2824 : :
2825 : : ! Now the overlap change nonstationnary nonfrozenwf part (PAW only)
2826 [ + - + + ]: 33 : if (outd2==1.and.usepaw==1)then
2827 : 8 : write(iout,*)' '
2828 : 8 : write(iout,*)' PAW: Non-stationary WF-overlap part of the 2nd-order matrix'
2829 : 8 : write(iout,*)' j1 j2 matrix element'
2830 : 8 : write(iout,*)' dir pert dir pert real part imaginary part'
2831 [ + + ]: 90 : do ipert1=1,mpert
2832 [ + + ]: 336 : do idir1=1,3
2833 : : if ((ipert1<=natom .or.&
2834 [ + + + + : 246 : & (ipert1==natom+2.and.qzero==1.and.ddkfil(idir1)/=0)).or.&
+ - + + +
+ + + - +
- - ]
2835 : : & ((ipert1==natom+3.or.ipert1==natom+4).and.&
2836 : 82 : & (rfpert(natom+3)==1.or.rfpert(natom+4)==1)))then
2837 : 138 : write(iout,*)' '
2838 [ + + ]: 1602 : do ipert2=1,mpert
2839 [ + + ]: 6102 : do idir2=1,3
2840 [ + + + - ]: 5856 : if(rfpert(ipert2)==1.and.rfdir(idir2)==1)then
2841 : 2574 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
2842 : 2574 : & d2ovl(1,idir1,ipert1,idir2,ipert2),&
2843 : 5148 : & d2ovl(2,idir1,ipert1,idir2,ipert2)
2844 : : end if
2845 : : end do
2846 : : end do
2847 : : end if
2848 : : end do
2849 : : end do
2850 : : end if
2851 : :
2852 : : ! Now the 0-order local stationary nonfrozenwf part
2853 [ - + ]: 33 : if (outd2==2)then
2854 : 0 : write(iout,*)' '
2855 : 0 : write(iout,*)' Stationary 0-order local part of the 2nd-order matrix'
2856 : 0 : write(iout,*)' j1 j2 matrix element'
2857 : 0 : write(iout,*)' dir pert dir pert real part imaginary part'
2858 [ # # ]: 0 : do ipert1=1,mpert
2859 [ # # ]: 0 : do idir1=1,3
2860 [ # # # # ]: 0 : if(rfpert(ipert1)==1.and.rfdir(idir1)==1)then
2861 : 0 : write(iout,*)' '
2862 [ # # ]: 0 : do ipert2=1,mpert
2863 [ # # ]: 0 : do idir2=1,3
2864 [ # # # # ]: 0 : if(rfpert(ipert2)==1.and.rfdir(idir2)==1)then
2865 : 0 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
2866 : 0 : & d2loc0(1,idir1,ipert1,idir2,ipert2),&
2867 : 0 : & d2loc0(2,idir1,ipert1,idir2,ipert2)
2868 : : end if
2869 : : end do
2870 : : end do
2871 : : end if
2872 : : end do
2873 : : end do
2874 : : end if
2875 : :
2876 : : ! Now the stationary 0-order kinetic nonfrozenwf part
2877 [ - + ]: 33 : if (outd2==2)then
2878 : 0 : write(iout,*)' '
2879 : 0 : write(iout,*)' Stationary 0-order kinetic part of the 2nd-order matrix'
2880 : 0 : write(iout,*)' j1 j2 matrix element'
2881 : 0 : write(iout,*)' dir pert dir pert real part imaginary part'
2882 [ # # ]: 0 : do ipert1=1,mpert
2883 [ # # ]: 0 : do idir1=1,3
2884 [ # # # # ]: 0 : if(rfpert(ipert1)==1.and.rfdir(idir1)==1)then
2885 : 0 : write(iout,*)' '
2886 [ # # ]: 0 : do ipert2=1,mpert
2887 [ # # ]: 0 : do idir2=1,3
2888 [ # # # # ]: 0 : if(rfpert(ipert2)==1.and.rfdir(idir2)==1)then
2889 : 0 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
2890 : 0 : & d2k0(1,idir1,ipert1,idir2,ipert2),&
2891 : 0 : & d2k0(2,idir1,ipert1,idir2,ipert2)
2892 : : end if
2893 : : end do
2894 : : end do
2895 : : end if
2896 : : end do
2897 : : end do
2898 : : end if
2899 : :
2900 : : ! Now the stationary 0-order eigenvalue nonfrozenwf part
2901 [ - + ]: 33 : if (outd2==2)then
2902 : 0 : write(iout,*)' '
2903 : 0 : write(iout,*)' Stationary 0-order eigenvalue part of the' ,' 2nd-order matrix'
2904 : 0 : write(iout,*)' j1 j2 matrix element'
2905 : 0 : write(iout,*)' dir pert dir pert real part imaginary part'
2906 [ # # ]: 0 : do ipert1=1,mpert
2907 [ # # ]: 0 : do idir1=1,3
2908 [ # # # # ]: 0 : if(rfpert(ipert1)==1.and.rfdir(idir1)==1) then
2909 : 0 : write(iout,*)' '
2910 [ # # ]: 0 : do ipert2=1,mpert
2911 [ # # ]: 0 : do idir2=1,3
2912 [ # # # # ]: 0 : if(rfpert(ipert2)==1.and.rfdir(idir2)==1) then
2913 : 0 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
2914 : 0 : d2eig0(1,idir1,ipert1,idir2,ipert2),&
2915 : 0 : d2eig0(2,idir1,ipert1,idir2,ipert2)
2916 : : end if
2917 : : end do
2918 : : end do
2919 : : end if
2920 : : end do
2921 : : end do
2922 : : end if
2923 : :
2924 : : ! Now the stationary potential-density nonfrozenwf part
2925 [ - + ]: 33 : if (outd2==2)then
2926 : 0 : write(iout,*)' '
2927 : 0 : write(iout,*)' Station. potential-density part of the ',&
2928 : 0 : & ' 2nd-order matrix'
2929 : 0 : write(iout,*)' (Note : include some xc core-correction) '
2930 : 0 : write(iout,*)' j1 j2 matrix element'
2931 : 0 : write(iout,*)' dir pert dir pert real part imaginary part'
2932 [ # # ]: 0 : do ipert1=1,mpert
2933 [ # # ]: 0 : do idir1=1,3
2934 [ # # # # ]: 0 : if(rfpert(ipert1)==1.and.rfdir(idir1)==1)then
2935 : 0 : write(iout,*)' '
2936 [ # # ]: 0 : do ipert2=1,mpert
2937 [ # # ]: 0 : do idir2=1,3
2938 [ # # # # ]: 0 : if(rfpert(ipert2)==1.and.rfdir(idir2)==1)then
2939 : 0 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
2940 : 0 : & d2vn(1,idir1,ipert1,idir2,ipert2),&
2941 : 0 : & d2vn(2,idir1,ipert1,idir2,ipert2)
2942 : : end if
2943 : : end do
2944 : : end do
2945 : : end if
2946 : : end do
2947 : : end do
2948 : : end if
2949 : :
2950 : : ! Now the stationary 0-order nonloc nonfrozenwf part
2951 [ - + ]: 33 : if (outd2==2)then
2952 : 0 : write(iout,*)' '
2953 : 0 : write(iout,*)' Stationary 0-order nonlocal part of the 2-order'&
2954 : 0 : & ,' matrix'
2955 : 0 : write(iout,*)' j1 j2 matrix element'
2956 : 0 : write(iout,*)' dir pert dir pert real part imaginary part'
2957 [ # # ]: 0 : do ipert1=1,mpert
2958 [ # # ]: 0 : do idir1=1,3
2959 [ # # # # ]: 0 : if(rfpert(ipert1)==1.and.rfdir(idir1)==1)then
2960 : 0 : write(iout,*)' '
2961 [ # # ]: 0 : do ipert2=1,mpert
2962 [ # # ]: 0 : do idir2=1,3
2963 [ # # # # ]: 0 : if(rfpert(ipert2)==1.and.rfdir(idir2)==1)then
2964 : 0 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
2965 : 0 : & d2nl0(1,idir1,ipert1,idir2,ipert2),&
2966 : 0 : & d2nl0(2,idir1,ipert1,idir2,ipert2)
2967 : : end if
2968 : : end do
2969 : : end do
2970 : : end if
2971 : : end do
2972 : : end do
2973 : : end if
2974 : :
2975 : : ! Now the stationary 1-order nonloc nonfrozenwf part
2976 [ - + ]: 33 : if (outd2==2)then
2977 : 0 : write(iout,*)' '
2978 : 0 : write(iout,*)' Stationary 1-order nonlocal part of the'&
2979 : 0 : & ,' 2nd-order matrix'
2980 : 0 : write(iout,*)' (or the ddk wf part of it, in case of',&
2981 : 0 : & ' an electric field perturbation )'
2982 : 0 : write(iout,*)' j1 j2 matrix element'
2983 : 0 : write(iout,*)' dir pert dir pert real part imaginary part'
2984 [ # # ]: 0 : do ipert1=1,mpert
2985 [ # # ]: 0 : do idir1=1,3
2986 [ # # # # ]: 0 : if(rfpert(ipert1)==1.and.rfdir(idir1)==1)then
2987 : 0 : write(iout,*)' '
2988 [ # # ]: 0 : do ipert2=1,mpert
2989 [ # # ]: 0 : do idir2=1,3
2990 [ # # # # ]: 0 : if(rfpert(ipert2)==1.and.rfdir(idir2)==1)then
2991 : 0 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
2992 : 0 : & d2nl1(1,idir1,ipert1,idir2,ipert2),&
2993 : 0 : & d2nl1(2,idir1,ipert1,idir2,ipert2)
2994 : : end if
2995 : : end do
2996 : : end do
2997 : : end if
2998 : : end do
2999 : : end do
3000 : : end if
3001 : :
3002 : : ! End of the long print out condition
3003 : : end if
3004 : :
3005 : :
3006 : : !Derivative database initialisation
3007 : :
3008 : : !Calculation of the number of elements
3009 : 418 : nelmts=0
3010 [ + + ]: 4271 : do ipert1=1,mpert
3011 [ + + ]: 15830 : do idir1=1,3
3012 [ + + ]: 127909 : do ipert2=1,mpert
3013 [ + + ]: 461547 : do idir2=1,3
3014 : 449988 : nelmts=nelmts+blkflg(idir1,ipert1,idir2,ipert2)
3015 : : end do
3016 : : end do
3017 : : end do
3018 : : end do
3019 : :
3020 : : !Now the whole 2nd-order matrix, but not in cartesian coordinates,
3021 : : !and masses not included
3022 : 418 : write(iout,*)' '
3023 : 418 : write(iout,*)' 2nd-order matrix (non-cartesian coordinates,',' masses not included,'
3024 : 418 : write(iout,*)' asr not included )'
3025 [ + + ]: 418 : if(rfstrs/=0) then
3026 : 33 : write(iout,*)' cartesian coordinates for strain terms (1/ucvol factor '
3027 : 33 : write(iout,*)' for elastic tensor components not included) '
3028 : : end if
3029 : 418 : write(iout,*)' j1 j2 matrix element'
3030 : 418 : write(iout,*)' dir pert dir pert real part imaginary part'
3031 : 418 : nline=1
3032 [ + + ]: 4271 : do ipert1=1,mpert
3033 [ + + ]: 15830 : do idir1=1,3
3034 [ + + ]: 11559 : if(nline/=0)write(iout,*)' '
3035 : 11559 : nline=0
3036 [ + + ]: 127909 : do ipert2=1,mpert
3037 [ + + ]: 461547 : do idir2=1,3
3038 [ + + ]: 449988 : if(blkflg(idir1,ipert1,idir2,ipert2)==1)then
3039 : 25555 : nline=nline+1
3040 : 25555 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
3041 : 25555 : & d2matr(1,idir1,ipert1,idir2,ipert2),&
3042 : 51110 : & d2matr(2,idir1,ipert1,idir2,ipert2)
3043 : : end if
3044 : : end do
3045 : : end do
3046 : : end do
3047 : : end do
3048 : :
3049 : : !Now the dynamical matrix
3050 [ + + ]: 418 : if(rfphon==1)then
3051 : 382 : write(iout,*)' '
3052 : 382 : write(iout,*)' Dynamical matrix, in cartesian coordinates,'
3053 : 382 : write(iout,*)' if specified in the inputs, asr has been imposed'
3054 : 382 : write(iout,*)' j1 j2 matrix element'
3055 : 382 : write(iout,*)' dir pert dir pert real part imaginary part'
3056 : 382 : nline=1
3057 [ + + ]: 1145 : do ipert1=1,natom
3058 [ + + ]: 3434 : do idir1=1,3
3059 [ + + ]: 2289 : if(nline/=0)write(iout,*)' '
3060 : 2289 : nline=0
3061 [ + + ]: 9421 : do ipert2=1,natom
3062 [ + + ]: 27765 : do idir2=1,3
3063 [ + + ]: 25476 : if(carflg(idir1,ipert1,idir2,ipert2)==1)then
3064 : 14235 : nline=nline+1
3065 : 14235 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
3066 : 14235 : & d2cart(1,idir1,ipert1,idir2,ipert2),&
3067 : 28470 : & d2cart(2,idir1,ipert1,idir2,ipert2)
3068 : : end if
3069 : : end do
3070 : : end do
3071 : : end do
3072 : : end do
3073 : : end if
3074 : :
3075 : : !Now the dielectric tensor ! normal case
3076 [ + + ]: 418 : if(rfpert(natom+2)==1)then
3077 : :
3078 : 92 : write(iout,*)' '
3079 : 92 : write(iout,*)' Dielectric tensor, in cartesian coordinates,'
3080 : 92 : write(iout,*)' j1 j2 matrix element'
3081 : 92 : write(iout,*)' dir pert dir pert real part imaginary part'
3082 : 92 : ipert1=natom+2
3083 : 92 : ipert2=natom+2
3084 : 92 : nline=1
3085 [ + + ]: 368 : do idir1=1,3
3086 [ + + ]: 276 : if(nline/=0)write(iout,*)' '
3087 : 276 : nline=0
3088 [ + + ]: 1196 : do idir2=1,3
3089 [ + + ]: 1104 : if(carflg(idir1,ipert1,idir2,ipert2)==1)then
3090 : 776 : nline=nline+1
3091 : 776 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
3092 : 776 : & d2cart(1,idir1,ipert1,idir2,ipert2),&
3093 : 1552 : & d2cart(2,idir1,ipert1,idir2,ipert2)
3094 : : end if
3095 : : end do
3096 : : end do
3097 : :
3098 [ + + ]: 92 : if (prtbbb == 1) then
3099 : :
3100 : 2 : delta(:,:) = zero
3101 : 2 : delta(1,1) = one ; delta(2,2) = one ; delta(3,3) = one
3102 : :
3103 : 2 : write(iout,*)
3104 : 2 : write(iout,*)'Band by band decomposition of the dielectric tensor'
3105 : 2 : write(iout,*)' '
3106 : :
3107 : 2 : write(iout,*)' Vacuum polarization'
3108 : 2 : write(iout,*)' j1 j2 matrix element'
3109 : 2 : write(iout,*)' dir pert dir pert real part imaginary part'
3110 : 2 : nline=1
3111 [ + + ]: 8 : do idir1=1,3
3112 [ + - ]: 6 : if(nline/=0)write(iout,*)' '
3113 : 6 : nline=0
3114 [ + + ]: 26 : do idir2=1,3
3115 : 18 : nline=nline+1
3116 : 18 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
3117 : 42 : & delta(idir2,idir1),zero
3118 : : end do
3119 : : end do
3120 : :
3121 [ + + ]: 18 : do iband = 1,mband
3122 : 16 : write(iout,*)' '
3123 : 16 : write(iout,*)' Dielectric tensor, in cartesian coordinates, for band',iband
3124 : 16 : write(iout,*)' j1 j2 matrix element'
3125 : 16 : write(iout,*)' dir pert dir pert real part imaginary part'
3126 : 16 : ipert1 = natom + 2
3127 : 16 : ipert2 = natom + 2
3128 : 16 : nline=1
3129 [ + + ]: 66 : do idir1=1,3
3130 [ + - ]: 48 : if(nline/=0)write(iout,*)' '
3131 : 48 : nline=0
3132 [ + + ]: 208 : do idir2=1,3
3133 [ + - ]: 192 : if(carflg(idir1,ipert1,idir2,ipert2)==1)then
3134 : : ! substract vacuum polarization
3135 [ + + ]: 144 : if (idir1 == idir2) then
3136 : : d2cart_bbb(1,idir1,idir2,ipert2,iband,iband) = &
3137 : 48 : & d2cart_bbb(1,idir1,idir2,ipert2,iband,iband) - 1
3138 : : end if
3139 : 144 : nline=nline+1
3140 : 144 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
3141 : 144 : & d2cart_bbb(1,idir1,idir2,ipert2,iband,iband),&
3142 : 288 : & d2cart_bbb(2,idir1,idir2,ipert2,iband,iband)
3143 : : end if
3144 : : end do
3145 : : end do
3146 : : end do !iband
3147 : :
3148 : : end if !prtbbb
3149 : :
3150 : : end if ! end natom+2 dielectric output
3151 : :
3152 : : !Now the effective charges
3153 : : !In case of the stationary calculation
3154 [ - + - - : 418 : if(outd2==2 .and. rfpert(natom+2)==1 .and.rfphon==1)then
- - ]
3155 : 0 : write(iout,*)' '
3156 : 0 : write(iout,*)' Effective charges, in cartesian coordinates,'
3157 : 0 : write(iout,*)' if specified in the inputs, charge neutrality has been imposed'
3158 : 0 : write(iout,*)' j1 j2 matrix element'
3159 : 0 : write(iout,*)' dir pert dir pert real part imaginary part'
3160 : 0 : ipert1=natom+2
3161 : 0 : nline=1
3162 [ # # ]: 0 : do idir1=1,3
3163 [ # # ]: 0 : if(nline/=0)write(iout,*)' '
3164 : 0 : nline=0
3165 [ # # ]: 0 : do ipert2=1,natom
3166 [ # # ]: 0 : do idir2=1,3
3167 [ # # ]: 0 : if(carflg(idir1,ipert1,idir2,ipert2)==1)then
3168 : 0 : nline=nline+1
3169 : 0 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
3170 : 0 : & d2cart(1,idir1,ipert1,idir2,ipert2),&
3171 : 0 : & d2cart(2,idir1,ipert1,idir2,ipert2)
3172 : : end if
3173 : : end do
3174 : : end do
3175 : : end do
3176 : : end if
3177 : :
3178 : : !Now in case of the non-stationary calculation
3179 [ + - + + ]: 418 : if(outd2==1 .and. rfpert(natom+2)==1)then
3180 : 92 : write(iout,*)' '
3181 [ + + - + ]: 92 : if(usepaw==1.and..not.(has_allddk))then
3182 : 0 : write(iout,*)' Warning: Born effectives charges are not correctly computed'
3183 : 0 : write(iout,*)' you need all ddk perturbations!'
3184 : : end if
3185 : 92 : write(iout,*)' Effective charges, in cartesian coordinates,'
3186 : 92 : write(iout,*)' (from electric field response) '
3187 : 92 : write(iout,*)' if specified in the inputs, charge neutrality has been imposed'
3188 : 92 : write(iout,*)' j1 j2 matrix element'
3189 : 92 : write(iout,*)' dir pert dir pert real part imaginary part'
3190 : 92 : ipert2=natom+2
3191 : 92 : nline=1
3192 [ + + ]: 368 : do idir2=1,3
3193 [ + + ]: 276 : if(nline/=0)write(iout,*)' '
3194 : 276 : nline=0
3195 [ + + ]: 1025 : do ipert1=1,natom
3196 [ + + ]: 2904 : do idir1=1,3
3197 [ + + ]: 2628 : if(carflg(idir1,ipert1,idir2,ipert2)==1)then
3198 : 1765 : nline=nline+1
3199 : 1765 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
3200 : 1765 : & d2cart(1,idir1,ipert1,idir2,ipert2),&
3201 : 3530 : & d2cart(2,idir1,ipert1,idir2,ipert2)
3202 : : end if
3203 : : end do
3204 : : end do
3205 : : end do
3206 : : end if
3207 : :
3208 : : if(outd2==1 .and. rfphon==1 .and. qzero==1&
3209 [ + - + + : 418 : & .and. ( (ddkfil(1)/=0.or.ddkfil(2)/=0.or.ddkfil(3)/=0) .or. &
+ + + + +
- + + +
+ ]
3210 : : & berryopt==4 .or. berryopt==6 .or. berryopt==7 .or. berryopt==14 .or. berryopt==16 .or. berryopt==17 ) )then !!HONG need to test for fixed E and D
3211 : 90 : write(iout,*)' '
3212 [ + + - + ]: 90 : if(usepaw==1.and..not.(has_allddk))then
3213 : 0 : write(iout,*)' Warning: Born effectives charges are not correctly computed'
3214 : 0 : write(iout,*)' you need all ddk perturbations!'
3215 : : end if
3216 : 90 : write(iout,*)' Effective charges, in cartesian coordinates,'
3217 : 90 : write(iout,*)' (from phonon response) '
3218 : 90 : write(iout,*)' if specified in the inputs, charge neutrality has been imposed'
3219 : 90 : write(iout,*)' j1 j2 matrix element'
3220 : 90 : write(iout,*)' dir pert dir pert real part imaginary part'
3221 : 90 : nline=1
3222 [ + + ]: 294 : do ipert2=1,natom
3223 [ + + ]: 906 : do idir2=1,3
3224 [ + + ]: 612 : if(nline/=0)write(iout,*)' '
3225 : 612 : nline=0
3226 : 612 : ipert1=natom+2
3227 [ + + ]: 2652 : do idir1=1,3
3228 [ + + ]: 2448 : if(carflg(idir1,ipert1,idir2,ipert2)==1)then
3229 : 1738 : nline=nline+1
3230 : 1738 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
3231 : 1738 : & d2cart(1,idir1,ipert1,idir2,ipert2),&
3232 : 3476 : & d2cart(2,idir1,ipert1,idir2,ipert2)
3233 : : end if
3234 : : end do
3235 : : end do
3236 : : end do
3237 : 90 : write(iout,*)' '
3238 : 90 : write(iout,*)' '
3239 : 90 : write(iout,*)' '
3240 : :
3241 [ + + ]: 90 : if (prtbbb == 1) then
3242 : :
3243 : 2 : write(iout,*)'Band by band decomposition of the Born effective charges'
3244 : 2 : write(iout,*)' '
3245 : 2 : write(iout,*)'Ionic charges in cartesian coordinates'
3246 : 2 : write(iout,*)' j1 j2 matrix element'
3247 : 2 : write(iout,*)' dir pert dir pert real part imaginary part'
3248 : 2 : zr = zero
3249 : 2 : zi = zero
3250 [ + + ]: 6 : do ipert2=1,natom
3251 [ + + ]: 18 : do idir2=1,3
3252 [ + - ]: 12 : if(nline/=0)write(iout,*)' '
3253 : 12 : nline=0
3254 : 12 : ipert1=natom+2
3255 [ + + ]: 52 : do idir1=1,3
3256 : 36 : zr = zero
3257 [ + + ]: 36 : if (idir1 == idir2) then
3258 : 12 : zr = zion(typat(ipert2))
3259 : : end if
3260 : 36 : nline=nline+1
3261 : 36 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
3262 : 84 : & zr,zi
3263 : : end do
3264 : : end do
3265 : : end do
3266 : :
3267 [ + + ]: 18 : do iband = 1,mband
3268 : 16 : write(iout,*)' '
3269 : 16 : write(iout,*)' Effective charges, in cartesian coordinates, for band',iband
3270 : 16 : write(iout,*)' (from phonon response) '
3271 : 16 : write(iout,*)' if specified in the inputs, charge neutrality has been imposed'
3272 : 16 : write(iout,*)' j1 j2 matrix element'
3273 : 16 : write(iout,*)' dir pert dir pert real part imaginary part'
3274 : 16 : nline=1
3275 [ + + ]: 50 : do ipert2=1,natom
3276 [ + + ]: 144 : do idir2=1,3
3277 [ + - ]: 96 : if(nline/=0)write(iout,*)' '
3278 : 96 : nline=0
3279 : 96 : ipert1=natom+2
3280 [ + + ]: 416 : do idir1=1,3
3281 [ + - ]: 384 : if(carflg(idir1,ipert1,idir2,ipert2)==1)then
3282 : 288 : nline=nline+1
3283 : 288 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
3284 : 288 : & d2cart_bbb(1,idir1,idir2,ipert2,iband,iband),&
3285 : 576 : & d2cart_bbb(2,idir1,idir2,ipert2,iband,iband)
3286 : : end if
3287 : : end do
3288 : : end do
3289 : : end do
3290 : : end do !iband
3291 : : end if !prtbbb
3292 : : end if ! end of print effective charges
3293 : :
3294 : : !Now the elastic tensor
3295 [ + + ]: 418 : if(rfstrs/=0) then
3296 : 33 : write(iout,*)' '
3297 : 33 : write(iout,*)' Rigid-atom elastic tensor , in cartesian coordinates,'
3298 : 33 : write(iout,*)' j1 j2 matrix element'
3299 : 33 : write(iout,*)' dir pert dir pert real part imaginary part'
3300 : 33 : nline=1
3301 [ + + ]: 99 : do ipert1=natom+3,natom+4
3302 [ + + ]: 297 : do idir1=1,3
3303 [ + - ]: 198 : if(nline/=0)write(iout,*)' '
3304 : 198 : nline=0
3305 [ + + ]: 660 : do ipert2=natom+3,natom+4
3306 [ + + ]: 1782 : do idir2=1,3
3307 [ + + ]: 1584 : if(carflg(idir1,ipert1,idir2,ipert2)==1)then
3308 : 962 : nline=nline+1
3309 : 962 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
3310 : 962 : & d2cart(1,idir1,ipert1,idir2,ipert2),&
3311 : 1924 : & d2cart(2,idir1,ipert1,idir2,ipert2)
3312 : : end if
3313 : : end do
3314 : : end do
3315 : : end do
3316 : : end do
3317 : : end if
3318 : :
3319 : : !Now the internal strain coupling parameters
3320 [ + + ]: 418 : if(rfstrs/=0) then
3321 : 33 : write(iout,*)' '
3322 : 33 : write(iout,*)' Internal strain coupling parameters, in cartesian coordinates,'
3323 : 33 : write(iout,*)' zero average net force deriv. has been imposed '
3324 : 33 : write(iout,*)' j1 j2 matrix element'
3325 : 33 : write(iout,*)' dir pert dir pert real part imaginary part'
3326 : 33 : nline=1
3327 [ + + ]: 111 : do ipert1=1,natom
3328 [ + + ]: 345 : do idir1=1,3
3329 [ + - ]: 234 : if(nline/=0)write(iout,*)' '
3330 : 234 : nline=0
3331 [ + + ]: 780 : do ipert2=natom+3,natom+4
3332 [ + + ]: 2106 : do idir2=1,3
3333 [ + + ]: 1872 : if(carflg(idir1,ipert1,idir2,ipert2)==1)then
3334 : 1101 : nline=nline+1
3335 : 1101 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
3336 : 1101 : & d2cart(1,idir1,ipert1,idir2,ipert2),&
3337 : 2202 : & d2cart(2,idir1,ipert1,idir2,ipert2)
3338 : : end if
3339 : : end do
3340 : : end do
3341 : : end do
3342 : : end do
3343 : : end if
3344 : :
3345 : : !Now the piezoelectric tensor
3346 [ + + + + : 418 : if(rfstrs/=0 .and. (ddkfil(1)/=0.or.ddkfil(2)/=0.or.ddkfil(3)/=0))then
+ - + + ]
3347 : 17 : write(iout,*)' '
3348 [ + + - + ]: 17 : if(usepaw==1.and..not.(has_allddk))then
3349 : 0 : write(iout,*)' Warning: Rigid-atom proper piezoelectric tensor is not correctly computed'
3350 : 0 : write(iout,*)' you need all ddk perturbations!'
3351 : : end if
3352 : 17 : write(iout,*)' Rigid-atom proper piezoelectric tensor, in cartesian coordinates,'
3353 : 17 : write(iout,*)' (from strain response)'
3354 : 17 : write(iout,*)' j1 j2 matrix element'
3355 : 17 : write(iout,*)' dir pert dir pert real part imaginary part'
3356 : 17 : nline=1
3357 : 17 : ipert1=natom+2
3358 [ + + ]: 68 : do idir1=1,3
3359 [ + + ]: 51 : if(nline/=0)write(iout,*)' '
3360 : 51 : nline=0
3361 [ + + ]: 571 : do ipert2=natom+3,natom+4
3362 [ + + ]: 459 : do idir2=1,3
3363 [ + + ]: 408 : if(carflg(idir1,ipert1,idir2,ipert2)==1)then
3364 : 265 : nline=nline+1
3365 : 265 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
3366 : 265 : & d2cart(1,idir1,ipert1,idir2,ipert2),&
3367 : 530 : & d2cart(2,idir1,ipert1,idir2,ipert2)
3368 : : end if
3369 : : end do
3370 : : end do
3371 : : end do
3372 : : end if
3373 : :
3374 : : !Now the piezoelectric tensor
3375 : : if(outd2==1 .and. (pawpiezo==1.and.rfpert(natom+2)==1)&
3376 [ + - + + : 418 : & .and. (ddkfil(1)/=0.or.ddkfil(2)/=0.or.ddkfil(3)/=0)) then
+ + - + -
- - - ]
3377 : 11 : write(iout,*)' '
3378 [ + - - + ]: 11 : if(usepaw==1.and..not.(has_allddk))then
3379 : 0 : write(iout,*)' Warning: Rigid-atom proper piezoelectric tensor is not correctly computed'
3380 : 0 : write(iout,*)' you need all ddk perturbations!'
3381 : : end if
3382 [ + - + + ]: 11 : if(usepaw==1.and..not.has_full_piezo)then
3383 : 10 : write(iout,*)' Warning: The rigid-atom proper piezoelectric tensor'
3384 : 10 : write(iout,*)' from electric field response requires nsym=1'
3385 : : end if
3386 [ + + ]: 11 : if (has_full_piezo) then
3387 : 1 : write(iout,*)' Rigid-atom proper piezoelectric tensor, in cartesian coordinates,'
3388 : 1 : write(iout,*)' (from electric field response)'
3389 : 1 : write(iout,*)' j1 j2 matrix element'
3390 : 1 : write(iout,*)' dir pert dir pert real part imaginary part'
3391 : 1 : nline=1
3392 : 1 : ipert1=natom+2
3393 [ + + ]: 4 : do idir1=1,3
3394 [ + - ]: 3 : if(nline/=0)write(iout,*)' '
3395 : 3 : nline=0
3396 [ + + ]: 10 : do ipert2=natom+3,natom+4
3397 [ + + ]: 27 : do idir2=1,3
3398 [ + - ]: 24 : if(carflg(idir2,ipert2,idir1,ipert1)==1)then
3399 : 18 : nline=nline+1
3400 : 18 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir2,ipert2,idir1,ipert1,&
3401 : 18 : & d2cart(1,idir2,ipert2,idir1,ipert1),&
3402 : 36 : & d2cart(2,idir2,ipert2,idir1,ipert1)
3403 : : end if
3404 : : end do
3405 : : end do
3406 : : end do
3407 : : end if
3408 : : end if
3409 : :
3410 : : !Now the spin field quantities
3411 [ + + ]: 418 : if (rfmagn==1) then
3412 : 8 : write(iout,*)' '
3413 : 8 : write(iout,*)' Magnetic susceptibility, in cartesian coordinates'
3414 : 8 : write(iout,*)' (from uniform spin field response)'
3415 : 8 : write(iout,*)' j1 j2 matrix element'
3416 : 8 : write(iout,*)' dir pert dir pert real part imaginary part'
3417 : 8 : ipert1=natom+5
3418 : 8 : ipert2=natom+5
3419 : 8 : nline=1
3420 [ + + ]: 32 : do idir1=1,3
3421 [ + + ]: 24 : if (nline/=0) write(iout,*)' '
3422 : 24 : nline=0
3423 [ + + ]: 104 : do idir2=1,3
3424 [ + + ]: 96 : if (carflg(idir1,ipert1,idir2,ipert2)==1) then
3425 : 15 : nline=nline+1
3426 : 15 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
3427 : 15 : & d2cart(1,idir1,ipert1,idir2,ipert2),&
3428 : 30 : & d2cart(2,idir1,ipert1,idir2,ipert2)
3429 : : end if
3430 : : end do
3431 : : end do
3432 : : end if
3433 : :
3434 [ + + ]: 418 : if (rfmagn==2) then
3435 : 3 : write(iout,*)' '
3436 : 3 : write(iout,*)' Local magnetic susceptibility, in cartesian coordinates'
3437 : 3 : write(iout,*)' (from local spin field response)'
3438 : 3 : write(iout,*)' j1 j2 matrix element'
3439 : 3 : write(iout,*)' dir pert dir pert real part imaginary part'
3440 : 3 : nline=1
3441 [ + + ]: 21 : do ipert1= natom+12,2*natom+11
3442 [ + + ]: 75 : do idir1=1,3
3443 [ + - ]: 54 : if(nline/=0)write(iout,*)' '
3444 : 54 : nline=0
3445 [ + + ]: 396 : do ipert2= natom+12,2*natom+11
3446 [ + + ]: 1350 : do idir2=1,3
3447 [ + + ]: 1296 : if(carflg(idir1,ipert1,idir2,ipert2)==1)then
3448 : 105 : nline=nline+1
3449 : 105 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
3450 : 105 : & d2cart(1,idir1,ipert1,idir2,ipert2),&
3451 : 210 : & d2cart(2,idir1,ipert1,idir2,ipert2)
3452 : : end if
3453 : : end do
3454 : : end do
3455 : : end do
3456 : : end do
3457 : : end if
3458 : :
3459 [ + + + + ]: 418 : if (rfmagn==1.and.rfpert(natom+2)==1) then
3460 : 2 : write(iout,*)' '
3461 : 2 : write(iout,*)' Magnetoelectric tensor, in cartesian coordinates'
3462 : 2 : write(iout,*)' (from magnetization induced by electric field)'
3463 : 2 : write(iout,*)' j1 j2 matrix element'
3464 : 2 : write(iout,*)' dir pert dir pert real part imaginary part'
3465 : 2 : ipert1=natom+5
3466 : 2 : ipert2=natom+2
3467 : 2 : nline=1
3468 [ + + ]: 8 : do idir1=1,3
3469 [ + - ]: 6 : if (nline/=0) write(iout,*)' '
3470 : 6 : nline=0
3471 [ + + ]: 26 : do idir2=1,3
3472 [ + + ]: 24 : if (carflg(idir1,ipert1,idir2,ipert2)==1) then
3473 : 10 : nline=nline+1
3474 : 10 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
3475 : 10 : & d2cart(1,idir1,ipert1,idir2,ipert2),&
3476 : 20 : & d2cart(2,idir1,ipert1,idir2,ipert2)
3477 : : end if
3478 : : end do
3479 : : end do
3480 : :
3481 : 2 : write(iout,*)' '
3482 : 2 : write(iout,*)' Magnetoelectric tensor, in cartesian coordinates'
3483 : 2 : write(iout,*)' (from polarization induced by Zeeman field)'
3484 : 2 : write(iout,*)' j1 j2 matrix element'
3485 : 2 : write(iout,*)' dir pert dir pert real part imaginary part'
3486 : 2 : ipert1=natom+2
3487 : 2 : ipert2=natom+5
3488 : 2 : nline=1
3489 [ + + ]: 8 : do idir1=1,3
3490 [ + - ]: 6 : if (nline/=0) write(iout,*)' '
3491 : 6 : nline=0
3492 [ + + ]: 26 : do idir2=1,3
3493 [ + + ]: 24 : if (carflg(idir1,ipert1,idir2,ipert2)==1) then
3494 : 10 : nline=nline+1
3495 : 10 : write(iout,'(2(i4,i5),2(1x,f20.10))')idir1,ipert1,idir2,ipert2,&
3496 : 10 : & d2cart(1,idir1,ipert1,idir2,ipert2),&
3497 : 20 : & d2cart(2,idir1,ipert1,idir2,ipert2)
3498 : : end if
3499 : : end do
3500 : : end do
3501 : :
3502 : : end if
3503 : :
3504 : :
3505 : 418 : end subroutine dfpt_dyout
3506 : : !!***
3507 : :
3508 : : !!****f* ABINIT/dfpt_gatherdy
3509 : : !!
3510 : : !! NAME
3511 : : !! dfpt_gatherdy
3512 : : !!
3513 : : !! FUNCTION
3514 : : !! Sum (gather) the different parts of the 2nd-order matrix,
3515 : : !! to get the matrix of second-order derivatives (d2matr)
3516 : : !! Then, generates the dynamical matrix, not including the masses,
3517 : : !! but the correct non-cartesian coordinates ( => d2cart)
3518 : : !!
3519 : : !! INPUTS
3520 : : !! asr= (0=> no acoustic sum rule [asr] imposed), (1 or 2=> asr is imposed) only for dynamical matrix at Gamma
3521 : : !! becfrnl(3,natom,3*pawbec)=NL frozen contribution to Born Effective Charges (PAW only)
3522 : : !! berryopt=option for berry phase treatment
3523 : : !! blkflg(3,mpert,3,mpert)= ( 1 if the element of the dynamical
3524 : : !! matrix has been calculated ; 0 otherwise )
3525 : : !! chneut= (0=> no charge neutrality sum rule imposed), (1=> charge neutrality is imposed,
3526 : : !! with equal repartition of the charge neutrality correction for the effective charges),
3527 : : !! (2=> charge neutrality is imposed, with weighted repartition of the charge neutrality correction for the effective charges),
3528 : : !! dyew(2,3,natom,3,natom)=Ewald part of the dyn.matrix
3529 : : !! dyfrwf(dyfr_cplex,3,3,natom,1+(natom-1)*dyfr_nondiag)=frozen wf part of the dyn.matrix (except xc1)
3530 : : !! dyfrx1(2,3,natom,3,natom)=xc core correction (1) part of the frozen-wf
3531 : : !! part of the dynamical matrix.
3532 : : !! dyfr_cplex=1 if dyfrnl is real, 2 if it is complex
3533 : : !! dyfr_nondiag=1 if dyfrwf is non diagonal with respect to atoms; 0 otherwise
3534 : : !! dyvdw(2,3,natom,3,natom*usevdw)=vdw DFT-D part of the dynamical matrix
3535 : : !! d2bbb(2,3,3,mpert,mband,mband*prtbbb)=band by band decomposition of some
3536 : : !! second order derivatives
3537 : : !! d2nfr(2,3,mpert,3,mpert)=non-frozen wf part of the 2nd-order matr
3538 : : !! eltcore(6,6)=core contribution to the elastic tensor
3539 : : !! elteew(6+3*natom,6)=Ewald contribution to the elastic tsenor
3540 : : !! eltfrhar(6,6)=hartree contribution to the elastic tensor
3541 : : !! eltfrkin(6,6)=kinetic contribution to the elastic tensor
3542 : : !! eltfrloc(6+3*natom,6)=local psp contribution to the elastic tensor
3543 : : !! eltfrnl(6+3*natom,6)=non-local psp contribution to the elastic tensor
3544 : : !! eltfrxc(6+3*natom,6)=exchange-correlation contribution to the elastic tensor
3545 : : !! eltvdw(6+3*natom,6*usevdw)=vdw DFT-D part of the elastic tensor
3546 : : !! gprimd(3,3)=basis vector in the reciprocal space
3547 : : !! mband=maximum number of bands
3548 : : !! mpert =maximum number of ipert
3549 : : !! natom=number of atoms in unit cell
3550 : : !! ntypat=number of atom types
3551 : : !! outd2=option for the output of the 2nd-order matrix :
3552 : : !! if outd2=1, non-stationary part
3553 : : !! if outd2=2, stationary part.
3554 : : !! pawbec= flag for the computation of frozen part of Born Effective Charges (PAW only)
3555 : : !! prtbbb=if 1, print the band-by-band decomposition, otherwise, prtbbb=0
3556 : : !! rfpert(mpert)=define the perturbations
3557 : : !! rprimd(3,3)=dimensional primitive translations (bohr)
3558 : : !! typat(natom)=integer label of each type of atom (1,2,...)
3559 : : !! ucvol=unit cell volume
3560 : : !! usevdw= flag set to 1 if vdw DFT-D semi-empirical potential is in use
3561 : : !! zion(ntypat)=charge corresponding to the atom type
3562 : : !!
3563 : : !! OUTPUT
3564 : : !! carflg(3,mpert,3,mpert)= ( 1 if the element of the cartesian
3565 : : !! 2DTE matrix has been calculated correctly ; 0 otherwise )
3566 : : !! d2cart(2,3,mpert,3,mpert)=
3567 : : !! dynamical matrix, effective charges, dielectric tensor,....
3568 : : !! all in cartesian coordinates
3569 : : !! d2cart_bbb(2,3,3,mpert,mband,mband*prtbbb)=
3570 : : !! band by band decomposition of Born effective charges
3571 : : !! (calculated from phonon-type perturbation) in cartesian coordinates
3572 : : !! d2matr(2,3,mpert,3,mpert)=2nd-order matrix (masses non included,
3573 : : !! no cartesian coordinates : simply second derivatives)
3574 : : !!
3575 : : !! SOURCE
3576 : :
3577 : 418 : subroutine dfpt_gatherdy(asr,becfrnl,berryopt,blkflg,carflg,chneut,dyew,dyfrwf,dyfrx1,&
3578 : 418 : & dyfr_cplex,dyfr_nondiag,dyvdw,d2bbb,d2cart,d2cart_bbb,d2matr,d2nfr,&
3579 : 418 : & eltcore,elteew,eltfrhar,eltfrkin,eltfrloc,eltfrnl,eltfrxc,eltvdw,&
3580 : 418 : & gprimd,mband,mpert,natom,ntypat,outd2,pawbec,pawpiezo,piezofrnl,prtbbb,&
3581 : 418 : & rfpert,rprimd,typat,ucvol,usevdw,zion)
3582 : :
3583 : : !Arguments -------------------------------
3584 : : !scalars
3585 : : integer,intent(in) :: asr,berryopt,chneut,dyfr_cplex,dyfr_nondiag,mband,mpert,natom,ntypat,outd2
3586 : : integer,intent(in) :: pawbec,pawpiezo,prtbbb,usevdw
3587 : : real(dp),intent(in) :: ucvol
3588 : : !arrays
3589 : : integer,intent(in) :: rfpert(mpert),typat(natom)
3590 : : integer,intent(inout) :: blkflg(3,mpert,3,mpert)
3591 : : integer,intent(out) :: carflg(3,mpert,3,mpert)
3592 : : real(dp),intent(in) :: becfrnl(3,natom,3*pawbec)
3593 : : real(dp),intent(in) :: d2bbb(2,3,3,mpert,mband,mband*prtbbb)
3594 : : real(dp),intent(in) :: d2nfr(2,3,mpert,3,mpert),dyew(2,3,natom,3,natom)
3595 : : real(dp),intent(in) :: dyfrwf(dyfr_cplex,3,3,natom,1+(natom-1)*dyfr_nondiag)
3596 : : real(dp),intent(in) :: dyfrx1(2,3,natom,3,natom),dyvdw(2,3,natom,3,natom*usevdw)
3597 : : real(dp),intent(in) :: eltcore(6,6),elteew(6+3*natom,6)
3598 : : real(dp),intent(in) :: eltfrhar(6,6),eltfrkin(6,6),eltfrloc(6+3*natom,6)
3599 : : real(dp),intent(in) :: eltfrnl(6+3*natom,6),eltfrxc(6+3*natom,6)
3600 : : real(dp),intent(in) :: eltvdw(6+3*natom,6*usevdw),gprimd(3,3)
3601 : : real(dp),intent(in) :: piezofrnl(6,3*pawpiezo),rprimd(3,3),zion(ntypat)
3602 : : real(dp),intent(out) :: d2cart(2,3,mpert,3,mpert)
3603 : : real(dp),intent(out) :: d2cart_bbb(2,3,3,mpert,mband,mband*prtbbb)
3604 : : real(dp),intent(out) :: d2matr(2,3,mpert,3,mpert)
3605 : :
3606 : : !Local variables -------------------------
3607 : : !scalars
3608 : : integer :: iband,iblok,idir,idir1,idir2,ii,ipert,ipert1,ipert2
3609 : : integer :: jj,nblok,selectz
3610 : : character(len=500) :: msg
3611 : : !arrays
3612 : : integer :: flg1(3),flg2(3)
3613 : : real(dp) :: vec1(3),vec2(3)
3614 : : ! real(dp) :: ter(3,3) ! this variable appears commented out below
3615 : 418 : real(dp),allocatable :: d2tmp(:,:,:,:,:),d2work(:,:,:,:,:),elfrtot(:,:)
3616 : :
3617 : : ! *********************************************************************
3618 : :
3619 : :
3620 [ + - ]: 418 : if(outd2/=3)then
3621 : :
3622 : : ! Initialise the 2nd-derivative matrix
3623 [ + + + + : 1140800 : d2matr(:,:,:,:,:)=0.0_dp
+ + + + +
+ ]
3624 : :
3625 : : ! Copy first the non-frozen-part for all possible elements
3626 [ + + ]: 4271 : do ipert2=1,mpert
3627 [ + + ]: 15830 : do idir2=1,3
3628 [ + + ]: 127909 : do ipert1=1,mpert
3629 [ + + ]: 461547 : do idir1=1,3
3630 [ + + ]: 449988 : if( blkflg(idir1,ipert1,idir2,ipert2)==1 ) then
3631 [ + + ]: 76665 : do ii=1,2
3632 : : d2matr(ii,idir1,ipert1,idir2,ipert2)=&
3633 : 76665 : & d2nfr(ii,idir1,ipert1,idir2,ipert2)
3634 : : end do
3635 : : end if
3636 : : end do
3637 : : end do
3638 : : end do
3639 : : end do
3640 : :
3641 : : ! For the dynamical matrix
3642 : : ! Add the Ewald part and the xc1 part of the frozen-wf part
3643 : : ! Add the vdw part (if any)
3644 [ + + ]: 1275 : do ipert2=1,natom
3645 [ + + ]: 3846 : do idir2=1,3
3646 [ + + ]: 10925 : do ipert1=1,natom
3647 [ + + ]: 32559 : do idir1=1,3
3648 [ + + ]: 29988 : if( blkflg(idir1,ipert1,idir2,ipert2)==1 ) then
3649 [ + + ]: 43662 : do ii=1,2
3650 : : d2matr(ii,idir1,ipert1,idir2,ipert2)= &
3651 : : & d2matr(ii,idir1,ipert1,idir2,ipert2)+ &
3652 : : & dyew(ii,idir1,ipert1,idir2,ipert2) + &
3653 : 29108 : & dyfrx1(ii,idir1,ipert1,idir2,ipert2)
3654 [ + + ]: 43662 : if (usevdw==1) then
3655 : : d2matr(ii,idir1,ipert1,idir2,ipert2)= &
3656 : : & d2matr(ii,idir1,ipert1,idir2,ipert2)+ &
3657 : 108 : & dyvdw(ii,idir1,ipert1,idir2,ipert2)
3658 : : end if
3659 : : end do
3660 : : end if
3661 : : end do
3662 : : end do
3663 : : end do
3664 : : end do
3665 : :
3666 : : ! For the dynamical matrix
3667 : : ! Add the frozen-wavefunction part
3668 [ + + ]: 418 : if (dyfr_nondiag==0) then
3669 [ + + ]: 1176 : do ipert2=1,natom
3670 [ + + ]: 3534 : do idir2=1,3
3671 [ + + ]: 10218 : do idir1=1,3
3672 [ + + ]: 9432 : if( blkflg(idir1,ipert2,idir2,ipert2)==1 ) then
3673 : : d2matr(1:dyfr_cplex,idir1,ipert2,idir2,ipert2)=&
3674 : : & d2matr(1:dyfr_cplex,idir1,ipert2,idir2,ipert2)&
3675 [ + + ]: 10544 : & +dyfrwf(1:dyfr_cplex,idir1,idir2,ipert2,1)
3676 : : end if
3677 : : end do
3678 : : end do
3679 : : end do
3680 : : else
3681 [ + + ]: 99 : do ipert2=1,natom
3682 [ + + ]: 348 : do ipert1=1,natom
3683 [ + + ]: 1067 : do idir2=1,3
3684 [ + + ]: 3237 : do idir1=1,3
3685 [ + + ]: 2988 : if( blkflg(idir1,ipert1,idir2,ipert2)==1 ) then
3686 : : d2matr(1:dyfr_cplex,idir1,ipert1,idir2,ipert2)=&
3687 : : & d2matr(1:dyfr_cplex,idir1,ipert1,idir2,ipert2)&
3688 [ + + ]: 4036 : & +dyfrwf(1:dyfr_cplex,idir1,idir2,ipert1,ipert2)
3689 : : end if
3690 : : end do
3691 : : end do
3692 : : end do
3693 : : end do
3694 : : end if
3695 : :
3696 : : ! Add the frozen-wavefunction part of Born Effective Charges
3697 [ + + ]: 418 : if (pawbec==1) then
3698 : 32 : ipert2=natom+2
3699 [ + + ]: 128 : do idir2=1,3 ! Direction of electric field
3700 [ + + ]: 365 : do ipert1=1,natom ! Atom
3701 [ + + ]: 1044 : do idir1=1,3 ! Direction of atom
3702 [ + + ]: 711 : if(blkflg(idir1,ipert1,idir2,ipert2)==1 ) then
3703 : : d2matr(1,idir1,ipert1,idir2,ipert2)=&
3704 : 450 : & d2matr(1,idir1,ipert1,idir2,ipert2)+becfrnl(idir1,ipert1,idir2)
3705 : : end if
3706 [ + + ]: 948 : if(blkflg(idir2,ipert2,idir1,ipert1)==1 ) then
3707 : : d2matr(1,idir2,ipert2,idir1,ipert1)=&
3708 : 450 : & d2matr(1,idir2,ipert2,idir1,ipert1)+becfrnl(idir1,ipert1,idir2)
3709 : : end if
3710 : : end do
3711 : : end do
3712 : : end do
3713 : : end if
3714 : :
3715 : : ! For piezoelectric tensor add a contribution in PAW case
3716 [ + + ]: 418 : if(pawpiezo==1) then
3717 : 15 : ipert2=natom+2
3718 [ + + ]: 60 : do idir2=1,3 ! Direction of electric field
3719 [ + + ]: 150 : do ipert1=natom+3,natom+4 ! Strain
3720 [ + + ]: 405 : do idir1=1,3
3721 : 270 : ii=idir1+3*(ipert1-natom-3)
3722 [ + + ]: 270 : if(blkflg(idir1,ipert1,idir2,ipert2)==1 ) then
3723 : : d2matr(1,idir1,ipert1,idir2,ipert2)=&
3724 : 150 : d2matr(1,idir1,ipert1,idir2,ipert2)+piezofrnl(ii,idir2)
3725 : : endif
3726 [ + + ]: 360 : if(blkflg(idir2,ipert2,idir1,ipert1)==1 ) then
3727 : : d2matr(1,idir2,ipert2,idir1,ipert1)=&
3728 : 150 : d2matr(1,idir2,ipert2,idir1,ipert1)+piezofrnl(ii,idir2)
3729 : : endif
3730 : : end do
3731 : : end do
3732 : : end do
3733 : : end if
3734 : :
3735 : : ! Internal strain and strain-strain
3736 : :
3737 : : ! Accumulate all frozen parts of the elastic tensor
3738 [ + - - + : 2090 : ABI_MALLOC(elfrtot,(6+3*natom,6))
+ - + - +
- + - - +
+ - ]
3739 [ + + + + ]: 33400 : elfrtot(:,:)=elteew(:,:)+eltfrloc(:,:)+eltfrnl(:,:)+eltfrxc(:,:)
3740 [ + + + + ]: 17974 : elfrtot(1:6,1:6)=elfrtot(1:6,1:6)+eltcore(:,:)+eltfrhar(:,:)+eltfrkin(:,:)
3741 [ + + + + : 619 : if (usevdw==1) elfrtot(:,:)=elfrtot(:,:)+eltvdw(:,:)
+ + ]
3742 : :
3743 [ + + ]: 1254 : do ipert2=natom+3,natom+4
3744 [ + + ]: 3762 : do idir2=1,3
3745 : :
3746 : : ! Internal strain components
3747 [ + + ]: 7650 : do ipert1=1,natom
3748 [ + + ]: 23076 : do idir1=1,3
3749 : 15426 : ii=idir1+6+3*(ipert1-1)
3750 : 15426 : jj=idir2+3*(ipert2-natom-3)
3751 [ + + ]: 15426 : if( blkflg(idir1,ipert1,idir2,ipert2)==1 ) then
3752 : : d2matr(1,idir1,ipert1,idir2,ipert2)=&
3753 : 1101 : & d2matr(1,idir1,ipert1,idir2,ipert2)+elfrtot(ii,jj)
3754 : : endif
3755 [ + + ]: 20568 : if( blkflg(idir2,ipert2,idir1,ipert1)==1 ) then
3756 : : d2matr(1,idir2,ipert2,idir1,ipert1)=&
3757 : 1101 : & d2matr(1,idir2,ipert2,idir1,ipert1)+elfrtot(ii,jj)
3758 : : endif
3759 : : end do
3760 : : end do
3761 : :
3762 : : ! Now, strain-strain 2nd derivatives
3763 [ + + ]: 8360 : do ipert1=natom+3,natom+4
3764 [ + + ]: 22572 : do idir1=1,3
3765 [ + + ]: 20064 : if( blkflg(idir1,ipert1,idir2,ipert2)==1 ) then
3766 : 962 : ii=idir1+3*(ipert1-natom-3)
3767 : 962 : jj=idir2+3*(ipert2-natom-3)
3768 : : d2matr(1,idir1,ipert1,idir2,ipert2)=&
3769 : 962 : & d2matr(1,idir1,ipert1,idir2,ipert2)+elfrtot(ii,jj)
3770 : : end if
3771 : : end do
3772 : : end do
3773 : :
3774 : : end do
3775 : : end do
3776 [ - + ]: 418 : ABI_FREE(elfrtot)
3777 : : ! End section for internal strain and strain-strain
3778 : :
3779 : : ! The second-order matrix has been computed.
3780 : :
3781 : : ! Filter now components smaller in absolute value than 1.0d-20,
3782 : : ! for automatic testing reasons
3783 [ + + ]: 4271 : do ipert2=1,mpert
3784 [ + + ]: 15830 : do idir2=1,3
3785 [ + + ]: 127909 : do ipert1=1,mpert
3786 [ + + ]: 461547 : do idir1=1,3
3787 [ + + ]: 449988 : if( blkflg(idir1,ipert1,idir2,ipert2)==1 ) then
3788 [ + + ]: 76665 : do ii=1,2
3789 [ + + ]: 76665 : if( d2matr(ii,idir1,ipert1,idir2,ipert2)**2 < 1.0d-40)then
3790 : 17701 : d2matr(ii,idir1,ipert1,idir2,ipert2)=zero
3791 : : end if
3792 : : end do
3793 : : end if
3794 : : end do
3795 : : end do
3796 : : end do
3797 : : end do
3798 : :
3799 : : ! Cartesian coordinates transformation
3800 : 418 : iblok=1 ; nblok=1
3801 : :
3802 : : ! In the case of finite electric field, the convention for the
3803 : : ! direction of the electric field perturbation was NOT the usual convention ...
3804 : : ! So, there is a transformation to the usual conventions
3805 : : ! to be done first ...
3806 : : if((berryopt==4 .or. berryopt==6 .or. berryopt==7 .or. berryopt==14 .or. berryopt==16 .or. berryopt==17 ) &
3807 [ + + + + : 5434 : & .and. minval(abs(blkflg(:,natom+2,:,natom+2)))/=0)then !!HONG need to check for fixed D and E calculation
+ + + - ]
3808 [ + + + + : 13 : if(minval(abs(blkflg(:,natom+2,:,natom+2)-1))/=0)then
- + ]
3809 : : write(msg,'(5a)')&
3810 : 0 : & ' In case of finite electric field, and electric field perturbation,',ch10,&
3811 : 0 : & ' the three directions for the perturbations must be treated.',ch10,&
3812 : 0 : & ' Action : set idir to 1 1 1, or forget about finite electric field.'
3813 : 0 : ABI_ERROR(msg)
3814 : : end if
3815 [ + + ]: 10 : do ipert=1,mpert
3816 [ + + ]: 37 : do idir=1,3
3817 [ + + ]: 90 : do ii=1,2
3818 [ + + ]: 216 : vec1(:)=d2matr(ii,idir,ipert,:,natom+2)
3819 [ + + ]: 216 : flg1(:)=blkflg(idir,ipert,:,natom+2)
3820 : 54 : call cart39(flg1,flg2,gprimd,1,1,rprimd,vec1,vec2)
3821 [ + + ]: 216 : d2matr(ii,idir,ipert,:,natom+2)=vec2(:)*two_pi
3822 [ + + ]: 243 : blkflg(idir,ipert,:,natom+2)=flg2(:)
3823 : : end do
3824 : : end do
3825 : : end do
3826 [ + + ]: 10 : do ipert=1,mpert
3827 [ + + ]: 37 : do idir=1,3
3828 [ + + ]: 90 : do ii=1,2
3829 [ + + ]: 216 : vec1(:)=d2matr(ii,:,natom+2,idir,ipert)
3830 [ + + ]: 216 : flg1(:)=blkflg(:,natom+2,idir,ipert)
3831 : 54 : call cart39(flg1,flg2,gprimd,1,1,rprimd,vec1,vec2)
3832 [ + + ]: 216 : d2matr(ii,:,natom+2,idir,ipert)=vec2(:)*two_pi
3833 [ + + ]: 243 : blkflg(:,natom+2,idir,ipert)=flg2(:)
3834 : : end do
3835 : : end do
3836 : : end do
3837 : : ! Also to be done, a change of sign, that I do not understand (XG071110)
3838 : : ! Perhaps due to d/dk replacing id/dk ? !
3839 [ + + + + : 31 : d2matr(:,:,natom+2,:,natom+2)=-d2matr(:,:,natom+2,:,natom+2)
+ + ]
3840 : : end if
3841 : :
3842 : : call cart29(blkflg,d2matr,carflg,d2cart,&
3843 : 418 : & gprimd,iblok,mpert,natom,nblok,ntypat,rprimd,typat,ucvol,zion)
3844 : :
3845 : : ! Band by band decomposition of the Born effective charges
3846 [ + + ]: 418 : if(prtbbb==1)then
3847 [ - + + - : 10 : ABI_MALLOC(d2work,(2,3,mpert,3,mpert))
+ - - + +
- + - + -
- + - + ]
3848 [ - + + - : 6 : ABI_MALLOC(d2tmp,(2,3,mpert,3,mpert))
- + + - -
+ + - ]
3849 [ + + ]: 18 : do iband=1,mband
3850 [ + + + + : 39472 : d2work(:,:,:,:,:)=0.0_dp
+ + + + +
+ ]
3851 [ + + + + : 39472 : d2tmp(:,:,:,:,:)=0.0_dp
+ + + + +
+ ]
3852 [ + + + + : 4480 : d2work(:,:,natom+2,:,:) = d2bbb(:,:,:,:,iband,iband)
+ + + + ]
3853 : : call cart29(blkflg,d2work,carflg,d2tmp,&
3854 : 16 : & gprimd,iblok,mpert,natom,nblok,ntypat,rprimd,typat,ucvol,zion)
3855 : :
3856 : : ! Remove the ionic part
3857 [ + + ]: 48 : do ipert1=1,natom
3858 [ + + ]: 144 : do idir1=1,3
3859 : : d2tmp(1,idir1,natom+2,idir1,ipert1) = &
3860 : 128 : & d2tmp(1,idir1,natom+2,idir1,ipert1) - zion(typat(ipert1))
3861 : : end do
3862 : : end do
3863 : :
3864 [ + + + + : 4482 : d2cart_bbb(:,:,:,:,iband,iband)=d2tmp(:,:,natom+2,:,:)
+ + + + ]
3865 : :
3866 : : end do
3867 [ - + ]: 2 : ABI_FREE(d2tmp)
3868 [ - + ]: 2 : ABI_FREE(d2work)
3869 : : end if ! prtbbb==1
3870 : :
3871 : : !
3872 : : ! Now, the cartesian elements are ready for output
3873 : : ! carflg give the information on their correctness
3874 : : end if
3875 : :
3876 : : ! Imposition of the ASR on the analytical part of the DynMat
3877 : : ! Assume that if asr/=0, the whole cartesian matrix is correct
3878 [ + + ]: 418 : if(asr/=0)then
3879 : :
3880 [ - + + - : 785 : ABI_MALLOC(d2work,(2,3,mpert,3,mpert))
+ - - + +
- + - + -
- + - + ]
3881 : 157 : call asria_calc(asr,d2work,d2cart,mpert,natom)
3882 : : ! The following line imposes ASR:
3883 : 157 : call asria_corr(asr,d2work,d2cart,mpert,natom)
3884 : :
3885 [ - + ]: 157 : ABI_FREE(d2work)
3886 : :
3887 : : ! Imposition of the charge neutrality on the effective charges.
3888 [ + + ]: 157 : if(rfpert(natom+2)==1)then
3889 : 66 : selectz=0
3890 : 66 : call chneu9(chneut,d2cart,mpert,natom,ntypat,selectz,typat,zion)
3891 : : end if
3892 : :
3893 : : end if
3894 : :
3895 : : !Additional operations on cartesian strain derivatives
3896 [ + + + + ]: 418 : if(rfpert(natom+3)==1 .or. rfpert(natom+4)==1) then
3897 : : ! Impose zero-net-force condition on internal strain tensor
3898 [ + + ]: 99 : do ipert2=natom+3,natom+4
3899 [ + + ]: 297 : do idir2=1,3
3900 : 198 : vec1(:)=0.0_dp
3901 [ + + ]: 666 : do ipert1=1,natom
3902 [ + + ]: 2070 : do idir1=1,3
3903 [ + + ]: 1872 : if(carflg(idir1,ipert1,idir2,ipert2)==1) then
3904 : 1101 : vec1(idir1)=vec1(idir1)+d2cart(1,idir1,ipert1,idir2,ipert2)
3905 : : end if
3906 : : end do
3907 : : end do
3908 [ + + ]: 792 : vec1(:)=vec1(:)/dble(natom)
3909 [ + + ]: 732 : do ipert1=1,natom
3910 [ + + ]: 2070 : do idir1=1,3
3911 [ + + ]: 1872 : if(carflg(idir1,ipert1,idir2,ipert2)==1) then
3912 : : ! Note minus sign to convert gradients to forces
3913 : : d2cart(1,idir1,ipert1,idir2,ipert2)=&
3914 : 1101 : & -(d2cart(1,idir1,ipert1,idir2,ipert2)-vec1(idir1))
3915 : : end if
3916 : : end do
3917 : : end do
3918 : : end do
3919 : : end do
3920 : : ! Divide strain 2nd derivative by ucvol to give elastic tensor
3921 [ + + ]: 99 : do ipert2=natom+3,natom+4
3922 [ + + ]: 682 : do idir2=1,3
3923 [ + + ]: 660 : do ipert1=natom+3,natom+4
3924 [ + + ]: 1782 : do idir1=1,3
3925 [ + + ]: 1584 : if(carflg(idir1,ipert1,idir2,ipert2)==1) then
3926 : : d2cart(1,idir1,ipert1,idir2,ipert2)=&
3927 : 962 : & d2cart(1,idir1,ipert1,idir2,ipert2)/ucvol
3928 : : end if
3929 : : end do
3930 : : end do
3931 : : end do
3932 : : end do
3933 : : end if
3934 : :
3935 : : !calculate Born effective charges from electric field perturbation
3936 : : !do ipert1=1,natom
3937 : : !ter(:,:)=zero
3938 : : !do idir1=1,3
3939 : : !do ii=1,3
3940 : : !do jj=1,3
3941 : : !if(abs(gprimd(idir1,ii))>1.0d-10)then
3942 : : !ter(idir1,ii)=ter(idir1,ii)+ d2nfr(1,idir1,natom+2,jj,ipert1)*gprimd(jj,ii)
3943 : : !endif
3944 : : !enddo
3945 : : !enddo
3946 : : !add zion to bec
3947 : : !ter(idir1,idir1)=ter(idir1,idir1)+zion(typat(ipert1))
3948 : : !enddo
3949 : : !d2cart(1,:,ipert1,:,natom+2)=ter(:,:)
3950 : : !enddo
3951 : : !carflg(:,1:natom,:,natom+2)=1
3952 : :
3953 : : !Born effective charges from phonon perturbation
3954 : : !do ipert1=1,natom
3955 : : !ter(:,:)=zero
3956 : : !do idir1=1,3
3957 : : !do ii=1,3
3958 : : !do jj=1,3
3959 : : !if(abs(gprimd(idir1,ii))>1.0d-10)then
3960 : : !ter(idir1,ii)=ter(idir1,ii)+ d2nfr(1,jj,ipert1,idir1,natom+2)*gprimd(jj,ii)
3961 : : !endif
3962 : : !enddo
3963 : : !enddo
3964 : : !! add zion to bec
3965 : : !ter(idir1,idir1)=ter(idir1,idir1)+zion(typat(ipert1))
3966 : : !enddo
3967 : : !d2cart(1,:,natom+2,:,ipert1)=ter(:,:)
3968 : : !enddo
3969 : : !carflg(:,natom+2,:,1:natom)=1
3970 : :
3971 : :
3972 : : !!Dielectric constant
3973 : : !do ii=1,3
3974 : : !do jj=1,3
3975 : : !ter(ii,jj)=d2nfr(1,ii,natom+2,jj,natom+2)
3976 : : !end do
3977 : : !end do
3978 : : !ter(:,:)=pi*four*ter(:,:)/ucvol
3979 : : !
3980 : : !do ii=1,3
3981 : : !ter(ii,ii)=ter(ii,ii)+one
3982 : : !end do
3983 : : !d2cart(1,:,natom+2,:,natom+2)=ter(:,:)
3984 : : !carflg(:,natom+2,:,1:natom+2)=1
3985 : :
3986 : : !DEBUG
3987 : : !Debugging, but needed to make the stuff work on the IBM Dirac ? !
3988 : : !write(std_out,*)' d2cart '
3989 : : !ipert2=natom+2
3990 : : !do idir2=1,3
3991 : : !ipert1=natom+2
3992 : : !do idir1=1,3
3993 : : !write(std_out,'(5i4,2d20.10)' )idir1,ipert1,idir2,ipert2,&
3994 : : !& carflg(idir1,ipert1,idir2,ipert2),&
3995 : : !& d2cart(1,idir1,ipert1,idir2,ipert2),&
3996 : : !& d2cart(2,idir1,ipert1,idir2,ipert2)
3997 : : !end do
3998 : : !end do
3999 : : !ENDDEBUG
4000 : :
4001 : :
4002 : 418 : end subroutine dfpt_gatherdy
4003 : : !!***
4004 : :
4005 : : !!****f* ABINIT/dfpt_dyfro
4006 : : !! NAME
4007 : : !! dfpt_dyfro
4008 : : !!
4009 : : !! FUNCTION
4010 : : !! Compute the different parts of the frozen-wavefunction part of
4011 : : !! the dynamical matrix, except the non-local one, computed previously.
4012 : : !! Also (when installed) symmetrize the different part and their sum.
4013 : : !!
4014 : : !! INPUTS
4015 : : !! atindx1(natom)=index table for atoms, inverse of atindx
4016 : : !! dyfr_cplex=1 if dyfrnl is real, 2 if it is complex
4017 : : !! dyfr_nondiag=1 if dyfrnl and dyfrwf are non diagonal with respect to atoms; 0 otherwise
4018 : : !! gmet(3,3)=reciprocal space metric (bohr^-2)
4019 : : !! gprimd(3,3)=dimensional primitive translations for reciprocal space (bohr**-1)
4020 : : !! gsqcut=cutoff on G^2 based on ecut
4021 : : !! indsym(4,nsym,natom)=index showing transformation of atom labels
4022 : : !! under symmetry operations (computed in symatm)
4023 : : !! mgfft=maximum size of 1D FFTs
4024 : : !! mpi_enreg=information about MPI parallelization
4025 : : !! mqgrid=dimensioned number of q grid points for local psp spline
4026 : : !! natom=number of atoms in unit cell
4027 : : !! nattyp(ntypat)=number of atoms of each type
4028 : : !! nfft=(effective) number of FFT grid points (for this processor)
4029 : : !! ngfft(18)=contain all needed information about 3D FFT,
4030 : : !! see ~abinit/doc/variables/vargs.htm#ngfft
4031 : : !! nspden=number of spin-density components
4032 : : !! nsym=number of symmetries in space group
4033 : : !! ntypat=number of types of atoms
4034 : : !! n1xccc=dimension of xccc1d ; 0 if no XC core correction is used
4035 : : !! n3xccc=dimension of the xccc3d array (0 or nfft).
4036 : : !! psps <type(pseudopotential_type)>=variables related to pseudopotentials
4037 : : !! pawtab(ntypat*usepaw) <type(pawtab_type)>=paw tabulated starting data
4038 : : !! ph1d(2,3*(2*mgfft+1)*natom)=one-dimensional structure factor information
4039 : : !! qgrid(mqgrid)=q point array for local psp spline fits
4040 : : !! qphon(3)=wavevector of the phonon
4041 : : !! rhog(2,nfft)=electron density in G space
4042 : : !! rprimd(3,3)=dimensional primitive translation vectors (bohr)
4043 : : !! symq(4,2,nsym)=1 if symmetry preserves present qpoint. From littlegroup_q
4044 : : !! symrec(3,3,nsym)=symmetries in reciprocal space
4045 : : !! typat(natom)=integer type for each atom in cell
4046 : : !! ucvol=unit cell volume (bohr**3).
4047 : : !! usepaw= 0 for non paw calculation; =1 for paw calculation
4048 : : !! vlspl(mqgrid,2,ntypat)=q^2 v(q) spline for each type of atom.
4049 : : !! vxc(nfft,nspden)=exchange-correlation potential (hartree) in real
4050 : : !! space--only used when n1xccc/=0
4051 : : !! xcccrc(ntypat)=XC core correction cutoff radius (bohr) for each atom type
4052 : : !! xccc1d(n1xccc,6,ntypat)=1D core charge function and five derivatives,
4053 : : !! for each type of atom, from psp
4054 : : !! xccc3d(n3xccc)=3D core electron density for XC core correction, bohr^-3
4055 : : !! xred(3,natom)=reduced coordinates for atoms in unit cell
4056 : : !!
4057 : : !! OUTPUT
4058 : : !! dyfrlo(3,3,natom)=frozen wavefunctions part of the dynamical matrix
4059 : : !! (local only)
4060 : : !! dyfrwf(dyfr_cplex,3,3,natom,1+(natom-1)*dyfr_nondiag)=
4061 : : !! frozen wavefunctions part of the dynamical matrix
4062 : : !! (local + non-local)
4063 : : !! If NCPP, it depends on one atom
4064 : : !! If PAW, it depends on two atoms
4065 : : !! dyfrxc(3,3,natom)=frozen wavefunctions part of the dynamical matrix
4066 : : !! (non-linear xc core correction)
4067 : : !!
4068 : : !! SIDE EFFECTS
4069 : : !! Input/Output
4070 : : !! dyfrnl(dyfr_cplex,3,3,natom,1+(natom-1)*dyfr_nondiag)=
4071 : : !! frozen wavefunctions part of the dynamical matrix
4072 : : !! (non-local only)
4073 : : !! If NCPP, it depends on one atom
4074 : : !! If PAW, it depends on two atoms
4075 : : !!
4076 : : !! SOURCE
4077 : :
4078 : 450 : subroutine dfpt_dyfro(atindx1,dyfrnl,dyfrlo,dyfrwf,dyfrxc,dyfr_cplex,dyfr_nondiag,&
4079 : 450 : & dtset,gmet,gprimd,gsqcut,indsym,mgfft,mpi_enreg,mqgrid,natom,nattyp,&
4080 : 450 : & nfft,ngfft,nspden,nsym,ntypat,n1xccc,n3xccc,psps,pawtab,ph1d,qgrid,&
4081 : 450 : & qphon,rhog,rprimd,symq,symrec,typat,ucvol,usepaw,vlspl,vxc,&
4082 : 450 : & xcccrc,xccc1d,xccc3d,xred)
4083 : :
4084 : : !Arguments ------------------------------------
4085 : : !scalars
4086 : : integer,intent(in) :: dyfr_cplex,dyfr_nondiag,mgfft,mqgrid,n1xccc,n3xccc,natom,nfft,nspden
4087 : : integer,intent(in) :: nsym,ntypat,usepaw
4088 : : real(dp),intent(in) :: gsqcut,ucvol
4089 : : type(dataset_type),intent(in) :: dtset
4090 : : type(pseudopotential_type),intent(in) :: psps
4091 : : type(MPI_type),intent(in) :: mpi_enreg
4092 : : !arrays
4093 : : integer,intent(in) :: atindx1(natom),indsym(4,nsym,natom),nattyp(ntypat)
4094 : : integer,intent(in) :: ngfft(18),symq(4,2,nsym),symrec(3,3,nsym),typat(natom)
4095 : : real(dp),intent(in) :: gmet(3,3),gprimd(3,3),ph1d(2,3*(2*mgfft+1)*natom)
4096 : : real(dp),intent(in) :: qgrid(mqgrid),qphon(3),rhog(2,nfft)
4097 : : real(dp),intent(in) :: vlspl(mqgrid,2,ntypat),vxc(nfft,nspden)
4098 : : real(dp),intent(in) :: xccc1d(n1xccc,6,ntypat),xcccrc(ntypat),xred(3,natom)
4099 : : real(dp),intent(inout) :: rprimd(3,3)
4100 : : real(dp),intent(inout) :: dyfrnl(dyfr_cplex,3,3,natom,1+(natom-1)*dyfr_nondiag),xccc3d(n3xccc)
4101 : : real(dp),intent(out) :: dyfrlo(3,3,natom),dyfrwf(dyfr_cplex,3,3,natom,1+(natom-1)*dyfr_nondiag)
4102 : : real(dp),intent(inout) :: dyfrxc(3,3,natom) !vz_i
4103 : : type(pawtab_type),intent(in) :: pawtab(ntypat*usepaw)
4104 : :
4105 : : !Local variables-------------------------------
4106 : : !scalars
4107 : : logical, parameter :: do_final_sym=.true.
4108 : : integer :: iatom,jatom,n1,n2,n3,optatm,optdyfr,opteltfr,optgr,option
4109 : : integer :: optn,optn2,optstr,optv
4110 : : real(dp) :: eei
4111 : : !arrays
4112 : : integer :: qprtrb(3)
4113 : : real(dp) :: dummy6(6),dum_strn(6),dum_strv(6)
4114 : : real(dp) :: tsec(2),vprtrb(2)
4115 : : real(dp) :: dum_atmrho(0),dum_atmvloc(0),dum_gauss(0),dum_grn(0),dum_grv(0),dum_eltfrxc(0)
4116 : 450 : real(dp),allocatable :: dyfrlo_tmp1(:,:,:),dyfrlo_tmp2(:,:,:,:,:),dyfrsym_tmp(:,:,:,:,:)
4117 : 450 : real(dp),allocatable :: gr_dum(:,:),v_dum(:),vxctotg(:,:)
4118 : :
4119 : : ! *************************************************************************
4120 : :
4121 [ + + - + ]: 450 : if(nspden==4 .and. usepaw==1)then
4122 : 0 : ABI_WARNING('dfpt_dyfro : DFPT with nspden=4 works at the moment just for norm-conserving psp! (no paw support yet with nspden=4)')
4123 : : end if
4124 : :
4125 : 450 : n1=ngfft(1); n2=ngfft(2); n3=ngfft(3)
4126 : :
4127 [ + + + + ]: 450 : if (usepaw==1 .or. psps%nc_xccc_gspace==1) then
4128 : :
4129 : : ! PAW or NC with nc_xccc_gspace: compute local psp and core charge contribs together
4130 : : ! in reciprocal space
4131 : : ! -----------------------------------------------------------------------
4132 : 45 : call timab(563,1,tsec)
4133 [ + + ]: 45 : if (n3xccc>0) then
4134 [ - + + - : 123 : ABI_MALLOC(v_dum,(nfft))
+ - + - -
+ - + ]
4135 [ - + + - : 123 : ABI_MALLOC(vxctotg,(2,nfft))
+ - + - -
+ + - ]
4136 [ + + + + : 853721 : v_dum(:)=vxc(:,1);if (nspden>=2) v_dum(:)=0.5_dp*(v_dum(:)+vxc(:,2))
+ + ]
4137 : 41 : call fourdp(1,vxctotg,v_dum,-1,mpi_enreg,nfft,1,ngfft,0)
4138 : : call zerosym(vxctotg,2,ngfft(1),ngfft(2),ngfft(3),&
4139 : 41 : & comm_fft=mpi_enreg%comm_fft,distribfft=mpi_enreg%distribfft)
4140 [ - + ]: 41 : ABI_FREE(v_dum)
4141 : : else
4142 [ - + ]: 4 : ABI_MALLOC(vxctotg,(0,0))
4143 : : end if
4144 : 45 : optatm=0;optdyfr=1;optgr=0;optstr=0;optv=1;optn=n3xccc/nfft;optn2=1;opteltfr=0
4145 : : call atm2fft(atindx1,dum_atmrho,dum_atmvloc,dyfrxc,dyfrlo,dum_eltfrxc,&
4146 : : & dum_gauss,gmet,gprimd,dum_grn,dum_grv,gsqcut,mgfft,mqgrid,natom,nattyp,nfft,ngfft,ntypat,&
4147 : : & optatm,optdyfr,opteltfr,optgr,optn,optn2,optstr,optv,psps,pawtab,ph1d,qgrid,qprtrb,dtset%rcut,rhog,&
4148 : 45 : & rprimd,dum_strn,dum_strv,ucvol,usepaw,vxctotg,vxctotg,vxctotg,vprtrb,vlspl)
4149 [ - + ]: 45 : ABI_FREE(vxctotg)
4150 [ + + + + : 127 : if (n3xccc==0) dyfrxc=zero
+ + + + ]
4151 : : else
4152 : :
4153 : : ! Norm-conserving: compute local psp contribution in reciprocal space
4154 : : ! and core charge contribution in real space
4155 : : ! -----------------------------------------------------------------------
4156 : 405 : option=4
4157 [ - + + - : 1215 : ABI_MALLOC(dyfrlo_tmp1,(3,3,natom))
+ - + - -
+ - + ]
4158 [ - + + - : 1215 : ABI_MALLOC(gr_dum,(3,natom))
+ - + - -
+ - + ]
4159 [ - + + - : 1215 : ABI_MALLOC(v_dum,(nfft))
+ - + - -
+ - + ]
4160 : : call mklocl_recipspace(dyfrlo_tmp1,eei,gmet,gprimd,&
4161 : : & gr_dum,gsqcut,dtset%icutcoul,dummy6,mgfft,mpi_enreg,mqgrid,natom,nattyp,nfft,ngfft,dtset%nkpt,&
4162 : 405 : & ntypat,option,ph1d,qgrid,qprtrb,dtset%rcut,rhog,rprimd,ucvol,dtset%vcutgeo,vlspl,vprtrb,v_dum)
4163 [ + + ]: 1209 : do iatom=1,natom
4164 : : ! Reestablish correct order of atoms
4165 [ + + + + ]: 10857 : dyfrlo(1:3,1:3,atindx1(iatom))=dyfrlo_tmp1(1:3,1:3,iatom)
4166 : : end do
4167 [ - + ]: 405 : ABI_FREE(dyfrlo_tmp1)
4168 [ - + ]: 405 : ABI_FREE(v_dum)
4169 [ + + ]: 405 : if(n1xccc/=0)then
4170 : : call mkcore(dummy6,dyfrxc,gr_dum,mpi_enreg,natom,nfft,nspden,ntypat,&
4171 : 246 : & n1,n1xccc,n2,n3,option,rprimd,typat,ucvol,vxc,xcccrc,xccc1d,xccc3d,xred)
4172 : : end if
4173 [ - + ]: 405 : ABI_FREE(gr_dum)
4174 : : end if
4175 : :
4176 : : !Symmetrize dynamical matrix explicitly for given space group:
4177 : :
4178 : : !Symmetrize local part of the dynamical matrix dyfrlo:
4179 [ - + + - : 1350 : ABI_MALLOC(dyfrsym_tmp,(1,3,3,natom,1))
+ - + - -
+ - + ]
4180 [ - + + - : 900 : ABI_MALLOC(dyfrlo_tmp2,(1,3,3,natom,1))
- + + - ]
4181 [ + + + + : 12644 : dyfrsym_tmp(1,:,:,:,1)=dyfrlo(:,:,:)
+ + ]
4182 : 450 : call dfpt_sydy(1,dyfrsym_tmp,indsym,natom,0,nsym,qphon,dyfrlo_tmp2,symq,symrec)
4183 [ + + + + : 12644 : dyfrlo(:,:,:)=dyfrlo_tmp2(1,:,:,:,1)
+ + ]
4184 : : if (do_final_sym) then
4185 [ + + + + : 12644 : dyfrsym_tmp(1,:,:,:,1)=dyfrxc(:,:,:)
+ + ]
4186 : 450 : call dfpt_sydy(1,dyfrsym_tmp,indsym,natom,0,nsym,qphon,dyfrlo_tmp2,symq,symrec)
4187 [ + + + + : 12644 : dyfrxc(:,:,:)=dyfrlo_tmp2(1,:,:,:,1)
+ + ]
4188 : : end if
4189 [ - + ]: 450 : ABI_FREE(dyfrsym_tmp)
4190 [ - + ]: 450 : ABI_FREE(dyfrlo_tmp2)
4191 : :
4192 : : !Symmetrize nonlocal part of the dynamical matrix dyfrnl:
4193 : : !atindx1 is used to reestablish the correct order of atoms
4194 [ + + ]: 450 : if (dyfr_nondiag==0) then
4195 [ - + + - : 2030 : ABI_MALLOC(dyfrsym_tmp,(dyfr_cplex,3,3,natom,1))
+ - - + +
- + - + -
- + + - ]
4196 [ + + ]: 1212 : do iatom=1,natom
4197 [ + + + + : 18246 : dyfrsym_tmp(:,:,:,atindx1(iatom),1)=dyfrnl(:,:,:,iatom,1)
+ + ]
4198 : : end do
4199 : : else
4200 [ - + + - : 264 : ABI_MALLOC(dyfrsym_tmp,(dyfr_cplex,3,3,natom,natom))
+ - - + +
- - + + -
+ - + - -
+ + - ]
4201 [ + + ]: 176 : do jatom=1,natom
4202 [ + + ]: 768 : do iatom=1,natom
4203 [ + + + + : 13606 : dyfrsym_tmp(:,:,:,atindx1(iatom),atindx1(jatom))=dyfrnl(:,:,:,iatom,jatom)
+ + ]
4204 : : end do
4205 : : end do
4206 : : end if
4207 : 450 : call dfpt_sydy(dyfr_cplex,dyfrsym_tmp,indsym,natom,dyfr_nondiag,nsym,qphon,dyfrnl,symq,symrec)
4208 [ - + ]: 450 : ABI_FREE(dyfrsym_tmp)
4209 : :
4210 : : !Collect local, nl xc core, and non-local part
4211 : : !of the frozen wf dynamical matrix.
4212 [ + + + + : 32302 : dyfrwf(:,:,:,:,:)=dyfrnl(:,:,:,:,:)
+ + + + +
+ ]
4213 [ + + ]: 450 : if (dyfr_nondiag==0) then
4214 [ + + + + : 10884 : dyfrwf(1,:,:,:,1)=dyfrwf(1,:,:,:,1)+dyfrlo(:,:,:)+dyfrxc(:,:,:)
+ + ]
4215 : : else
4216 [ + + ]: 176 : do iatom=1,natom
4217 [ + + + + ]: 1760 : dyfrwf(1,:,:,iatom,iatom)=dyfrwf(1,:,:,iatom,iatom)+dyfrlo(:,:,iatom)+dyfrxc(:,:,iatom)
4218 : : end do
4219 : : end if
4220 : :
4221 : 450 : end subroutine dfpt_dyfro
4222 : : !!***
4223 : :
4224 : : !!****f* ABINIT/dfpt_dyxc1
4225 : : !! NAME
4226 : : !! dfpt_dyxc1
4227 : : !!
4228 : : !! FUNCTION
4229 : : !! Compute 2nd-order non-linear xc core-correction (part1) to the dynamical matrix.
4230 : : !! In case of derivative with respect to k or electric field perturbation,
4231 : : !! the 1st-order local potential vanishes.
4232 : : !!
4233 : : !! INPUTS
4234 : : !! atindx(natom)=index table for atoms
4235 : : !! gmet(3,3)=metrix tensor in G space in Bohr**-2.
4236 : : !! gsqcut=cutoff value on G**2 for sphere inside fft box.
4237 : : !! ixc= choice of exchange-correlation scheme
4238 : : !! kxc(nfft,nkxc)=first-order derivative of the xc potential
4239 : : !! if (nkxc=1) LDA kxc(:,1)= d2Exc/drho2
4240 : : !! if (nkxc=2) LDA kxc(:,1)= d2Exc/drho_up drho_up
4241 : : !! kxc(:,2)= d2Exc/drho_up drho_dn
4242 : : !! kxc(:,3)= d2Exc/drho_dn drho_dn
4243 : : !! if (nkxc=7) GGA kxc(:,1)= d2Exc/drho2
4244 : : !! kxc(:,2)= 1/|grad(rho)| dExc/d|grad(rho)|
4245 : : !! kxc(:,3)= 1/|grad(rho)| d2Exc/d|grad(rho)| drho
4246 : : !! kxc(:,4)= 1/|grad(rho)| * d/d|grad(rho)| ( 1/|grad(rho)| dExc/d|grad(rho)| )
4247 : : !! kxc(:,5)= gradx(rho)
4248 : : !! kxc(:,6)= grady(rho)
4249 : : !! kxc(:,7)= gradz(rho)
4250 : : !! if (nkxc=19) spin-polarized GGA case (same as nkxc=7 with up and down components)
4251 : : !! mgfft=maximum size of 1D FFTs
4252 : : !! mpert=maximum number of ipert
4253 : : !! mpi_enreg=information about MPI parallelization
4254 : : !! mqgrid=number of grid pts in q array for f(q) spline.
4255 : : !! natom=number of atoms in cell.
4256 : : !! nfft=(effective) number of FFT grid points (for this processor)
4257 : : !! ngfft(3)=fft grid dimensions.
4258 : : !! nkxc=second dimension of the kxc array
4259 : : !! (=1 for non-spin-polarized case, =3 for spin-polarized case)
4260 : : !! nmxc= if true, handle density/potential as non-magnetic (even if it is)
4261 : : !! nspden=number of spin-density components
4262 : : !! ntypat=number of types of atoms in cell.
4263 : : !! n1xccc=dimension of xccc1d ; 0 if no XC core correction is used
4264 : : !! psps <type(pseudopotential_type)>=variables related to pseudopotentials
4265 : : !! pawtab(ntypat*usepaw) <type(pawtab_type)>=paw tabulated starting data
4266 : : !! ph1d(2,3*(2*mgfft+1)*natom)=1-dim structure factor phase information
4267 : : !! qgrid(mqgrid)=q grid for spline from 0 to qmax.
4268 : : !! qphon(3)=wavevector of the phonon
4269 : : !! rfdir(3)=array that define the directions of perturbations
4270 : : !! rfpert(mpert)=array defining the type of perturbations that have to be computed
4271 : : !! rprimd(3,3)=dimensional primitive translation vectors (bohr)
4272 : : !! timrev=1 if time-reversal preserves the q wavevector; 0 otherwise.
4273 : : !! typat(natom)=integer type for each atom in cell
4274 : : !! ucvol=unit cell volume (bohr**3).
4275 : : !! usepaw= 0 for non paw calculation; =1 for paw calculation
4276 : : !! xcccrc(ntypat)=XC core correction cutoff radius (bohr) for each atom type
4277 : : !! xccc1d(n1xccc,6,ntypat)=1D core charge function and five derivatives,
4278 : : !! for each type of atom, from psp
4279 : : !! xred(3,natom)=fractional coordinates for atoms in unit cell
4280 : : !!
4281 : : !! OUTPUT! non_magnetic_xc= if true, handle density/potential as non-magnetic (even if it is)
4282 : : !! blkflgfrx1(3,natom,3,natom)=flag to indicate whether an element has been computed or not
4283 : : !! dyfrx1(2,3,natom,3,natom)=2nd-order non-linear xc
4284 : : !! core-correction (part1) part of the dynamical matrix
4285 : : !!
4286 : : !! SOURCE
4287 : :
4288 : 287 : subroutine dfpt_dyxc1(atindx,blkflgfrx1,dyfrx1,gmet,gsqcut,ixc,kxc,mgfft,mpert,mpi_enreg,mqgrid,&
4289 : 287 : & natom,nfft,ngfft,nkxc,nmxc,nspden,ntypat,n1xccc,psps,pawtab,&
4290 : 287 : & ph1d,qgrid,qphon,rfdir,rfpert,rprimd,timrev,typat,ucvol,usepaw,xcccrc,xccc1d,xred,rhor,vxc,ixcrot)
4291 : :
4292 : : use m_cgtools, only : dotprod_vn
4293 : : use m_atm2fft, only : dfpt_atm2fft
4294 : : use m_dfpt_mkvxc, only : dfpt_mkvxc, dfpt_mkvxc_noncoll
4295 : :
4296 : : !Arguments ------------------------------------
4297 : : !scalars
4298 : : integer,intent(in) :: ixc,mgfft,mpert,mqgrid,n1xccc,natom,nfft,nkxc,nspden,ntypat
4299 : : integer,intent(in) :: timrev,usepaw
4300 : : integer,optional,intent(in) :: ixcrot
4301 : : logical,intent(in) :: nmxc
4302 : : real(dp),intent(in) :: gsqcut,ucvol
4303 : : type(pseudopotential_type),intent(in) :: psps
4304 : : type(MPI_type),intent(in) :: mpi_enreg
4305 : : !arrays
4306 : : integer,intent(in) :: atindx(natom),ngfft(18),rfdir(3),rfpert(mpert),typat(natom)
4307 : : real(dp),intent(in) :: gmet(3,3),kxc(nfft,nkxc)
4308 : : real(dp),intent(in) :: ph1d(2,3*(2*mgfft+1)*natom),qgrid(mqgrid),qphon(3)
4309 : : real(dp),intent(in) :: rprimd(3,3),xccc1d(n1xccc,6,ntypat),xcccrc(ntypat)
4310 : : real(dp),intent(in) :: xred(3,natom)
4311 : : integer,intent(out) :: blkflgfrx1(3,natom,3,natom)
4312 : : real(dp),intent(out) :: dyfrx1(2,3,natom,3,natom)
4313 : : type(pawtab_type),intent(in) :: pawtab(ntypat*usepaw)
4314 : : !optional
4315 : : real(dp),optional,intent(in) :: rhor(nfft,nspden)
4316 : : real(dp),optional,intent(in) :: vxc(nfft,nspden)
4317 : :
4318 : : !Local variables-------------------------------
4319 : : !scalars
4320 : : integer :: cplex,iat1,iatom1,iatom2,idir1,idir2,ierr,ifft,my_natom,comm_atom
4321 : : integer :: n1,n2,n3,n3xccc,nfftot,option,upperdir,optnc
4322 : : logical :: paral_atom
4323 : : real(dp) :: valuei,valuer
4324 : : !arrays
4325 : 287 : integer,pointer :: my_atmtab(:)
4326 : : real(dp) :: tsec(2),gprimd_dummy(3,3)
4327 : : real(dp) :: dum_nhat(0)
4328 : 287 : real(dp),allocatable :: rhor1(:,:),vxc10(:,:),xcccwk1(:),xcccwk2(:)
4329 : : ! *********************************************************************
4330 : :
4331 : 287 : call timab(182,1,tsec)
4332 : :
4333 : 287 : n1=ngfft(1) ; n2=ngfft(2) ; n3=ngfft(3)
4334 : 287 : nfftot=n1*n2*n3
4335 : :
4336 : : !Set up parallelism over atoms
4337 : 287 : my_natom=mpi_enreg%my_natom
4338 : 287 : my_atmtab=>mpi_enreg%my_atmtab
4339 : 287 : comm_atom=mpi_enreg%comm_atom
4340 : 287 : paral_atom=(my_natom/=natom)
4341 : :
4342 : : !Zero out the output arrays :
4343 [ + + + + : 30735 : blkflgfrx1(:,:,:,:)=0
+ + + + ]
4344 [ + + + + : 72441 : dyfrx1(:,:,:,:,:)=zero
+ + + + +
+ ]
4345 : :
4346 : 287 : cplex=2-timrev ; n3xccc=nfft
4347 [ - + + - : 1148 : ABI_MALLOC(vxc10,(cplex*nfft,nspden))
- + + - +
- + - - +
- + ]
4348 : :
4349 : :
4350 : : !Loop on the perturbation j1
4351 [ + + ]: 887 : do iat1=1,my_natom
4352 [ + + ]: 600 : iatom1=iat1; if(paral_atom)iatom1=my_atmtab(iat1)
4353 [ + + ]: 2687 : do idir1=1,3
4354 : :
4355 : : ! Compute the derivative of the core charge with respect to j1
4356 [ - + + - : 5400 : ABI_MALLOC(xcccwk1,(cplex*n3xccc))
+ - + - -
+ - + ]
4357 : :
4358 : : ! PAW or NC with nc_xccc_gspace: 1st-order core charge in reciprocal space
4359 [ + + + + ]: 1800 : if (usepaw==1 .or. psps%nc_xccc_gspace==1) then
4360 : : call dfpt_atm2fft(atindx,cplex,gmet,gprimd_dummy,gsqcut,idir1,iatom1,&
4361 : : & mgfft,mqgrid,natom,1,nfft,ngfft,ntypat,ph1d,qgrid,&
4362 : 201 : & qphon,typat,ucvol,usepaw,xred,psps,pawtab,atmrhor1=xcccwk1,optn2_in=1)
4363 : :
4364 : : ! Norm-conserving psp: 1st-order core charge in real space
4365 : : else
4366 : : call dfpt_mkcore(cplex,idir1,iatom1,natom,ntypat,n1,n1xccc,&
4367 : 1599 : & n2,n3,qphon,rprimd,typat,ucvol,xcccrc,xccc1d,xcccwk1,xred)
4368 : : end if
4369 : :
4370 : : ! Compute the corresponding potential
4371 : 1800 : option=0
4372 [ - + + - : 5400 : ABI_MALLOC(rhor1,(cplex*nfft,nspden))
- + + - -
+ + - ]
4373 [ + + + + ]: 41821596 : rhor1=zero
4374 : : !FR SPr EB Non-collinear magnetism
4375 [ + + + - : 1800 : if (nspden==4.and.present(rhor).and.present(vxc).and.present(ixcrot)) then
+ - ]
4376 : 90 : optnc=1
4377 : : call dfpt_mkvxc_noncoll(cplex,ixc,kxc,mpi_enreg,nfft,ngfft,dum_nhat,0,dum_nhat,0,dum_nhat,0,nkxc,&
4378 : 90 : & nmxc,nspden,n3xccc,optnc,option,qphon,rhor,rhor1,rprimd,0,vxc,vxc10,xcccwk1,ixcrot=ixcrot)
4379 : : else
4380 : : call dfpt_mkvxc(cplex,ixc,kxc,mpi_enreg,nfft,ngfft,dum_nhat,0,dum_nhat,0,nkxc,&
4381 : 1710 : & nmxc,nspden,n3xccc,option,qphon,rhor1,rprimd,0,vxc10,xcccwk1)
4382 : : end if
4383 [ - + ]: 1800 : ABI_FREE(rhor1)
4384 [ - + ]: 1800 : ABI_FREE(xcccwk1)
4385 : :
4386 : : ! vxc10 will couple with xcccwk2, that behaves like
4387 : : ! a total density (ispden=1). Only the spin-up + spin-down
4388 : : ! average of vxc10 is needed.
4389 [ + + ]: 1800 : if (nspden/=1)then
4390 [ + + ]: 1336926 : do ifft=1,cplex*nfft
4391 : 1336926 : vxc10(ifft,1)=(vxc10(ifft,1)+vxc10(ifft,2))*half
4392 : : end do
4393 : : end if
4394 : :
4395 : : ! Loop on the perturbation j2
4396 [ + + ]: 6261 : do iatom2=1,iatom1
4397 : 3861 : upperdir=3
4398 [ + + ]: 3861 : if(iatom1==iatom2)upperdir=idir1
4399 [ + + ]: 15444 : do idir2=1,upperdir
4400 [ + + + + : 9783 : if( (rfpert(iatom1)==1 .and. rfdir(idir1) == 1) .or. &
+ + + + ]
4401 : 3861 : & (rfpert(iatom2)==1 .and. rfdir(idir2) == 1) )then
4402 : :
4403 : : ! Compute the derivative of the core charge with respect to j2
4404 [ - + + - : 11472 : ABI_MALLOC(xcccwk2,(cplex*n3xccc))
- + - + ]
4405 : :
4406 : : ! PAW or NC with nc_xccc_gspace: 1st-order core charge in reciprocal space
4407 [ + + + + ]: 5736 : if (usepaw==1 .or. psps%nc_xccc_gspace==1) then
4408 : : call dfpt_atm2fft(atindx,cplex,gmet,gprimd_dummy,gsqcut,idir2,iatom2,&
4409 : : & mgfft,mqgrid,natom,1,nfft,ngfft,ntypat,ph1d,qgrid,&
4410 : 933 : & qphon,typat,ucvol,usepaw,xred,psps,pawtab,atmrhor1=xcccwk2,optn2_in=1)
4411 : :
4412 : : ! Norm-conserving psp: 1st-order core charge in real space
4413 : : else
4414 : : call dfpt_mkcore(cplex,idir2,iatom2,natom,ntypat,n1,n1xccc,&
4415 : 4803 : & n2,n3,qphon,rprimd,typat,ucvol,xcccrc,xccc1d,xcccwk2,xred)
4416 : : end if
4417 : :
4418 : : ! Get the matrix element j1,j2
4419 : :
4420 : 5736 : call dotprod_vn(cplex,xcccwk2,valuer,valuei,nfft,nfftot,1,2,vxc10,ucvol)
4421 : :
4422 [ - + ]: 5736 : ABI_FREE(xcccwk2)
4423 : :
4424 : 5736 : dyfrx1(1,idir1,iatom1,idir2,iatom2)= valuer
4425 : 5736 : dyfrx1(2,idir1,iatom1,idir2,iatom2)= valuei
4426 : 5736 : dyfrx1(1,idir2,iatom2,idir1,iatom1)= valuer
4427 : 5736 : dyfrx1(2,idir2,iatom2,idir1,iatom1)=-valuei
4428 : 5736 : blkflgfrx1(idir1,iatom1,idir2,iatom2)=1
4429 : 5736 : blkflgfrx1(idir2,iatom2,idir1,iatom1)=1
4430 : : end if
4431 : : end do
4432 : : end do
4433 : : end do
4434 : : end do
4435 : :
4436 [ + + ]: 287 : if (paral_atom) then
4437 : 22 : call timab(48,1,tsec)
4438 : 22 : call xmpi_sum(dyfrx1,comm_atom,ierr)
4439 : 22 : call xmpi_sum(blkflgfrx1,comm_atom,ierr)
4440 : 22 : call timab(48,2,tsec)
4441 : : end if
4442 : :
4443 [ - + ]: 287 : ABI_FREE(vxc10)
4444 : :
4445 : 287 : call timab(182,2,tsec)
4446 : :
4447 : 574 : end subroutine dfpt_dyxc1
4448 : : !!***
4449 : :
4450 : : end module m_respfn_driver
4451 : : !!***
|
