Line data Source code
1 : !!****m* ABINIT/m_forctqmc
2 : !! NAME
3 : !! m_forctqmc
4 : !!
5 : !! FUNCTION
6 : !! Prepare CTQMC and call CTQMC
7 : !!
8 : !! COPYRIGHT
9 : !! Copyright (C) 2006-2026 ABINIT group (BAmadon, VPlanes)
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 : !! INPUTS
15 : !!
16 : !! OUTPUT
17 : !!
18 : !! SOURCE
19 :
20 : #if defined HAVE_CONFIG_H
21 : #include "config.h"
22 : #endif
23 :
24 : #include "abi_common.h"
25 :
26 : MODULE m_forctqmc
27 :
28 : use defs_basis
29 : use m_abicore
30 : use m_Ctqmc
31 : use m_CtqmcInterface
32 : use m_Ctqmcoffdiag
33 : use m_CtqmcoffdiagInterface
34 : use m_CtqmcoffdiagComplex
35 : use m_CtqmcoffdiagInterfaceComplex
36 : use m_data4entropyDMFT
37 : use m_errors
38 : use m_GreenHyb
39 : use m_time
40 :
41 : use m_crystal, only : crystal_t
42 : use m_datafordmft, only : compute_levels,hybridization_asymptotic_coefficient
43 : use m_energy, only : compute_migdal_energy,compute_trace_log_loc
44 : use m_fstrings, only : int2char4
45 : use m_green, only : compute_moments_loc,copy_green,destroy_green,green_type, &
46 : & init_green,int_fct,occup_green_tau,print_green
47 : use m_hide_lapack, only : matrginv,xginv
48 : use m_hu, only : copy_hu,destroy_hu,destroy_vee,hu_type,init_vee, &
49 : & rotatevee_hu,vee_type,vee_ndim2tndim_hu_r
50 : use m_io_tools, only : flush_unit,open_file
51 : use m_matlu, only : add_matlu,checkdiag_matlu,checkreal_matlu,chi_matlu,copy_matlu,destroy_matlu, &
52 : & diag_matlu,diff_matlu,fac_matlu,gather_matlu,init_matlu,magmomforb_matlu,magmomfspin_matlu, &
53 : & magmomfzeeman_matlu,matlu_type,print_matlu,printplot_matlu,prod_matlu,rotate_matlu,shift_matlu, &
54 : & slm2ylm_matlu,sym_matlu,symmetrize_matlu,xmpi_matlu,ylm2jmj_matlu,zero_matlu,magnfield_matlu,magmomjmj_matlu
55 : use m_numeric_tools, only : coeffs_gausslegint
56 : use m_oper, only : destroy_oper,gather_oper,identity_oper,init_oper,inverse_oper,oper_type, &
57 : & init_oper_ndat,copy_oper_to_ndat,copy_oper_from_ndat
58 : use m_paw_correlations, only : calc_vee
59 : use m_paw_dmft, only : paw_dmft_type
60 : use m_paw_numeric, only : jbessel => paw_jbessel
61 : use m_pawang, only : pawang_type
62 : use m_self, only : destroy_self,initialize_self,self_type
63 : use m_special_funcs, only : sbf8
64 : use m_splines, only : spline2_complex
65 :
66 : use netcdf !If calling TRIQS via python invocation, write a .nc file
67 :
68 : implicit none
69 :
70 : private
71 :
72 : public :: qmc_prep_ctqmc
73 : public :: testcode_ctqmc
74 : public :: testcode_ctqmc_b
75 : public :: ctqmcoutput_to_green
76 : public :: ctqmcoutput_printgreen
77 : public :: ctqmc_calltriqs
78 : public :: ctqmc_calltriqs_c
79 : !!***
80 :
81 : contains
82 : !!****f* m_forctqmc/qmc_prep_ctqmc
83 : !! NAME
84 : !! qmc_prep_ctqmc
85 : !!
86 : !! FUNCTION
87 : !! Prepare and call the qmc subroutines
88 : !!
89 : !! INPUTS
90 : !! cryst_struc <type(crystal_t)>=crystal structure data
91 : !! self <type(self_type)>= self-energy
92 : !! hu <type(hu_type)>= U interaction
93 : !! paw_dmft <type(paw_dmft_type)>= DMFT data structure
94 : !! pawang <type(pawang)>=paw angular mesh and related data
95 : !! pawprtvol = drive the amount of writed data.
96 : !! weiss <type(green_type)>= weiss function
97 : !!
98 : !! OUTPUT
99 : !! green <type(green_type)>= green function
100 : !!
101 : !! NOTES
102 : !!
103 : !! SOURCE
104 :
105 34 : subroutine qmc_prep_ctqmc(cryst_struc,green,self,hu,paw_dmft,pawang,pawprtvol,weiss)
106 :
107 : !Arguments ------------------------------------
108 : !scalars
109 : ! type(pawang_type), intent(in) :: pawang
110 : type(crystal_t), intent(in) :: cryst_struc
111 : type(green_type), intent(inout) :: green ! MGNAG: This fix the problem with v7[27:29] on nag@petrus
112 : type(hu_type), intent(inout) :: hu(cryst_struc%ntypat)
113 : type(paw_dmft_type), intent(inout) :: paw_dmft
114 : type(pawang_type), intent(in) :: pawang
115 : integer, intent(in) :: pawprtvol
116 : type(green_type), target, intent(inout) :: weiss
117 : type(self_type), intent(inout) :: self
118 : !Local variables ------------------------------
119 : integer :: iatom,icomp,ierr,if1,if2,iflavor1,iflavor2,ifreq,im1,im2,ima,imb,ispa,ispb,ispinor
120 : integer :: ispinor1,ispinor2,isppol,itau,itypat,lpawu,myproc,natom,ndim,nflavor,nomega,nproc
121 : integer :: nspinor,nsppol,nsppol_imp,ntypat,nwlo,opt_diag,opt_fk,opt_nondiag,opt_complex
122 : integer :: opt_rot,rot_type_vee,testcode,testrot,tndim,unt,unt2,useylm,basis,usejmj,opt_hybri
123 : integer, parameter :: optdb = 0
124 : logical :: nondiaglevels
125 : logical(kind=1) :: leg_measure = .true.
126 : real(dp) :: doccsum,EE,f4of2_sla,f6of2_sla,noise,omega
127 34 : type(green_type) :: weiss_for_rot
128 68 : type(oper_type) :: energy_level,level_diag
129 34 : type(CtqmcInterface) :: hybrid
130 102 : type(CtqmcoffdiagInterface) :: hybridoffdiag
131 102 : type(CtqmcoffdiagInterfaceComplex) :: hybridoffdiagComplex
132 : real(dp) :: umod(2,2)
133 : complex(dp) :: integral(2,2)
134 68 : real(dp), allocatable :: docc(:,:),gtmp(:,:),gtmp_nd(:,:,:),levels_ctqmc(:),vee(:,:,:,:)
135 68 : complex(dpc), allocatable :: muorb(:),muspin(:),muzeem(:),levels_ctqmc_complex(:),gtmp_ndc(:,:,:)
136 34 : complex(dpc), allocatable :: fw1(:,:),fw1_nd(:,:,:),gw_tmp(:,:),gw_tmp_nd(:,:,:)
137 68 : complex(dpc), allocatable :: gw1_nd(:,:,:),hybri_limit(:,:),levels_ctqmc_nd(:,:),shift(:)
138 34 : type(coeff2c_type), allocatable :: magmom_orb(:),magmom_spin(:),magmom_tot(:)
139 34 : type(hu_type), allocatable :: hu_for_s(:)
140 34 : type(matlu_type), allocatable :: dmat_diag(:),eigvectmatlu(:),hybri_coeff(:),matlu1(:),matlu2(:),matlu3(:)
141 34 : type(matlu_type), allocatable :: matlu4(:),matlumag(:),matlumag_orb(:),matlumag_spin(:),matlumag_tot(:)
142 34 : type(matlu_type), allocatable :: udens_atoms(:),udens_atoms_for_s(:)
143 34 : type(matlu_type), allocatable :: levels_temp(:),magnfield(:)
144 34 : type(vee_type), allocatable :: vee_for_s(:),vee_rotated(:)
145 : character(len=13) :: tag
146 : character(len=2) :: tag_atom
147 : character(len=500) :: message
148 : real(dp) :: tsec(2)
149 : #ifdef HAVE_OPENMP_OFFLOAD
150 : type(oper_type) :: green_oper_ndat
151 : #endif
152 : ! ************************************************************************
153 :
154 34 : call timab(701,1,tsec(:))
155 34 : call timab(702,1,tsec(:))
156 : !mbandc=paw_dmft%mbandc
157 : !nkpt=paw_dmft%nkpt
158 34 : natom = paw_dmft%natom
159 34 : nspinor = paw_dmft%nspinor
160 34 : nsppol = paw_dmft%nsppol
161 34 : ntypat = paw_dmft%ntypat
162 34 : nwlo = paw_dmft%dmft_nwlo
163 34 : basis = paw_dmft%dmftctqmc_basis
164 : !greendft%whichgreen="DFT"
165 :
166 34 : call init_green(weiss_for_rot,paw_dmft,opt_oper_ksloc=2)
167 : ! call init_green(gw_loc,paw_dmft)
168 34 : call copy_green(weiss,weiss_for_rot,opt_tw=2)
169 : !=======================================================================
170 : !== Use one QMC solver ===============================================
171 : !=======================================================================
172 34 : write(message,'(3a)') ch10,' === CT-QMC solver === '
173 34 : call wrtout(std_out,message,'COLL')
174 :
175 : ! Initialise for compiler
176 : ! omega_current=czero
177 :
178 : ! Initialise nproc
179 34 : nproc=paw_dmft%nproc
180 34 : myproc = paw_dmft%myproc
181 :
182 : ! ======================================
183 : ! Allocations: diagonalization and eigenvectors
184 : ! ======================================
185 164 : ABI_MALLOC(udens_atoms,(natom))
186 130 : ABI_MALLOC(eigvectmatlu,(natom))
187 164 : ABI_MALLOC(magmom_orb,(natom))
188 130 : ABI_MALLOC(matlumag_orb,(natom))
189 130 : ABI_MALLOC(magmom_spin,(natom))
190 130 : ABI_MALLOC(matlumag_spin,(natom))
191 130 : ABI_MALLOC(magmom_tot,(natom))
192 130 : ABI_MALLOC(matlumag_tot,(natom))
193 34 : if (paw_dmft%ientropy == 1) then
194 0 : ABI_MALLOC(udens_atoms_for_s,(natom))
195 : end if
196 130 : ABI_MALLOC(dmat_diag,(natom))
197 34 : call init_matlu(natom,nspinor,nsppol,paw_dmft%lpawu(:),dmat_diag(:))
198 34 : call init_matlu(natom,nspinor,nsppol,paw_dmft%lpawu(:),eigvectmatlu(:))
199 34 : call init_matlu(natom,2,1,paw_dmft%lpawu(:),udens_atoms(:))
200 34 : if (paw_dmft%ientropy == 1) then
201 0 : call init_matlu(natom,2,1,paw_dmft%lpawu(:),udens_atoms_for_s(:))
202 : end if
203 96 : do iatom=1,natom
204 62 : lpawu = paw_dmft%lpawu(iatom)
205 62 : if (lpawu == -1) cycle
206 136 : ABI_MALLOC(magmom_orb(iatom)%value,(2*(2*lpawu+1),2*(2*lpawu+1)))
207 4698 : magmom_orb(iatom)%value=czero
208 102 : ABI_MALLOC(magmom_spin(iatom)%value,(2*(2*lpawu+1),2*(2*lpawu+1)))
209 4698 : magmom_spin(iatom)%value=czero
210 102 : ABI_MALLOC(magmom_tot(iatom)%value,(2*(2*lpawu+1),2*(2*lpawu+1)))
211 4760 : magmom_tot(iatom)%value=czero
212 : end do ! iatom
213 :
214 : ! =================================================================
215 : ! Impose diago of density matrix
216 : ! =================================================================
217 :
218 : ! =================================================================
219 : ! Impose diago of levels and Ylm basis if opt_nondiag=1
220 : ! =================================================================
221 : ! opt_diag=1 ! 1: diago the levels (The best choice).
222 : ! opt_diag=2 ! 2: diago density matrix (can be used for historical reasons)
223 :
224 : ! Need in the general case of two input variable for opt_diag and
225 : ! opt_nondiag!
226 : ! opt_nondiag should be 0 by default
227 34 : opt_diag = 1
228 34 : opt_nondiag = 0
229 34 : if (paw_dmft%dmft_solv >= 6) opt_nondiag = 1 ! Use ctqmc in abinit with offdiag terms in F
230 : !else
231 : ! opt_nondiag = 0 ! use fast ctqmc in ABINIT without off diagonal terms in F
232 : !end if
233 :
234 34 : useylm = 0
235 34 : if (nspinor == 2) useylm = 1 ! to avoid complex G(tau)
236 34 : if (basis .eq. 4) then
237 0 : useylm = 1 ! first step before rotation to jmj
238 0 : usejmj = 1 ! jmj local basis
239 0 : opt_diag = 0 ! no diagonalization of local Hamiltonian
240 0 : opt_nondiag = 1 ! off_diag element taken into account
241 : else
242 34 : usejmj = 0
243 : endif
244 :
245 34 : opt_complex = 0
246 34 : if (paw_dmft%dmft_solv .eq. 10) then
247 0 : opt_complex = 1 !Complex G(tau)
248 0 : opt_hybri = paw_dmft%dmft_hybri_limit
249 : endif
250 :
251 : !write(6,*) "nspinor,useylm",nspinor,useylm
252 34 : if (useylm == 0) then
253 34 : write(std_out,*) " Slm (real spherical harmonics) basis is used (before a possible rotation)"
254 34 : rot_type_vee = 1 ! for rotatevee_hu
255 : ! else if (useylm == 1) then
256 : ! !write(std_out,*) " Ylm (complex spherical harmonics) basis is used (before rotation)"
257 : ! write(message,'(3a)') ch10," == Only Density-Density Terms Included"
258 : ! call wrtout(std_out,message,'COLL')
259 0 : else if (useylm == 1 .and. usejmj == 0) then
260 0 : write(message,'(3a)') ch10," == Only Density-Density Terms Included"
261 0 : call wrtout(std_out,message,'COLL')
262 : !write(std_out,*) " Ylm (complex spherical harmonics) basis is used (before rotation)"
263 0 : rot_type_vee = 4 ! for rotatevee_hu
264 0 : else if (useylm == 1 .and. usejmj == 1) then
265 0 : write(message,'(3a)') ch10,' == Jmj local basis is used without diagonalization of local Hamiltonian ',ch10
266 0 : call wrtout(std_out,message,'COLL')
267 0 : rot_type_vee = 3 !
268 : end if ! useylm
269 :
270 : ! if(useylm==1.and.opt_diag/=1) ABI_ERROR("useylm==1 and opt_diag/=0 is not possible")
271 34 : if (hu(1)%jpawu_zero .and. nsppol == 2) nsppol_imp = 2 ! J=0 and nsppol=2
272 34 : if (.not. hu(1)%jpawu_zero .or. nsppol /= 2) nsppol_imp = 1 ! J/=0 ou nsppol=1
273 : ! =================================================================
274 : ! Compute DFT Green's function to compare to weiss_for_rot (check)
275 : ! =================================================================
276 : ! call init_green(greendft,paw_dmft,opt_oper_ksloc=3)
277 : ! call greendftcompute_green(cryst_struc,greendft,pawang,paw_dmft)
278 : !! call copy_green(greendft,weiss_for_rot,2)
279 :
280 : ! =================================================================
281 : ! Compute atomic levels
282 : ! =================================================================
283 34 : call init_oper(paw_dmft,energy_level,opt_ksloc=2)
284 :
285 : ! ----------------------------------
286 : ! Compute atomic levels in Slm basis
287 : ! ----------------------------------
288 34 : call compute_levels(energy_level,self%hdc,paw_dmft,nondiag=nondiaglevels)
289 :
290 : ! ------------------------------------------------
291 : ! If levels are not diagonal, then diagonalize it (according to
292 : ! dmftctqmc_basis)
293 : ! dmftctqmc_basis = 0 : Slm
294 : ! dmftctqmc_basis = 1 : diagonalize hamiltonian
295 : ! dmftctqmc_basis = 2 : Ylm
296 : ! dmftctqmc_basis = 3 : digonalize occupation matrix
297 : ! dmftctqmc_basis = 4 : JmJ
298 : ! ------------------------------------------------
299 34 : if (paw_dmft%dmftctqmc_basis == 1) then
300 20 : if (nondiaglevels .or. useylm == 1) then
301 0 : opt_diag = 1
302 0 : write(message,'(3a)') ch10," == Hamiltonian in local basis is not diagonal: diagonalize it",ch10
303 : else
304 20 : opt_diag = 0
305 20 : write(message,'(5a)') ch10," == Hamiltonian in local basis is diagonal in the Slm basis ",ch10, &
306 40 : & " CTQMC will use this basis",ch10
307 : end if ! nondiaglevels or useylm
308 14 : else if (paw_dmft%dmftctqmc_basis == 2) then
309 14 : if (nondiaglevels .or. useylm == 1) then
310 14 : write(message,'(7a)') ch10," == Hamiltonian in local basis is not diagonal",ch10, &
311 14 : & " == According to dmftctqmc_basis: diagonalize density matrix",ch10, &
312 28 : & " == Warning : Check that the Hamiltonian is diagonal !",ch10
313 14 : opt_diag = 2
314 : else
315 0 : write(message,'(5a)') ch10," == Hamiltonian in local basis is diagonal in the Slm basis ",ch10, &
316 0 : & " CTQMC will use this basis",ch10
317 0 : opt_diag = 0
318 : end if ! nondiaglevels or useylm
319 0 : else if (paw_dmft%dmftctqmc_basis == 0) then
320 0 : if (nondiaglevels) then
321 0 : write(message,'(4a)') ch10," == Hamiltonian in local basis is not diagonal",ch10, &
322 0 : & " == According to dmftctqmc_basis: keep this non diagonal basis for the calculation"
323 : else
324 0 : write(message,'(5a)') ch10," == Hamiltonian in local basis is diagonal in the Slm basis ",ch10, &
325 0 : & " CTQMC will use this basis",ch10
326 : end if ! nondiaglevels
327 0 : opt_diag = 0
328 : end if ! dmftctqmc_basis
329 34 : call wrtout(std_out,message,'COLL')
330 34 : if (opt_diag == 1) then
331 0 : write(message,'(5a)') " == Switching to CTQMC basis: using basis that diagonalizes the electronic levels"
332 0 : call wrtout(std_out,message,'COLL')
333 34 : else if (opt_diag == 2) then
334 14 : write(message,'(5a)') " == The correlated occupation matrix is diagonalized"
335 14 : call wrtout(std_out,message,'COLL')
336 : end if ! opt_diag
337 :
338 : ! =================================================================
339 : ! Now, check if diagonalisation is necessary
340 : ! =================================================================
341 :
342 :
343 : ! =================================================================
344 : ! First rotate to Ylm basis the atomic levels
345 : ! =================================================================
346 :
347 34 : if (useylm == 1) then
348 :
349 0 : write(message,'(2a)') ch10, " == Switching to Ylm basis first"
350 0 : call wrtout(std_out,message,'COLL')
351 :
352 : ! Rotate from Slm to Ylm the atomic levels
353 : ! ----------------------------------------
354 0 : call slm2ylm_matlu(energy_level%matlu(:),natom,paw_dmft,1,0)
355 :
356 : ! Print atomic energy levels in Ylm basis
357 : ! --------------------------------
358 0 : if (pawprtvol >= 3) then
359 0 : write(message,'(2a)') ch10," == Print Energy levels in Ylm basis"
360 0 : call wrtout(std_out,message,'COLL')
361 0 : call print_matlu(energy_level%matlu(:),natom,1)
362 : end if ! pawprtvol>=3
363 :
364 : !==================================================================
365 : ! Add Zeeman contributions to local energy levels when nspinor = 2
366 : !==================================================================
367 0 : if(paw_dmft%dmft_magnfield .eq. 2 .and. nspinor .eq. 2) then
368 :
369 0 : ABI_MALLOC(magnfield,(natom))
370 0 : ABI_MALLOC(levels_temp,(natom))
371 :
372 0 : write(message,'(a,2x,a)') ch10, " == Add Zeeman contributions to local energy levels in Ylm"
373 0 : call wrtout(std_out,message,'COLL')
374 :
375 0 : call init_matlu(natom,nspinor,nsppol,paw_dmft%lpawu,magnfield)
376 0 : call init_matlu(natom,nspinor,nsppol,paw_dmft%lpawu,levels_temp)
377 0 : call copy_matlu(energy_level%matlu,levels_temp,natom)
378 :
379 : !Spin-Orbit case, not much tested so far (need to remove AFM sym)
380 0 : call magnfield_matlu(magnfield,natom,paw_dmft%dmft_magnfield_b,2)
381 : !call print_matlu(magnfield,natom,1)
382 0 : call add_matlu(levels_temp,magnfield,energy_level%matlu,natom,-1)
383 0 : call print_matlu(energy_level%matlu,natom,1)
384 0 : call destroy_matlu(magnfield,natom)
385 0 : call destroy_matlu(levels_temp,natom)
386 :
387 0 : ABI_FREE(magnfield)
388 0 : ABI_FREE(levels_temp)
389 : endif !dmft_magnfield
390 : end if ! useylm
391 :
392 34 : if (usejmj .eq. 1) then
393 : !rotate form Ylm to jmj the atomic levels
394 0 : call ylm2jmj_matlu(energy_level%matlu(:),natom,1,paw_dmft)
395 :
396 : ! Print atomic energy levels in Ylm basis
397 : ! --------------------------------
398 0 : if (pawprtvol >= 3) then
399 0 : write(message,'(2a)') ch10," == Print Energy levels in jmj basis"
400 0 : call wrtout(std_out,message,'COLL')
401 0 : call print_matlu(energy_level%matlu(:),natom,1)
402 : end if ! pawprtvol>=3
403 : endif
404 :
405 130 : ABI_MALLOC(vee_rotated,(natom))
406 34 : call init_vee(paw_dmft,vee_rotated(:))
407 :
408 : ! ===========================================================================================
409 : ! Start for diagonalization of levels/density matrix according to opt_diag
410 : ! ===========================================================================================
411 :
412 : !opt_rot=2 ! do it one time before CTQMC
413 34 : opt_rot = 1 ! do all the rotations successively on all different quantities.
414 34 : if (opt_diag == 1 .or. opt_diag == 0) then
415 :
416 20 : if (opt_diag == 1) then
417 : ! =================================================================
418 : ! Diagonalize atomic levels
419 : ! =================================================================
420 0 : call init_oper(paw_dmft,level_diag,opt_ksloc=2)
421 :
422 : ! Diagonalize atomic levels (opt_real is necessary, because
423 : ! rotation must be real in order for the occupations and Green's
424 : ! function to be real)
425 : ! ---------------------------------------------------------------
426 0 : write(message,'(2a)') ch10, " == Diagonalization of local Hamiltonian"
427 0 : call wrtout(std_out,message,'COLL')
428 :
429 : call diag_matlu(energy_level%matlu(:),level_diag%matlu(:),natom,pawprtvol,eigvectmatlu(:),&
430 0 : & nsppol_imp=nsppol_imp,opt_real=1,test=paw_dmft%dmft_solv) ! temporary: test should be extended to all cases.
431 :
432 : ! call rotate_matlu(energy_level%matlu,eigvectmatlu,natom,3,1)
433 : ! write(message,'(a,2x,a,f13.5)') ch10,&
434 : !& " == Print first Diagonalized Energy levels for Fermi Level=",paw_dmft%fermie
435 : ! call wrtout(std_out,message,'COLL')
436 : ! call print_matlu(energy_level%matlu,natom,1,compl=1,opt_exp=1)
437 :
438 : if (opt_rot == 1) then
439 0 : call copy_matlu(level_diag%matlu(:),energy_level%matlu(:),natom)
440 : end if
441 :
442 0 : call destroy_oper(level_diag)
443 :
444 : ! Print diagonalized levels
445 : ! --------------------------
446 0 : write(tag,'(f13.5)') paw_dmft%fermie
447 0 : if (pawprtvol >= 3) then
448 0 : write(message,'(a,2x,2a)') ch10,&
449 0 : & " == Print Energy levels in CTQMC basis"
450 0 : call wrtout(std_out,message,'COLL')
451 0 : call print_matlu(energy_level%matlu(:),natom,1,compl=0)
452 : else
453 0 : write(message,'(a,2x,2a)') ch10,&
454 0 : & " == Energy levels Diagonalized for Fermi Level=",adjustl(tag)
455 0 : call wrtout(std_out,message,'COLL')
456 : end if ! pawprtvol>=3
457 :
458 : else if (opt_diag == 0) then
459 68 : do iatom = 1, natom
460 48 : lpawu = paw_dmft%lpawu(iatom)
461 48 : if (lpawu == -1) cycle
462 20 : itypat = paw_dmft%typat(iatom)
463 : ! write(6,*) size(udens_atoms(iatom)%value)
464 : ! write(6,*) size(hu(itypat)%udens)
465 : ! write(6,*) udens_atoms(iatom)%value
466 : ! write(6,*) hu(itypat)%udens
467 : !udens_atoms(iatom)%mat(:,:,1)=hu(itypat)%udens(:,:)
468 155328 : vee_rotated(iatom)%mat(:,:,:,:) = hu(itypat)%veeslm2(:,:,:,:)
469 :
470 40 : if (usejmj == 1) then
471 0 : do iflavor1=1,tndim
472 0 : do iflavor2=1,tndim
473 0 : if(iflavor1==iflavor2) then
474 0 : eigvectmatlu(iatom)%mat(iflavor1,iflavor2,1)=cone
475 : else
476 0 : eigvectmatlu(iatom)%mat(iflavor1,iflavor2,1)=czero
477 : end if
478 : end do
479 : end do
480 :
481 0 : call rotatevee_hu(hu(:),paw_dmft,pawprtvol,eigvectmatlu(:),rot_type_vee,udens_atoms(:),vee_rotated(:))
482 :
483 : else
484 1744 : udens_atoms(iatom)%mat(:,:,1)=hu(itypat)%udens(:,:)
485 : endif
486 : end do ! iatom
487 : end if ! opt_diag=0 or 1
488 : ! call rotatevee_hu(cryst_struc,hu,nspinor,nsppol,pawprtvol,eigvectmatlu,udens_atoms)
489 :
490 14 : else if (opt_diag == 2) then
491 : ! =================================================================
492 : ! Diagonalizes density matrix and keep eigenvectors in eigvectmatlu
493 : ! =================================================================
494 :
495 : ! Print density matrix before diagonalization
496 : ! -------------------------------------------
497 14 : if (pawprtvol >= 3) then
498 14 : write(message,'(a,2x,a)') ch10," == Density Matrix before diagonalization ="
499 14 : call wrtout(std_out,message,'COLL')
500 : !MGNAG: This call is wrong if green has intent(out), now we use intent(inout)
501 14 : call print_matlu(green%occup%matlu(:),natom,1)
502 : end if ! pawprtvol>=3
503 :
504 : !! checkstop: we can have two different diagonalisation basis for the up and dn
505 : !! but one use the same basis, unless the error is really to large(>0.1)
506 :
507 : ! Diagonalize density matrix
508 : ! ---------------------------
509 : call diag_matlu(green%occup%matlu(:),dmat_diag(:),natom,4,eigvectmatlu(:), &
510 14 : & nsppol_imp=nsppol_imp,checkstop=.false.)
511 :
512 : ! Print diagonalized density matrix
513 : ! ----------------------------------
514 14 : if (pawprtvol >= 3) then
515 14 : write(message,'(a,2x,a)') ch10,&
516 28 : & " == Diagonalized Density Matrix in the basis used for QMC ="
517 14 : call wrtout(std_out,message,'COLL')
518 14 : call print_matlu(dmat_diag(:),natom,1)
519 :
520 : !write(message,'(2a,i3,13x,a)') ch10,' == Rotation of interaction matrix =='
521 : !call wrtout(std_out,message,'COLL')
522 : end if ! pawprtvol>=3
523 :
524 : !if (.not.hu(1)%jpawu_zero) &
525 : !ABI_WARNING("In qmc_prep_ctqmc J/=0 and rotation matrix not rotated")
526 : ! Rotate interaction.
527 : ! call rotatevee_hu(cryst_struc,hu,nspinor,nsppol,pawprtvol,eigvectmatlu,udens_atoms)
528 : ! call rotatevee_hu(cryst_struc,hu,nspinor,nsppol,pawprtvol,eigvectmatlu,udens_atoms,rot_type_vee)
529 : end if
530 : ! ===========================================================================================
531 : ! END Of diagonalization
532 : ! ===========================================================================================
533 :
534 34 : if (paw_dmft%ientropy == 1) then
535 0 : ABI_MALLOC(hu_for_s,(ntypat))
536 : ! Usefull to compute interaction energy for U=1 J=J/U when U=0.
537 0 : call copy_hu(ntypat,hu(:),hu_for_s(:))
538 0 : f4of2_sla = - one
539 0 : f6of2_sla = - one
540 0 : do itypat=1,ntypat
541 0 : ndim = 2*hu(itypat)%lpawu + 1
542 0 : ABI_MALLOC(vee,(ndim,ndim,ndim,ndim))
543 : call calc_vee(f4of2_sla,f6of2_sla,paw_dmft%j_for_s/paw_dmft%u_for_s, &
544 0 : & hu_for_s(itypat)%lpawu,pawang,one,vee(:,:,:,:))
545 0 : hu_for_s(itypat)%vee(:,:,:,:) = cmplx(vee(:,:,:,:),zero,kind=dp)
546 0 : ABI_FREE(vee)
547 : end do
548 0 : ABI_MALLOC(vee_for_s,(natom))
549 0 : call init_vee(paw_dmft,vee_for_s(:))
550 : call rotatevee_hu(hu_for_s(:),paw_dmft,pawprtvol,eigvectmatlu(:), &
551 0 : & rot_type_vee,udens_atoms_for_s(:),vee_for_s(:))
552 0 : call destroy_hu(hu_for_s(:),ntypat)
553 : ! udens_atoms_for_s will be used later.
554 0 : ABI_FREE(hu_for_s)
555 0 : call destroy_vee(paw_dmft,vee_for_s(:))
556 0 : ABI_FREE(vee_for_s)
557 : end if ! ientropy=1
558 :
559 34 : call flush_unit(std_out)
560 :
561 : ! ===========================================================================================
562 : ! Broadcast matrix of rotation from processor 0 to the other
563 : ! In case of degenerate levels, severals rotations are possible. Here we
564 : ! choose the rotation of proc 0. It is arbitrary.
565 : ! ===========================================================================================
566 34 : call xmpi_matlu(eigvectmatlu(:),natom,paw_dmft%spacecomm,master=0,option=2)
567 :
568 34 : if (opt_diag /= 0 ) then
569 : call rotatevee_hu(hu(:),paw_dmft,pawprtvol,eigvectmatlu(:), &
570 14 : & rot_type_vee,udens_atoms(:),vee_rotated(:))
571 : end if
572 :
573 : !unitnb=300000+paw_dmft%myproc
574 : !call int2char4(paw_dmft%myproc,tag_proc)
575 : !tmpfil = 'eigvectmatluaftermpi'//tag_proc
576 : !open (unit=unitnb,file=trim(tmpfil),status='unknown',form='formatted')
577 : !do iflavor1=1,14
578 : ! do iflavor2=1,14
579 : ! write(unitnb,*) iflavor1,iflavor2,eigvectmatlu(1,1)%value(iflavor1,iflavor2)
580 : ! enddo
581 : !enddo
582 :
583 : ! ===========================================================================================
584 : ! Now rotate various quantities in the new basis
585 : ! ===========================================================================================
586 :
587 : !=======================================================
588 : ! Allocate, Compute, and Rotate atomic levels for CTQMC
589 : !=======================================================
590 :
591 : ! If levels not rotated, rotate them
592 : ! -----------------------------------
593 34 : if (opt_diag == 2 .and. opt_rot == 1) then
594 14 : call rotate_matlu(energy_level%matlu(:),eigvectmatlu(:),natom,1)
595 : end if
596 :
597 : ! Print atomic levels
598 : ! -------------------
599 34 : if (pawprtvol >= 3 .and. opt_diag == 2 .and. opt_rot == 1) then
600 14 : write(message,'(a,2x,a)') ch10," == Print Energy levels in CTQMC basis"
601 14 : call wrtout(std_out,message,'COLL')
602 14 : call print_matlu(energy_level%matlu(:),natom,1)
603 20 : else if (opt_diag == 2 .and. opt_rot == 1) then
604 0 : write(message,'(a,2x,a)') ch10," == CT-QMC Energy levels rotated"
605 0 : call wrtout(std_out,message,'COLL')
606 : end if ! pawprtvol>=3
607 :
608 : !====================================================================
609 : ! If levels were diagonalized before, then rotate density matrix for
610 : ! information.
611 : !====================================================================
612 34 : if (opt_diag == 1) then
613 :
614 0 : ABI_MALLOC(matlu1,(natom))
615 0 : call init_matlu(natom,nspinor,nsppol,paw_dmft%lpawu(:),matlu1(:))
616 0 : call copy_matlu(green%occup%matlu(:),matlu1(:),natom)
617 0 : if (pawprtvol >= 3) then
618 0 : write(message,'(a,2x,a)') ch10," == Print occupations in cubic basis"
619 0 : call wrtout(std_out,message,'COLL')
620 0 : call print_matlu(green%occup%matlu(:),natom,1)
621 : end if ! pawprtvol>=3
622 :
623 : ! 1) rotate density matrix to Ylm basis
624 : ! --------------------------------------
625 0 : if (useylm == 1) then
626 0 : call slm2ylm_matlu(matlu1(:),natom,paw_dmft,1,0)
627 : ! if (pawprtvol >= 3 ) then
628 : ! write(message,'(2a)') ch10," == Print occupations in Ylm basis"
629 : ! call wrtout(std_out,message,'COLL')
630 : ! call print_matlu(matlu1(:),natom,1)
631 : ! end if
632 : end if ! useylm
633 :
634 : ! 2) rotate density matrix to rotated basis
635 : ! -------------------------------------------
636 : if (opt_rot == 1 .or. opt_rot == 2) then
637 0 : call rotate_matlu(matlu1(:),eigvectmatlu(:),natom,1)
638 : end if
639 0 : write(message,'(a,2x,a)') ch10," == Print occupations in CTQMC basis"
640 0 : call wrtout(std_out,message,'COLL')
641 0 : call print_matlu(matlu1(:),natom,1,compl=1)
642 0 : if (paw_dmft%dmft_solv .eq. 10) then
643 0 : write(message,'(a,2x,a)') ch10," The potential complex off diagonal occupation matrix elements are &
644 0 : &taken into account in the CT-QMC with dmft_solv = 10."
645 0 : call wrtout(std_out,message,'COLL')
646 : else
647 0 : call checkreal_matlu(matlu1(:),natom,tol10)
648 : endif
649 0 : call destroy_matlu(matlu1(:),natom)
650 0 : ABI_FREE(matlu1)
651 :
652 : end if ! opt_diag=1
653 :
654 34 : call flush_unit(std_out)
655 :
656 : ! =================================================================
657 : ! Rotate weiss function according to eigenvectors.
658 : ! =================================================================
659 : !!!stop
660 : ! Rotate Weiss function first in Ylm basis
661 : ! -----------------------------------------------------------------
662 34 : if (pawprtvol >= 3) then
663 28 : write(message,'(a,2x,a)') ch10, " == Print Weiss-field for first frequency in Cubic basis"
664 28 : call wrtout(std_out,message,'COLL')
665 28 : call print_matlu(weiss_for_rot%oper(1)%matlu(:),natom,1,compl=1) !
666 : endif
667 :
668 34 : if(useylm==1) then
669 : !write(message,'(a,2x,a)') ch10, " == Rotation of weiss and greendft in the Ylm Basis="
670 : !call wrtout(std_out,message,'COLL')
671 0 : do ifreq=1,nwlo
672 0 : call slm2ylm_matlu(weiss_for_rot%oper(ifreq)%matlu(:),natom,paw_dmft,1,0)
673 0 : call slm2ylm_matlu(weiss%oper(ifreq)%matlu(:),natom,paw_dmft,1,0)
674 : ! call slm2ylm_matlu(greendft%oper(ifreq)%matlu,natom,1,0)
675 : end do
676 : end if
677 :
678 34 : if(usejmj==1) then
679 0 : write(message,'(a,2x,a)') ch10, " == Rotation of weiss and greendft in the jmj Basis="
680 0 : call wrtout(std_out,message,'COLL')
681 0 : do ifreq=1,nwlo
682 0 : call ylm2jmj_matlu(weiss_for_rot%oper(ifreq)%matlu(:),natom,1,paw_dmft)
683 0 : call ylm2jmj_matlu(weiss%oper(ifreq)%matlu(:),natom,1,paw_dmft)
684 : end do
685 : end if
686 :
687 :
688 : if (pawprtvol >= 3) then
689 : ! write(message,'(a,2x,a,f13.5)') ch10,& ! debug
690 : ! " == Print weiss for small freq 1 before rot" ! debug
691 : ! call wrtout(std_out,message,'COLL') ! debug
692 : ! call print_matlu(weiss_for_rot%oper(1)%matlu,natom,1) ! debug
693 :
694 : ! Print Weiss function
695 : ! --------------------
696 : ! write(message,'(a,2x,a)') ch10," == Print weiss for 1st freq before rot" ! debug
697 : ! call wrtout(std_out,message,'COLL') ! debug
698 : ! call print_matlu(weiss_for_rot%oper(1)%matlu(:),natom,1,compl=1) ! debug
699 : ! write(message,'(a,2x,a)') ch10," == Print weiss for last freq before rot" ! debug
700 : ! call wrtout(std_out,message,'COLL') ! debug
701 : ! call print_matlu(weiss_for_rot%oper(nwlo)%matlu(:),natom,1,compl=1) ! debug
702 : ! write(message,'(a,2x,a,f13.5)') ch10,& ! debug
703 : !& " == Print DFT G for 1st freq before rot" ! debug
704 : ! call wrtout(std_out,message,'COLL') ! debug
705 : ! call print_matlu(greendft%oper(1)%matlu,natom,1,compl=1,opt_exp=2) ! debug
706 : ! write(message,'(a,2x,a,f13.5)') ch10,& ! debug
707 : !& " == Print DFT G for last freq before rot" ! debug
708 : ! call wrtout(std_out,message,'COLL') ! debug
709 : ! call print_matlu(greendft%oper(paw_dmft%dmft_nwlo)%matlu,natom,1,compl=1,opt_exp=2) ! debug
710 : end if ! pawprtvol>=3
711 :
712 34 : if (opt_diag /= 0) then
713 : ! Rotate Weiss function from the Slm (or Ylm) to the basis of diagonalisation
714 : ! -------------------------------------------------------------------
715 : !write(message,'(a,2x,a)') ch10, " == Rotation of weiss ="
716 : !call wrtout(std_out,message,'COLL')
717 :
718 1274 : do ifreq=1,nwlo
719 14 : if (opt_rot == 1) then
720 1260 : call rotate_matlu(weiss_for_rot%oper(ifreq)%matlu(:),eigvectmatlu(:),natom,1)
721 1260 : call rotate_matlu(weiss%oper(ifreq)%matlu(:),eigvectmatlu(:),natom,1)
722 : end if ! opt_rot=1
723 : ! call checkdiag_matlu(weiss_for_rot%oper(ifreq)%matlu,natom,tol6)
724 : end do ! ifreq
725 :
726 28 : do iatom=1,natom
727 :
728 14 : if (iatom < 10) then
729 14 : write(tag_atom,'("0",I1)') iatom
730 : else
731 0 : write(tag_atom,'(I2)') iatom
732 : endif
733 :
734 : !print Weiss field for correlated atoms
735 14 : lpawu = paw_dmft%lpawu(iatom)
736 14 : if (lpawu == -1) cycle
737 :
738 28 : if (myproc == mod(nproc+1,nproc)) then
739 8 : if (open_file(trim(paw_dmft%filapp)//"_atom_"//tag_atom//"_G0w.dat",message,newunit=unt) /= 0) ABI_ERROR(message)
740 8 : ndim = 2*paw_dmft%lpawu(iatom) + 1
741 728 : do ifreq=1,nwlo
742 720 : write(unt,'(29f21.14)') paw_dmft%omega_lo(ifreq),&
743 2880 : & (((weiss_for_rot%oper(ifreq)%matlu(iatom)%mat(im1+(ispinor-1)*ndim,im1+(ispinor-1)*ndim,isppol),&
744 5048 : & im1=1,3),ispinor=1,nspinor),isppol=1,nsppol)
745 : end do ! ifreq
746 8 : close(unit=unt)
747 : end if ! myproc=master
748 : enddo
749 :
750 14 : call flush_unit(std_out)
751 14 : if (pawprtvol >= 3) then
752 14 : write(message,'(a,2x,a)') ch10," == Print Weiss-field for first frequency in CTQMC basis" ! debug
753 14 : call wrtout(std_out,message,'COLL') ! debug
754 14 : call print_matlu(weiss_for_rot%oper(1)%matlu(:),natom,1,compl=1) ! debug
755 : ! write(message,'(a,2x,a)') ch10," == Print weiss for last freq after rot" ! debug
756 : ! call wrtout(std_out,message,'COLL') ! debug
757 : ! call print_matlu(weiss_for_rot%oper(nwlo)%matlu(:),natom,1,compl=1) ! debug
758 : end if ! pawprtvol>=3
759 :
760 : ! ! Rotate DFT Green's function first in Ylm basis then in the rotated basis and compare to weiss_for_rot
761 : ! ! -----------------------------------------------------------------------------------------------------
762 : ! write(message,'(a,2x,a)') ch10, " == Rotation of greendft ="
763 : ! call wrtout(std_out,message,'COLL')
764 : ! do ifreq=1,paw_dmft%dmft_nwlo
765 : ! if(opt_rot==1) call rotate_matlu(greendft%oper(ifreq)%matlu,eigvectmatlu,natom,3,1)
766 : ! call diff_matlu("Weiss_for_rot","greendft",weiss_for_rot%oper(ifreq)%matlu,greendft%oper(ifreq)%matlu,natom,1,tol14)
767 : !! call checkdiag_matlu(weiss_for_rot%oper(ifreq)%matlu,natom,tol6)
768 : ! end do
769 : ! if(pawprtvol>=3) then
770 : ! write(message,'(a,2x,a,f13.5)') ch10,& ! debug
771 : !& " == Print greendft for small freq 1 after rot" ! debug
772 : ! call wrtout(std_out,message,'COLL') ! debug
773 : ! call print_matlu(greendft%oper(1)%matlu,natom,1,compl=1,opt_exp=2) ! debug
774 : ! write(message,'(a,2x,a,f13.5)') ch10,& ! debug
775 : !& " == Print greendft for last freq after rot" ! debug
776 : ! call wrtout(std_out,message,'COLL') ! debug
777 : ! call print_matlu(greendft%oper(paw_dmft%dmft_nwlo)%matlu,natom,1,compl=1,opt_exp=2) ! debug
778 : ! end if
779 : ! call flush_unit(std_out)
780 : end if
781 :
782 : ! =================================================================
783 : ! Compute analytic limit of hybridization and rotate it
784 : ! =================================================================
785 164 : ABI_MALLOC(hybri_coeff,(natom))
786 34 : call init_matlu(natom,nspinor,nsppol,paw_dmft%lpawu(:),hybri_coeff(:))
787 : !write(6,*)"hybri1",hybri_coeff(1)%mat(1,1,1,1,1),paw_dmft%natom,cryst_struc%natom
788 :
789 : ! Compute analytical C_ij such that F_ij -> C_ij/iw_n
790 : ! ---------------------------------------
791 34 : call hybridization_asymptotic_coefficient(cryst_struc,paw_dmft,hybri_coeff(:))
792 :
793 : ! Print analytical C_ij (not rotated)
794 : ! ---------------------------------------
795 34 : if (paw_dmft%dmft_solv /= 10) then
796 34 : write(message,'(a,2x,a)') ch10," == Coeff analytical C_ij such that F -> C_ij/iw_n for large frequency"
797 34 : call wrtout(std_out,message,'COLL')
798 34 : call print_matlu(hybri_coeff(:),natom,1)
799 : endif
800 :
801 : ! Rotate analytical C_ij in Ylm basis
802 : ! ---------------------------------------
803 34 : if (useylm == 1) then
804 0 : call slm2ylm_matlu(hybri_coeff(:),natom,paw_dmft,1,0)
805 : end if
806 : !rotate in jmj basis
807 34 : if (usejmj == 1) then
808 0 : call ylm2jmj_matlu(hybri_coeff(:),natom,1,paw_dmft)
809 : end if
810 :
811 34 : if (opt_diag /= 0) then
812 : ! Rotate analytical C_ij in rotated basis
813 : ! ---------------------------------------
814 : if (opt_rot == 1 .or. opt_rot == 2) then
815 14 : call rotate_matlu(hybri_coeff(:),eigvectmatlu(:),natom,1)
816 : end if
817 :
818 : ! Print analytical C_ij (rotated)
819 : ! ---------------------------------------
820 14 : if (paw_dmft%dmft_solv /= 10) then
821 14 : write(message,'(a,2x,a)') ch10," == Coeff analytical C_ij such that F -> C_ij/iw_n after rotation"
822 14 : call wrtout(std_out,message,'COLL')
823 14 : call print_matlu(hybri_coeff(:),natom,1,compl=1,opt_exp=0)
824 : endif
825 : end if
826 :
827 : ! =================================================================
828 : ! Check if rotation is properly done.
829 : ! =================================================================
830 : if(3 == 4) then
831 : write(message,'(a,2x,a)') ch10, " == Print dmat before rot"
832 : call wrtout(std_out,message,'COLL')
833 : call print_matlu(green%occup%matlu(:),natom,1)
834 : if (useylm == 1) then
835 : call slm2ylm_matlu(green%occup%matlu(:),natom,paw_dmft,1,0)
836 : end if
837 : if (opt_rot == 1) then
838 : call rotate_matlu(green%occup%matlu(:),eigvectmatlu(:),natom,1)
839 : end if
840 : write(message,'(a,2x,a)') ch10," == Print dmat after rot"
841 : call wrtout(std_out,message,'COLL')
842 : call print_matlu(green%occup%matlu(:),natom,1)
843 :
844 : write(message,'(2a)') ch10,' QMC STOP: DEBUG'
845 : call wrtout(std_out,message,'COLL')
846 : ABI_ERROR(message)
847 : end if
848 : ! =================================================================
849 : ! Check
850 : ! =================================================================
851 :
852 : ! write(message,'(a,2x,a,f13.5)') ch10,&
853 : !& " == Print weiss for small tau"
854 : ! call wrtout(std_out,message,'COLL')
855 : ! call print_matlu(weiss%oper(1)%matlu,natom,1)
856 : ! write(message,'(a,2x,a,f13.5)') ch10,&
857 : !& " == Print weiss for large tau"
858 : ! call wrtout(std_out,message,'COLL')
859 : ! call print_matlu(weiss%oper(paw_dmft%dmft_nwlo)%matlu,natom,1)
860 : ! call flush_unit(std_out)
861 : ! write(message,'(2a)') ch10,' Check weiss_for_rot(last freq)'
862 : ! call wrtout(std_out,message,'COLL')
863 : ! call checkdiag_matlu(weiss_for_rot%oper(paw_dmft%dmft_nwlo)%matlu,natom,tol6,opt=nspinor)
864 : ! call flush_unit(std_out)
865 : ! write(message,'(2a)') ch10,' Check weiss_for_rot(ifreq=1)'
866 : ! call wrtout(std_out,message,'COLL')
867 : ! call checkdiag_matlu(weiss_for_rot%oper(1)%matlu,natom,tol6,opt=nspinor)
868 : ! call flush_unit(std_out)
869 :
870 : !master = 0
871 :
872 : ! =================================================================
873 : ! Print out
874 : ! =================================================================
875 :
876 : ! Print Weiss
877 : ! -------------
878 34 : if (paw_dmft%dmft_prgn == 1) then
879 0 : call print_green('Weiss_diag',weiss_for_rot,1,paw_dmft,opt_wt=1,opt_decim=1)
880 : end if
881 :
882 34 : if (paw_dmft%dmft_solv /= 10) then
883 34 : write(message,'(a,2x,a)') ch10," == Preparing data for CTQMC"
884 34 : call wrtout(std_out,message,'COLL')
885 :
886 : ! Print Rotate Weiss for 1st and last frequencies (a second time ? why ?)
887 : ! ------------------------------------------------
888 34 : if (pawprtvol >= 3) then
889 28 : write(message,'(a,2x,a)') ch10," == Print rotated weiss function for small freq in the rotated basis" ! debug
890 28 : call wrtout(std_out,message,'COLL') ! debug
891 28 : call print_matlu(weiss_for_rot%oper(1)%matlu(:),natom,1,compl=1) ! debug
892 28 : write(message,'(a,2x,a)') ch10," == Print rotated weiss function for largest freq in the rotated basis" ! debug
893 28 : call wrtout(std_out,message,'COLL') ! debug
894 28 : call print_matlu(weiss_for_rot%oper(nwlo)%matlu(:),natom,1,compl=1) ! debug
895 : end if ! pawprtvol>=3
896 : endif
897 : ! =================================================================
898 : ! VARIABLES FOR CTQMC TESTS
899 34 : testcode = 0
900 34 : testrot = 0
901 : ! opt_fk = 0 ! for developpers to check Fourier transform and computes G0(tau)
902 34 : opt_fk = 1 ! usual case: for real calculations
903 : ! =================================================================
904 :
905 : ! _________________________________________________________________
906 : !
907 : ! SECOND PART : BUILT HYBRIDIZATION FROM G0
908 : ! _________________________________________________________________
909 : !
910 : ! =================================================================
911 : ! Compute inverse of weiss and compute hybridization
912 : ! =================================================================
913 :
914 : ! Compute inverse of weiss for each Frequency
915 : ! -----------------------------------------------------------------
916 :
917 17963 : do ifreq=1,nwlo
918 56139 : ABI_MALLOC(matlu1,(natom))
919 56139 : ABI_MALLOC(matlu2,(natom))
920 17929 : call init_matlu(natom,nspinor,nsppol,paw_dmft%lpawu(:),matlu1(:))
921 17929 : call init_matlu(natom,nspinor,nsppol,paw_dmft%lpawu(:),matlu2(:))
922 :
923 17929 : call copy_matlu(weiss_for_rot%oper(ifreq)%matlu(:),matlu1(:),natom)
924 :
925 : ! Print G_0(iw_n)
926 : ! ----------------
927 : if (optdb == 1) then
928 : call printplot_matlu(weiss_for_rot%oper(ifreq)%matlu(:),natom,paw_dmft%omega_lo(ifreq),"go",60000,imre=1)
929 : end if
930 :
931 : ! Compute G_0^-1
932 : ! -------------------------------------------
933 : ! if opt_fk=1 or testcode/=0 Do the inversion
934 : ! if opt_fk=0 Do not inverse.
935 : ! If testcode=2 and opt_fk=0 Do the inversion
936 : ! If testcode=1 and opt_fk=0 Do the inversion but no effect, because it will nevertheless be erased
937 : ! If opt_fk=1 Do the inversion
938 : ! -------------------------------------------
939 : if (optdb == 1) then
940 : call printplot_matlu(matlu1(:),natom,paw_dmft%omega_lo(ifreq),"weiss",12000,imre=1)
941 : end if
942 : if (opt_fk == 1 .or. testcode /= 0) then
943 17929 : call inverse_oper(weiss_for_rot%oper(ifreq),2)
944 : end if
945 :
946 : ! Print G_0^-1(iw_n)
947 : ! ----------------
948 : if (optdb == 1) then
949 : call printplot_matlu(weiss_for_rot%oper(ifreq)%matlu(:),natom,paw_dmft%omega_lo(ifreq),"goinv",70000,imre=1)
950 : end if
951 :
952 17929 : if (paw_dmft%dmft_solv /= 10) then
953 17929 : if (pawprtvol >= 4 .or. ifreq == nwlo) then
954 : if (opt_fk == 1 .or. testcode /= 0) then
955 : ! Check inversion : do the product
956 : ! ----------------------------------------------
957 34 : call prod_matlu(weiss_for_rot%oper(ifreq)%matlu(:),matlu1(:),matlu2(:),natom)
958 34 : write(message,'(a,2x,a,i7)') ch10," == Print product of weiss times invers for freq",ifreq
959 34 : call wrtout(std_out,message,'COLL') ! debug
960 34 : call print_matlu(matlu2(:),natom,1) ! debug
961 : end if
962 : end if
963 : endif
964 :
965 17929 : call destroy_matlu(matlu1(:),natom)
966 17929 : call destroy_matlu(matlu2(:),natom)
967 38210 : ABI_FREE(matlu1)
968 38244 : ABI_FREE(matlu2)
969 :
970 : end do ! ifreq
971 :
972 : ! Copy weiss_for_rot into weiss
973 : ! -------------------------------
974 : !call copy_matlu(weiss_for_rot%oper(ifreq)%matlu,weiss%oper(ifreq)%matlu,natom)
975 :
976 :
977 : ! Print G_0^-1 for 1st and last frequencies.
978 : ! -----------------------------------------
979 34 : if (paw_dmft%dmft_solv /= 10) then
980 34 : if (pawprtvol >= 3) then
981 28 : write(message,'(a,2x,a)') ch10," == Print G_0^-1 for small freq in the rotated basis" ! debug
982 28 : call wrtout(std_out,message,'COLL') ! debug
983 28 : call print_matlu(weiss_for_rot%oper(1)%matlu(:),natom,1) ! debug
984 28 : write(message,'(a,2x,a,e18.10,a)') ch10,& ! debug
985 56 : & " == Print G_0^-1 for last freq in the rotated basis (last freq=",paw_dmft%omega_lo(nwlo),")" ! debug
986 28 : call wrtout(std_out,message,'COLL') ! debug
987 28 : call print_matlu(weiss_for_rot%oper(paw_dmft%dmft_nwlo)%matlu(:),natom,1,compl=1) ! debug
988 : end if ! pawprtvol>=3
989 : endif
990 : ! Substract frequency from diagonal part
991 : ! ======================================
992 :
993 102 : ABI_MALLOC(shift,(natom))
994 17963 : do ifreq=1,nwlo
995 :
996 38210 : shift(:) = cmplx(zero,paw_dmft%omega_lo(ifreq),kind=dp)
997 :
998 : ! write(5555,'(400e17.4)') paw_dmft%omega_lo(ifreq),((((((weiss_for_rot%oper(ifreq)%matlu(1)%mat&
999 : ! & (im,im1,isppol,ispinor,ispinor1)-cmplx(0.d0,paw_dmft%omega_lo(ifreq),kind=dp)),im=1,2*3+1),&
1000 : !& im1=1,2*3+1),isppol=1,nsppol),ispinor=1,nspinor),ispinor1=1,nspinor)
1001 :
1002 : if (opt_fk == 1) then
1003 : ! Compute G_0^-1-iw_n
1004 : ! --------------------
1005 17929 : call shift_matlu(weiss_for_rot%oper(ifreq)%matlu(:),natom,shift(:))
1006 :
1007 : ! Compute -G_0^-1+iw_n
1008 : ! --------------------
1009 17929 : call fac_matlu(weiss_for_rot%oper(ifreq)%matlu(:),natom,-cone)
1010 : end if
1011 :
1012 : ! Print -G_0^-1+iw_n
1013 : ! --------------------
1014 34 : if (optdb == 1) then
1015 : call printplot_matlu(weiss_for_rot%oper(ifreq)%matlu(:),natom,paw_dmft%omega_lo(ifreq), &
1016 : & "G0inv_minus_omega",20000,imre=1)
1017 : end if
1018 : end do ! ifreq
1019 :
1020 : ! Print -G_0^+1-iw_n=(F-levels) for last freq in the rotated basis"
1021 : ! ------------------------------------------------------------------
1022 34 : ABI_FREE(shift)
1023 34 : if (pawprtvol >= 3) then
1024 28 : if (paw_dmft%dmft_solv .eq. 10) then
1025 0 : write(message,'(a,2x,a)') ch10,&
1026 0 : & " == Print G_0^-1-iw_n=-(F-levels) for first frequency in CTQMC basis"
1027 0 : call wrtout(std_out,message,'COLL')
1028 0 : call print_matlu(weiss_for_rot%oper(1)%matlu(:),natom,1)
1029 : end if !dmft_solv=10
1030 : else
1031 6 : write(message,'(a,2x,a)') ch10,& ! debug
1032 12 : & " == Print G_0^-1-iw_n=-(F-levels) for last freq in the rotated basis" ! debug
1033 6 : call wrtout(std_out,message,'COLL') ! debug
1034 6 : call print_matlu(weiss_for_rot%oper(nwlo)%matlu(:),natom,1,compl=1) ! debug
1035 : end if ! pawprtvol>=3
1036 :
1037 : ! Check numerical limit of F(i_wn)*iw_n (can be used also to compute F )
1038 : ! ======================================
1039 :
1040 34 : if (opt_nondiag == 1) then
1041 :
1042 0 : ABI_MALLOC(matlu1,(natom))
1043 0 : ABI_MALLOC(matlu2,(natom))
1044 0 : ABI_MALLOC(matlu3,(natom))
1045 0 : ABI_MALLOC(matlu4,(natom))
1046 0 : call init_matlu(natom,nspinor,nsppol,paw_dmft%lpawu(:),matlu1(:))
1047 0 : call init_matlu(natom,nspinor,nsppol,paw_dmft%lpawu(:),matlu2(:))
1048 0 : call init_matlu(natom,nspinor,nsppol,paw_dmft%lpawu(:),matlu3(:))
1049 0 : call init_matlu(natom,nspinor,nsppol,paw_dmft%lpawu(:),matlu4(:))
1050 :
1051 : !write(message,'(a,2x,a)') ch10," == energy_levels"
1052 : !call wrtout(std_out,message,'COLL')
1053 : !call print_matlu(energy_level%matlu(:),natom,1,opt_exp=2,compl=0)
1054 :
1055 0 : do ifreq=nwlo,1,-1 ! necessary to have matlu4 computed for the max frequency and available for all frequency.
1056 : ! do ifreq=paw_dmft%dmftqmc_l,1,-1 ! necessary to have matlu4 computed for the max frequency and available for all frequency.
1057 :
1058 : ! Compute F (substract levels) for max frequency
1059 : ! -----------------------------------------------
1060 0 : call add_matlu(weiss_for_rot%oper(ifreq)%matlu(:),energy_level%matlu(:),matlu1(:),natom,-1)
1061 :
1062 : ! Print F(iw_n)=-(G_0^-1-iw_n+levels) for last frequency.
1063 : ! --------------------------------------------------------
1064 0 : if ((ifreq == nwlo .or. ifreq == paw_dmft%dmftqmc_l) .and. paw_dmft%dmft_solv /= 10) then
1065 0 : write(message,'(a,2x,a,i4,a,f13.5,a)') ch10, &
1066 0 : & " == Print F(iw_n)=-(G_0^-1-iw_n+levels) for freq nb",ifreq," (=",paw_dmft%omega_lo(ifreq),")"
1067 0 : call wrtout(std_out,message,'COLL')
1068 0 : call print_matlu(matlu1(:),natom,1,opt_exp=1,compl=1)
1069 : end if
1070 : if (optdb == 1) then
1071 : call printplot_matlu(matlu1(:),natom,paw_dmft%omega_lo(ifreq),"Hybridization",10000,imre=1)
1072 : end if
1073 :
1074 : ! Put F in weiss_for_rot -> CTQMC
1075 : ! -------------------------------
1076 : if (opt_rot == 2) then
1077 : call rotate_matlu(weiss_for_rot%oper(ifreq)%matlu(:),eigvectmatlu(:),natom,1)
1078 : end if
1079 : ! The following line will produce directly the weiss function for the CTQMC code
1080 : if (opt_fk == 1) then
1081 0 : call copy_matlu(matlu1(:),weiss_for_rot%oper(ifreq)%matlu(:),natom)
1082 : end if
1083 :
1084 : ! Multiply F by frequency
1085 : ! ------------------------
1086 0 : call copy_matlu(matlu1(:),matlu2(:),natom)
1087 0 : call fac_matlu(matlu1(:),natom,cmplx(zero,paw_dmft%omega_lo(ifreq),kind=dp))
1088 0 : if ((ifreq == nwlo .or. ifreq == paw_dmft%dmftqmc_l) .and. paw_dmft%dmft_solv /= 10) then
1089 0 : write(message,'(a,2x,a,i4,a,f13.5,a)') ch10, &
1090 0 : & " == Print numerical C_ij = F(iw_n)*iw_n for freq nb",ifreq," (=",paw_dmft%omega_lo(ifreq),")"
1091 0 : call wrtout(std_out,message,'COLL')
1092 0 : call print_matlu(matlu1(:),natom,1,opt_exp=1,compl=1)
1093 : end if
1094 : if (optdb == 1) then
1095 : call printplot_matlu(matlu1(:),natom,paw_dmft%omega_lo(ifreq),"cij",72800,imre=1)
1096 : end if
1097 : ! call rotate_matlu(matlu1,eigvectmatlu,natom,3,1)
1098 :
1099 0 : if ((ifreq == nwlo .or. ifreq == paw_dmft%dmftqmc_l) .and. paw_dmft%dmft_solv /= 10) then
1100 0 : write(message,'(a,2x,a,i4,a,f13.5,a)') ch10, &
1101 0 : & " == Print numerical after back rotation C_ij = F(iw_n)*iw_n for freq nb",ifreq," (=",paw_dmft%omega_lo(ifreq),")"
1102 0 : call wrtout(std_out,message,'COLL')
1103 0 : call print_matlu(matlu1(:),natom,1,opt_exp=1,compl=1)
1104 : end if
1105 : if (optdb == 1) then
1106 : call printplot_matlu(matlu1(:),natom,paw_dmft%omega_lo(ifreq),"cij_rotated",72900,imre=1)
1107 : end if
1108 :
1109 : ! Built C_ij/iw_n
1110 : ! ------------------------
1111 0 : call copy_matlu(hybri_coeff(:),matlu1(:),natom)
1112 0 : call fac_matlu(matlu1(:),natom,cone/cmplx(zero,paw_dmft%omega_lo(ifreq),kind=dp))
1113 : if (optdb == 1) then
1114 : call printplot_matlu(matlu1(:),natom,paw_dmft%omega_lo(ifreq),"cij_over_omega",72000)
1115 : end if
1116 : ! if(ifreq==paw_dmft%dmft_nwlo) then
1117 : ! write(message,'(a,2x,a,f13.5)') ch10, " == Print numerical C_ij/iw_n for frequency",paw_dmft%omega_lo(ifreq)
1118 : ! call wrtout(std_out,message,'COLL')
1119 : ! call print_matlu(matlu1,natom,1,opt_exp=1,compl=1)
1120 : ! endif
1121 :
1122 : ! For test: put C_ij/i_wn into weiss_for_rot
1123 : ! --------------------------------------------
1124 : ! call copy_matlu(matlu1,weiss_for_rot%oper(ifreq)%matlu,natom,opt_non_diag=1)
1125 :
1126 : ! Compute Hybri - C_ij/iw_n
1127 : ! ------------------------
1128 0 : call add_matlu(matlu2(:),matlu1(:),matlu3(:),natom,-1)
1129 :
1130 : ! Print Hybri - C_ij/iw_n
1131 : ! ------------------------
1132 : if (optdb == 1) then
1133 : call printplot_matlu(matlu3(:),natom,paw_dmft%omega_lo(ifreq),"hybri_minus_asymp",74000,imre=1)
1134 : end if
1135 :
1136 : ! Multiply (F-C_ij/i_wn) by (iw_n)**2 to find D_ij such that (F-C_ij/i_wn) -> D_ij/(iw_n)^2 only for last frequency.
1137 : ! ------------------------------------------------------------------------------------------------------------------
1138 0 : call copy_matlu(matlu3(:),matlu2(:),natom)
1139 0 : call fac_matlu(matlu2(:),natom,cmplx(zero,paw_dmft%omega_lo(ifreq),kind=dp)**2)
1140 : if (optdb == 1) then
1141 : call printplot_matlu(matlu2(:),natom,paw_dmft%omega_lo(ifreq),"fminuscijtimesw2",75000,imre=1)
1142 : end if
1143 0 : if ((ifreq == nwlo .or. ifreq == paw_dmft%dmftqmc_l) .and. paw_dmft%dmft_solv /= 10) then
1144 0 : call copy_matlu(matlu2(:),matlu4(:),natom)
1145 0 : write(message,'(a,2x,a,i4,a,f13.5,a)') ch10, &
1146 0 : & " == Print numerical (F(iw_n)-C_ij/iw_n)%iw_n^2 for freq nb",ifreq," (=",paw_dmft%omega_lo(ifreq),")"
1147 0 : call wrtout(std_out,message,'COLL')
1148 0 : call print_matlu(matlu4(:),natom,1)
1149 : end if
1150 :
1151 : ! Built C_ij/iw_n+D_ij/(iw_n)^2
1152 : ! ------------------------
1153 0 : call copy_matlu(matlu4(:),matlu3(:),natom,opt_re=1)
1154 0 : call fac_matlu(matlu3(:),natom,cone/cmplx(zero,paw_dmft%omega_lo(ifreq),kind=dp)**2)
1155 0 : call add_matlu(matlu1(:),matlu3(:),matlu2(:),natom,1)
1156 0 : if (optdb == 1) then
1157 : call printplot_matlu(matlu2(:),natom,paw_dmft%omega_lo(ifreq),"cij_w_plus_dij_w2",72700,imre=1)
1158 : end if
1159 : ! For test: put C_ij/i_wn +D_ij/(iw_n)^2 into weiss_for_rot
1160 : ! --------------------------------------------
1161 : ! call copy_matlu(matlu2,weiss_for_rot%oper(ifreq)%matlu,natom,opt_non_diag=1)
1162 :
1163 :
1164 : end do ! ifreq
1165 :
1166 : ! Print F(iw_n) used by CTQMC for first frequency
1167 : ! -----------------------------
1168 0 : if(paw_dmft%dmft_solv .eq. 10) then
1169 0 : write(message,'(a,2x,a)') ch10," == Print F(iw_n)=-(G_0^-1-iw_n+levels) for first frequency in CTQMC basis"
1170 0 : call wrtout(std_out,message,'COLL')
1171 0 : call print_matlu(weiss_for_rot%oper(1)%matlu(:),natom,1)
1172 : endif
1173 :
1174 :
1175 0 : call destroy_matlu(matlu1(:),natom)
1176 0 : call destroy_matlu(matlu2(:),natom)
1177 0 : call destroy_matlu(matlu3(:),natom)
1178 0 : call destroy_matlu(matlu4(:),natom)
1179 0 : ABI_FREE(matlu1)
1180 0 : ABI_FREE(matlu2)
1181 0 : ABI_FREE(matlu3)
1182 0 : ABI_FREE(matlu4)
1183 : end if ! if opt_nondiag=1
1184 :
1185 : ! =======================
1186 : !
1187 : ! Rotation of Magnetic moment for CT-QMC
1188 : !
1189 : ! =======================
1190 34 : if(nspinor .eq. 2 .and. paw_dmft%dmftctqmc_localprop .gt. 1) then
1191 0 : write(message,'(a,2x,2a)') ch10, " == Making rotation for magnetic moments", ch10
1192 0 : call wrtout(std_out,message,'COLL')
1193 :
1194 0 : if(usejmj .eq. 1) then
1195 : ! == Mj values
1196 0 : call init_matlu(natom=1,nspinor=paw_dmft%nspinor,nsppol=paw_dmft%nsppol,lpawu_natom=paw_dmft%lpawu,matlu=matlumag_tot)
1197 0 : call zero_matlu(matlumag_tot,natom=1)
1198 0 : call magmomjmj_matlu(matlumag_tot,natom=1)
1199 : !call print_matlu(matlumag_tot,natom=1,prtopt=1)
1200 0 : call gather_matlu(matlumag_tot,magmom_tot,natom=1,option=1,prtopt=0)
1201 0 : call destroy_matlu(matlumag_tot,natom=1)
1202 :
1203 : else
1204 : !create a rotation matrix for diagonal Hamiltonian
1205 0 : if(opt_diag == 0) then
1206 0 : write(message,'(a,2x,2a)') ch10, " --> Hamiltonian is already diagonal in Slm", ch10
1207 0 : call wrtout(std_out,message,'COLL')
1208 0 : do iatom = 1,paw_dmft%natom
1209 0 : if(paw_dmft%lpawu(iatom) /= -1) then
1210 0 : do iflavor1=1,tndim
1211 0 : do iflavor2=1,tndim
1212 0 : if(iflavor1==iflavor2) then
1213 0 : eigvectmatlu(iatom)%mat(iflavor1,iflavor2,1)=cone
1214 : else
1215 0 : eigvectmatlu(iatom)%mat(iflavor1,iflavor2,1)=czero
1216 : end if
1217 : end do
1218 : end do
1219 : end if
1220 : end do
1221 : end if !end opt_diag=0
1222 :
1223 : ! == orbital angular momentum
1224 0 : call init_matlu(natom=natom,nspinor=paw_dmft%nspinor,nsppol=paw_dmft%nsppol,lpawu_natom=paw_dmft%lpawu,matlu=matlumag_orb)
1225 0 : call zero_matlu(matlumag_orb,natom=natom)
1226 0 : call chi_matlu(matlumag_orb,natom=natom,option=1,optprt=0)
1227 0 : call rotate_matlu(matlumag_orb,eigvectmatlu,natom=natom,inverse=1)
1228 : !call print_matlu(matlumag_orb,iatom,prtopt=1)
1229 0 : call gather_matlu(matlumag_orb,magmom_orb,natom=natom,option=1,prtopt=0)
1230 0 : call destroy_matlu(matlumag_orb,natom=natom)
1231 :
1232 : ! == spin angular momentum
1233 0 : call init_matlu(natom=natom,nspinor=paw_dmft%nspinor,nsppol=paw_dmft%nsppol,lpawu_natom=paw_dmft%lpawu,matlu=matlumag_spin)
1234 0 : call zero_matlu(matlumag_spin,natom=natom)
1235 0 : call chi_matlu(matlumag_spin,natom=natom,option=2,optprt=0)
1236 0 : call rotate_matlu(matlumag_spin,eigvectmatlu,natom=natom,inverse=1)
1237 : !call print_matlu(matlumag_spin,natom,prtopt=1)
1238 0 : call gather_matlu(matlumag_spin,magmom_spin,natom=natom,option=1,prtopt=0)
1239 0 : call destroy_matlu(matlumag_spin,natom=natom)
1240 :
1241 : ! == total angular momentum
1242 0 : call init_matlu(natom=natom,nspinor=paw_dmft%nspinor,nsppol=paw_dmft%nsppol,lpawu_natom=paw_dmft%lpawu,matlu=matlumag_tot)
1243 0 : call zero_matlu(matlumag_tot,natom=natom)
1244 0 : call chi_matlu(matlumag_tot,natom=natom,option=3,optprt=0)
1245 0 : call rotate_matlu(matlumag_tot,eigvectmatlu,natom=natom,inverse=1)
1246 : !call print_matlu(matlumag_tot,natom=1,prtopt=1)
1247 0 : call gather_matlu(matlumag_tot,magmom_tot,natom=natom,option=1,prtopt=0)
1248 0 : call destroy_matlu(matlumag_tot,natom=natom)
1249 : endif !usejmj
1250 0 : write(message,'(a,2x,2a)') ch10, " ==> Rotation done", ch10
1251 0 : call wrtout(std_out,message,'COLL')
1252 :
1253 : end if ! dmftctqmc_localprop
1254 : !======================
1255 :
1256 34 : call timab(702,2,tsec(:))
1257 : ! =========================================================================================
1258 : ! Start big loop over atoms to compute hybridization and do the CTQMC
1259 : ! =========================================================================================
1260 :
1261 34 : call timab(703,1,tsec(:))
1262 96 : do iatom=1,natom
1263 :
1264 62 : lpawu = paw_dmft%lpawu(iatom)
1265 62 : if (lpawu == -1) cycle
1266 :
1267 34 : green%ecorr_qmc(iatom) = zero
1268 34 : itypat = paw_dmft%typat(iatom)
1269 34 : tndim = 2*lpawu + 1
1270 : ! if(lpawu/=-1) then
1271 :
1272 34 : nflavor = 2 * tndim
1273 :
1274 34 : if (testcode >= 1) then
1275 0 : nflavor = 2
1276 : if (testcode == 2) then
1277 : ispa = 1
1278 : ispb = 2
1279 : if (nspinor == 1) ispb = 1
1280 : ima = 1
1281 : imb = 1
1282 : if (tndim > 4) then
1283 : ima = 5 ! row
1284 : imb = 4 ! column
1285 : end if
1286 : end if ! testcode=2
1287 : end if ! testcode >=1
1288 :
1289 136 : ABI_MALLOC(fw1,(nwlo,nflavor))
1290 170 : ABI_MALLOC(fw1_nd,(nwlo,nflavor,nflavor))
1291 102 : ABI_MALLOC(levels_ctqmc,(nflavor))
1292 136 : ABI_MALLOC(levels_ctqmc_nd,(nflavor,nflavor))
1293 4698 : levels_ctqmc_nd(:,:) = czero
1294 102 : ABI_MALLOC(levels_ctqmc_complex,(nflavor))
1295 402 : levels_ctqmc_complex(:) = czero
1296 102 : ABI_MALLOC(hybri_limit,(nflavor,nflavor))
1297 4698 : hybri_limit(:,:) = czero
1298 1880926 : fw1_nd(:,:,:) = czero
1299 182380 : fw1(:,:) = czero
1300 :
1301 : ! =================================================================
1302 : ! Put hybridization in new arrays for CTQMC
1303 : ! =================================================================
1304 34 : if (testcode == 0) then
1305 34 : iflavor1 = 0
1306 34 : iflavor2 = 0
1307 :
1308 88 : do isppol=1,nsppol
1309 142 : do ispinor1=1,nspinor
1310 162 : do ispinor2=1,nspinor
1311 378 : do im1=1,tndim
1312 1786 : do im2=1,tndim
1313 :
1314 : ! first diagonal terms whatever opt_nondiag
1315 1462 : iflavor1 = im1 + tndim*(ispinor1-1) + tndim*(isppol-1)
1316 1462 : iflavor2 = im2 + tndim*(ispinor2-1) + tndim*(isppol-1)
1317 :
1318 1732 : if (iflavor1 == iflavor2 ) then
1319 :
1320 : ! Put weiss_for_rot in fw1
1321 173428 : do ifreq=1,nwlo
1322 173158 : if (opt_fk == 1 .or. opt_fk == 0) fw1(ifreq,iflavor1) = &
1323 173428 : & weiss_for_rot%oper(ifreq)%matlu(iatom)%mat(im1+(ispinor1-1)*tndim,im1+(ispinor1-1)*tndim,isppol)
1324 : end do ! ifreq
1325 173428 : fw1_nd(:,iflavor1,iflavor1) = fw1(:,iflavor1)
1326 :
1327 270 : if(paw_dmft%dmft_solv .eq. 10) then
1328 : !off diag levels are always null beceause of diagonalisation
1329 : levels_ctqmc_complex(iflavor1) = &
1330 0 : & energy_level%matlu(iatom)%mat(im1+(ispinor1-1)*tndim,im1+(ispinor1-1)*tndim,isppol)
1331 0 : hybri_limit(iflavor1,iflavor1) = hybri_coeff(iatom)%mat(im1+(ispinor1-1)*tndim,im1+(ispinor1-1)*tndim,isppol)
1332 : else
1333 : levels_ctqmc(iflavor1) = &
1334 270 : & dble(energy_level%matlu(iatom)%mat(im1+(ispinor1-1)*tndim,im1+(ispinor1-1)*tndim,isppol))
1335 270 : hybri_limit(iflavor1,iflavor1) = hybri_coeff(iatom)%mat(im1+(ispinor1-1)*tndim,im1+(ispinor1-1)*tndim,isppol)
1336 : endif
1337 :
1338 : ! case nsppol=nspinor=1
1339 270 : if (nsppol == 1 .and. nspinor == 1) then
1340 8918 : fw1(:,iflavor1+tndim) = fw1(:,iflavor1)
1341 8918 : fw1_nd(:,iflavor1+tndim,iflavor1+tndim) = fw1(:,iflavor1)
1342 98 : if(paw_dmft%dmft_solv .eq. 10) then
1343 0 : levels_ctqmc_complex(iflavor1+tndim) = levels_ctqmc_complex(iflavor1)
1344 : else
1345 98 : levels_ctqmc(iflavor1+tndim) = levels_ctqmc(iflavor1)
1346 98 : hybri_limit(iflavor1+tndim,iflavor1+tndim) = hybri_limit(iflavor1,iflavor1)
1347 : endif
1348 : end if
1349 :
1350 : ! off diagonal terms
1351 : else
1352 :
1353 : ! Put weiss_for_rot in fw1_nd
1354 704408 : do ifreq=1,nwlo
1355 703216 : if (opt_fk == 1 .or. opt_fk == 0) fw1_nd(ifreq,iflavor1,iflavor2) = &
1356 704408 : & weiss_for_rot%oper(ifreq)%matlu(iatom)%mat(im1+(ispinor1-1)*tndim,im2+(ispinor2-1)*tndim,isppol)
1357 : end do ! ifreq
1358 1192 : hybri_limit(iflavor1,iflavor2) = hybri_coeff(iatom)%mat(im1+(ispinor1-1)*tndim,im2+(ispinor2-1)*tndim,isppol)
1359 :
1360 : ! case nsppol=nspinor=1
1361 1192 : if (nsppol == 1 .and. nspinor == 1) then
1362 53508 : fw1_nd(:,iflavor1+tndim,iflavor2+tndim) = fw1_nd(:,iflavor1,iflavor2)
1363 588 : hybri_limit(iflavor1+tndim,iflavor2+tndim) = hybri_limit(iflavor1,iflavor2)
1364 : end if
1365 :
1366 : end if ! iflavor1=iflavor2
1367 :
1368 : ! < / HACK >
1369 : end do ! im2
1370 : end do ! im1
1371 : end do ! ispinor2
1372 : end do ! ispinor1
1373 : end do ! isppol
1374 : ! < HACK >
1375 : ! JB. On 1000 cpus this can not work since all CPU try to open/write the files
1376 : ! Action : Don't print it or check only one cpu does it.
1377 :
1378 34 : if (pawprtvol >= 10000000) then
1379 0 : write(message,'(a,2x,a)') ch10, " == Hybri for all flavors for CTQMC "
1380 0 : call wrtout(std_out,message,'COLL')
1381 0 : do iflavor1=1,nflavor
1382 0 : write(message,'(4x,14(2e14.5,2x))') (hybri_limit(iflavor1,iflavor2),iflavor2=1,nflavor)
1383 0 : call wrtout(std_out,message,'COLL')
1384 : end do ! iflavor1
1385 :
1386 0 : if (open_file('Hybri_cijoveromega',message,newunit=unt,status='unknown',form='formatted') /= 0) &
1387 0 : & ABI_ERROR(message)
1388 0 : if (open_file('Hybri',message,newunit=unt2,status='unknown',form='formatted') /= 0) ABI_ERROR(message)
1389 0 : do ifreq=1,nwlo
1390 : ! weiss_for_rot is G_0^-1-iw_n=-(F-levels)
1391 0 : if (optdb == 1) then
1392 : call printplot_matlu(weiss_for_rot%oper(ifreq)%matlu(:),natom,paw_dmft%omega_lo(ifreq),"weissbefore112",30000)
1393 : end if
1394 : end do
1395 0 : do iflavor1=1,nflavor
1396 0 : do iflavor2=1,nflavor
1397 0 : do ifreq=1,nwlo
1398 0 : omega = pi * paw_dmft%temp * (two*float(ifreq)-1)
1399 : ! fw1_nd is -G_0^+1-iw_n=(F-levels)
1400 0 : write(unt,'(300e16.5)') paw_dmft%omega_lo(ifreq), &
1401 0 : & fw1_nd(ifreq,iflavor1,iflavor2)-hybri_limit(iflavor1,iflavor2)/cmplx(zero,paw_dmft%omega_lo(ifreq),kind=dp)
1402 0 : write(unt2,'(300e16.5)') paw_dmft%omega_lo(ifreq),fw1_nd(ifreq,iflavor1,iflavor2)
1403 : end do ! ifreq
1404 0 : write(unt,*)
1405 0 : write(unt2,*)
1406 : end do ! iflavor2
1407 : end do ! iflavor1
1408 0 : close(unt)
1409 0 : close(unt2)
1410 : end if ! pawprtvol>=10000000
1411 : end if ! testcode
1412 : ! </ HACK >
1413 :
1414 :
1415 :
1416 :
1417 : ! ====================================================================================
1418 : ! TEST
1419 : ! For testing purpose, built ultra simple hybridization (constant in
1420 : ! imaginary time or very simple) or extract some part of the calculated hybridization
1421 : ! ====================================================================================
1422 34 : if (testcode >= 1) then
1423 : !dmft_nwlo = paw_dmft%dmft_nwlo
1424 0 : paw_dmft%dmft_nwlo = paw_dmft%dmftqmc_l
1425 0 : ABI_MALLOC(gw1_nd,(paw_dmft%dmft_nwlo,nflavor,nflavor))
1426 0 : gw1_nd(:,:,:) = czero
1427 :
1428 : ! Call testcode_ctqmc: built simple hybridization
1429 : !--------------------------------------------------
1430 0 : if (testcode == 1) then
1431 : call testcode_ctqmc(paw_dmft%dmftqmc_l,fw1_nd(:,:,:),fw1(:,:),gtmp_nd(:,:,:),gw_tmp_nd(:,:,:),&
1432 0 : & levels_ctqmc(:),hybri_limit(:,:),nflavor,1,paw_dmft%temp,testrot,testcode,umod(:,:))
1433 : ! Select 2x2 hybridization matrix from the current larger matrix
1434 : ! ima and imb are defined above.
1435 : !----------------------------------------------------------------
1436 0 : else if (testcode == 2) then
1437 : !close(unt)
1438 : !close(unt2)
1439 : call testcode_ctqmc_b(energy_level,hybri_coeff,weiss_for_rot,paw_dmft%dmftqmc_l,fw1_nd(:,:,:),&
1440 0 : & levels_ctqmc(:),levels_ctqmc_nd(:,:),hybri_limit(:,:),paw_dmft%temp,umod(:,:),opt_diag,opt_fk)
1441 : end if
1442 :
1443 : ! Calculation of Inverse Green's function from hybridization
1444 : !-------------------------------------------------------------
1445 0 : do if1=1,2
1446 0 : do if2=1,2
1447 0 : do ifreq=1,paw_dmft%dmftqmc_l
1448 0 : omega = pi * paw_dmft%temp * (two*dble(ifreq)-1)
1449 0 : if (if1 == if2) then
1450 0 : gw1_nd(ifreq,if1,if2) = (cmplx(zero,omega,kind=dp)-fw1_nd(ifreq,if1,if2))
1451 : else
1452 0 : gw1_nd(ifreq,if1,if2) = -fw1_nd(ifreq,if1,if2)
1453 : end if
1454 : end do ! ifreq
1455 : end do ! if2
1456 : end do ! if1
1457 : ! Calculation of Green's function (call inverse)
1458 : !-------------------------------------------------------------
1459 0 : do ifreq=1,paw_dmft%dmftqmc_l
1460 0 : call xginv(gw1_nd(ifreq,:,:),2)
1461 : end do
1462 0 : write(std_out,*) " testctqmc high frequency limit of hybridization",fw1_nd(paw_dmft%dmftqmc_l,:,:)
1463 :
1464 : ! Integrate Green's function
1465 : !-------------------------------------------------------------
1466 0 : do if1=1,2
1467 0 : do if2=1,2
1468 0 : call int_fct(gw1_nd(:,if1,if2),(if1==if2),2,paw_dmft,integral(if1,if2)) ! test_1
1469 : end do
1470 : end do
1471 : ! Write Occupations
1472 0 : write(std_out,*) "Occupation of model in matrix form"
1473 0 : do if1=1,2
1474 0 : write(std_out,'(2(2f13.5,3x))') ((integral(if1,if2)+conjg(integral(if2,if1)))/two,if2=1,2)
1475 : end do
1476 0 : write(std_out,*) "Limit of hybridization "
1477 0 : do if1=1,2
1478 0 : write(std_out,'(2(2f13.5,3x))') (hybri_limit(if1,if2),if2=1,2)
1479 : end do
1480 :
1481 : ! If opt_fk=0, give Green's function to CTQMC code instead of
1482 : ! hybridization
1483 : !-------------------------------------------------------------
1484 0 : if (opt_fk == 0) fw1_nd(:,:,:) = gw1_nd(:,:,:)
1485 :
1486 0 : ABI_FREE(gw1_nd)
1487 0 : paw_dmft%dmft_nwlo = nwlo
1488 :
1489 : ! and testcode>1
1490 : end if ! testcode>=1
1491 :
1492 :
1493 34 : call flush_unit(std_out)
1494 : ! =================================================================
1495 :
1496 : ! ___________________________________________________________________________________
1497 : !
1498 : ! THIRD PART : CALL CTQMC
1499 : ! ___________________________________________________________________________________
1500 :
1501 : ! ==================================================================
1502 : ! Main calls to CTQMC code in ABINIT (INITIALIZATION and OPTIONS)
1503 : ! ==================================================================
1504 34 : if (paw_dmft%dmft_solv == 5 .or. paw_dmft%dmft_solv == 8 .or. paw_dmft%dmft_solv == 10) then
1505 34 : write(message,'(a,2x,a)') ch10," == Initializing CTQMC"
1506 34 : call wrtout(std_out,message,'COLL')
1507 :
1508 : ! Initialisation
1509 : ! =================================================================
1510 34 : if (paw_dmft%dmft_solv == 5) then
1511 34 : nomega = paw_dmft%dmftqmc_l
1512 : call CtqmcInterface_init(hybrid,paw_dmft%dmftqmc_seed,paw_dmft%dmftqmc_n, &
1513 : & paw_dmft%dmftqmc_therm,paw_dmft%dmftctqmc_meas,nflavor,paw_dmft%dmftqmc_l,&
1514 34 : & one/paw_dmft%temp,zero,std_out,paw_dmft%dmftctqmc_chains,paw_dmft%spacecomm,paw_dmft%nspinor)
1515 : ! options
1516 : ! =================================================================
1517 : call CtqmcInterface_setOpts(hybrid, &
1518 : & opt_Fk = opt_fk, &
1519 : & opt_order = paw_dmft%dmftctqmc_order, &
1520 : & opt_histo = paw_dmft%dmftctqmc_localprop, &
1521 : & opt_movie = paw_dmft%dmftctqmc_mov, &
1522 : & opt_analysis = paw_dmft%dmftctqmc_correl, &
1523 : & opt_check = paw_dmft%dmftctqmc_check, &
1524 : & opt_noise = paw_dmft%dmftctqmc_grnns, &
1525 : & opt_spectra = paw_dmft%dmftctqmc_mrka, &
1526 34 : & opt_gmove = paw_dmft%dmftctqmc_gmove)
1527 : end if
1528 :
1529 34 : if (paw_dmft%dmft_solv == 8) then
1530 0 : nomega = paw_dmft%dmftqmc_l
1531 : call CtqmcoffdiagInterface_init(hybridoffdiag,paw_dmft%dmftqmc_seed,&
1532 : & paw_dmft%dmftqmc_n,paw_dmft%dmftqmc_therm,paw_dmft%dmftctqmc_meas,&
1533 : & nflavor,paw_dmft%dmftqmc_l,one/paw_dmft%temp,zero,std_out,&
1534 0 : & paw_dmft%spacecomm,opt_nondiag,paw_dmft%nspinor)
1535 : ! options
1536 : ! =================================================================
1537 : call CtqmcoffdiagInterface_setOpts(hybridoffdiag,opt_Fk=opt_fk, &
1538 : & opt_order = paw_dmft%dmftctqmc_order, &
1539 : & opt_histo = paw_dmft%dmftctqmc_localprop, &
1540 : & opt_movie = paw_dmft%dmftctqmc_mov, &
1541 : & opt_analysis = paw_dmft%dmftctqmc_correl, &
1542 : & opt_check = paw_dmft%dmftctqmc_check, &
1543 : & opt_noise = paw_dmft%dmftctqmc_grnns, &
1544 : & opt_spectra = paw_dmft%dmftctqmc_mrka, &
1545 0 : & opt_gmove = paw_dmft%dmftctqmc_gmove)
1546 : end if
1547 :
1548 34 : if (paw_dmft%dmft_solv == 10) then
1549 0 : nomega = paw_dmft%dmftqmc_l
1550 : call CtqmcoffdiagInterfaceComplex_init(hybridoffdiagComplex,paw_dmft%dmftqmc_seed,&
1551 : & paw_dmft%dmftqmc_n,paw_dmft%dmftqmc_therm,paw_dmft%dmftctqmc_meas,&
1552 : & nflavor,paw_dmft%dmftqmc_l,one/paw_dmft%temp,zero,std_out,&
1553 0 : & paw_dmft%spacecomm,opt_nondiag,paw_dmft%nspinor)
1554 : ! options
1555 : ! =================================================================
1556 : call CtqmcoffdiagInterfaceComplex_setOpts(hybridoffdiagComplex,opt_Fk=opt_fk, &
1557 : & opt_order = paw_dmft%dmftctqmc_order, &
1558 : & opt_histo = paw_dmft%dmftctqmc_localprop, &
1559 : & opt_movie = paw_dmft%dmftctqmc_mov, &
1560 : & opt_analysis = paw_dmft%dmftctqmc_correl, &
1561 : & opt_check = paw_dmft%dmftctqmc_check, &
1562 : & opt_noise = paw_dmft%dmftctqmc_grnns, &
1563 : & opt_spectra = paw_dmft%dmftctqmc_mrka, &
1564 0 : & opt_gmove = paw_dmft%dmftctqmc_gmove)
1565 : end if
1566 :
1567 34 : write(message,'(a,2x,2a)') ch10, " == Initialization CTQMC done", ch10
1568 34 : call wrtout(std_out,message,'COLL')
1569 :
1570 : end if ! dmft_solv=5 or dmft_solv=8
1571 :
1572 34 : if (paw_dmft%dmft_solv == 9) then
1573 0 : ABI_MALLOC(gw_tmp_nd,(paw_dmft%dmft_nwli,nflavor,nflavor))
1574 : ! because size allocation problem with TRIQS paw_dmft%dmft_nwlo must be >= paw_dmft%dmft_nwli
1575 0 : open(unit=505,file=trim(paw_dmft%filapp)//"_Legendre_coefficients.dat",status='unknown',form='formatted')
1576 : else
1577 34 : if (paw_dmft%dmft_solv == 5) then
1578 136 : ABI_MALLOC(gw_tmp,(paw_dmft%dmft_nwlo,nflavor+1))
1579 : end if
1580 170 : ABI_MALLOC(gw_tmp_nd,(paw_dmft%dmft_nwlo,nflavor,nflavor+1))
1581 : !use gw_tmp to put freq
1582 17963 : do ifreq=1,paw_dmft%dmft_nwlo
1583 17929 : if (paw_dmft%dmft_solv == 5) gw_tmp(ifreq,nflavor+1) = cmplx(zero,paw_dmft%omega_lo(ifreq),kind=dp)
1584 17963 : gw_tmp_nd(ifreq,nflavor,nflavor+1) = cmplx(zero,paw_dmft%omega_lo(ifreq),kind=dp)
1585 : end do
1586 : end if ! dmft_solv=9
1587 :
1588 136 : ABI_MALLOC(gtmp,(paw_dmft%dmftqmc_l,nflavor))
1589 : ! THIS IS A BACKUP PLAN. USING paw_dmft%hybrid makes a segfault on TIKAL
1590 : ! PSC with MPI only (and max2_open64). paw_dmf%hybrid is corrupted
1591 : ! somewhere but I could not find the place in all DMFT routines
1592 170 : ABI_MALLOC(gtmp_nd,(paw_dmft%dmftqmc_l,nflavor,nflavor))
1593 34 : if(paw_dmft%dmft_solv .eq. 10) then
1594 0 : ABI_MALLOC(gtmp_ndc,(paw_dmft%dmftqmc_l,nflavor,nflavor))
1595 : endif
1596 34 : call flush_unit(std_out)
1597 :
1598 34 : call timab(704,1,tsec(:))
1599 : ! =================================================================
1600 : ! BEGIN CALL TO CTQMC SOLVERS
1601 : ! =================================================================
1602 :
1603 34 : if (testcode == 0) then
1604 :
1605 : ! =================================================================
1606 : ! CTQMC run Abinit
1607 : ! =================================================================
1608 34 : if (paw_dmft%dmft_solv == 5) then
1609 :
1610 136 : ABI_MALLOC(docc,(nflavor,nflavor))
1611 4698 : docc(:,:) = zero
1612 : call CtqmcInterface_run(hybrid,fw1(1:paw_dmft%dmftqmc_l,:),Gtau=gtmp(:,:),Gw=gw_tmp(:,:),D=docc(:,:),E=green%ecorr_qmc(iatom),&
1613 : ! & matU=hu(itypat)%udens,opt_levels=levels_ctqmc)
1614 : & matU=dble(udens_atoms(iatom)%mat(:,:,1)),opt_levels=levels_ctqmc(:),Magmom_orb=REAL(magmom_orb(iatom)%value),&
1615 18690 : & Magmom_spin=REAL(magmom_spin(iatom)%value),Magmom_tot=REAL(magmom_tot(iatom)%value),Iatom=iatom,fname=paw_dmft%filapp)
1616 34 : if (paw_dmft%dmft_entropy > 0) then
1617 9 : call data4entropyDMFT_setDocc(paw_dmft%forentropyDMFT,iatom,docc(:,:))
1618 : end if
1619 34 : ABI_FREE(docc)
1620 : !DO iflavor = 1, nflavor
1621 : ! hybrid%Hybrid%Greens(iflavor)%oper(1:this%samples) = gtmp(1:this%samples,iflavor)
1622 : ! CALL GreenHyb_forFourier(this%Greens(iflavor), Gomega=Gw(:,iflavor), omega=Gw(:,this%flavors+1))
1623 : !END DO
1624 :
1625 : ! =================================================================
1626 : ! CTQMC run Abinit off diagonal terms in hybridization
1627 : ! =================================================================
1628 0 : else if (paw_dmft%dmft_solv == 8) then
1629 : ! =================================================================
1630 :
1631 0 : ABI_MALLOC(docc,(nflavor,nflavor))
1632 0 : docc(:,:) = zero
1633 :
1634 : call CtqmcoffdiagInterface_run(hybridoffdiag,fw1_nd(1:paw_dmft%dmftqmc_l,:,:),Gtau=gtmp_nd(:,:,:),&
1635 : & Gw=gw_tmp_nd(:,:,:),D=doccsum,E=green%ecorr_qmc(iatom),Noise=noise,matU=dble(udens_atoms(iatom)%mat(:,:,1)),&
1636 : & Docc=docc(:,:),opt_levels=levels_ctqmc(:),hybri_limit=hybri_limit(:,:),Magmom_orb=REAL(magmom_orb(iatom)%value),&
1637 : & Magmom_spin=REAL(magmom_spin(iatom)%value),Magmom_tot=REAL(magmom_tot(iatom)%value),Iatom=iatom,&
1638 0 : & fname=paw_dmft%filapp,jmjbasis=usejmj)
1639 :
1640 : ! For entropy (alternative formulation)
1641 0 : if (paw_dmft%ientropy == 1) then
1642 0 : EE = zero
1643 0 : do if1=1,nflavor
1644 0 : do if2=if1+1,nflavor
1645 0 : EE = EE + docc(if1,if2)*dble(udens_atoms_for_s(iatom)%mat(if1,if2,1))
1646 : ! write(std_out,*) udens_atoms_for_s(iatom)%value(if1,if2),docc(if1,if2)
1647 : end do
1648 : end do
1649 : ! Here in udens U=1, J=J/U, so we need to multiply bu U/Ha_eV
1650 0 : write(message,'(a,3(f14.10,3x))') "For entropy calculation E_corr_qmc, u_for_s, j_for,s", &
1651 0 : & paw_dmft%u_for_s*EE/Ha_eV,paw_dmft%u_for_s,paw_dmft%j_for_s
1652 0 : call wrtout(std_out,message,'COLL')
1653 0 : EE = zero
1654 0 : do if1=1,nflavor
1655 0 : do if2=if1+1,nflavor
1656 0 : EE = EE + dble(docc(if1,if2)*udens_atoms(iatom)%mat(if1,if2,1))
1657 : ! write(std_out,*) udens_atoms(iatom)%value(if1,if2),docc(if1,if2)
1658 : end do
1659 : end do
1660 : ! Here in udens U=U, J=J, so we obtain directly the results
1661 0 : write(message,'(a,3(f14.10,3x))') "Reference calculation E_corr_qmc, upawu , jpawu ", &
1662 0 : & EE,hu(itypat)%upawu*Ha_eV,hu(itypat)%jpawu*Ha_eV
1663 0 : call wrtout(std_out,message,'COLL')
1664 : end if
1665 0 : ABI_FREE(docc)
1666 : ! TODO: Handle de luj0 case for entropy
1667 :
1668 : ! =================================================================
1669 : ! CTQMC run Abinit Complex off diagonal terms in hybridization
1670 : ! =================================================================
1671 0 : else if (paw_dmft%dmft_solv == 10) then
1672 : ! =================================================================
1673 :
1674 0 : ABI_MALLOC(docc,(nflavor,nflavor))
1675 0 : docc(:,:) = zero
1676 :
1677 : call CtqmcoffdiagInterfaceComplex_run(hybridoffdiagComplex,fw1_nd(1:paw_dmft%dmftqmc_l,:,:),Gtau=gtmp_ndc(:,:,:),&
1678 : & Gw=gw_tmp_nd(:,:,:),D=doccsum,E=green%ecorr_qmc(iatom),Noise=noise,matU=udens_atoms(iatom)%mat(:,:,1),&
1679 : & Docc=docc(:,:),opt_levels=levels_ctqmc_complex(:),hybri_limit=hybri_limit(:,:),Magmom_orb=REAL(magmom_orb(iatom)%value),&
1680 : & Magmom_spin=REAL(magmom_spin(iatom)%value),Magmom_tot=REAL(magmom_tot(iatom)%value),&
1681 0 : & Iatom=iatom,fname=paw_dmft%filapp,opthybri=opt_hybri)
1682 :
1683 0 : ABI_FREE(docc)
1684 : ! =================================================================
1685 : ! CTQMC run TRIQS
1686 : ! =================================================================
1687 0 : else if (paw_dmft%dmft_solv == 9) then
1688 : ! =================================================================
1689 :
1690 0 : call ctqmc_calltriqs(paw_dmft,cryst_struc,hu(:),levels_ctqmc,gtmp_nd,gw_tmp_nd,fw1_nd,leg_measure,iatom)
1691 :
1692 : end if
1693 :
1694 : ! =================================================================
1695 : ! CTQMC run for tests
1696 : ! =================================================================
1697 0 : else if (testcode >= 1) then
1698 : call CtqmcInterface_run(hybrid,fw1(1:nomega,:),Gtau=gtmp(:,:),Gw=gw_tmp(:,:),E=green%ecorr_qmc(iatom),&
1699 0 : & matU=umod(:,:),opt_levels=levels_ctqmc(:),Iatom=iatom,fname=paw_dmft%filapp)
1700 :
1701 : ! for non diagonal code
1702 : ! call CtqmcInterface_run(hybrid,fw1_nd(1:nomega,:,:),Gtau=gtmp_nd,&
1703 : !& Gw=gw_tmp_nd,D=Doccsum,E=green%ecorr_qmc(iatom),&
1704 : !& Noise=Noise,matU=umod,opt_levels=levels_ctqmc,hybri_limit=hybri_limit)
1705 :
1706 : ! If test of the code is activated, and testrot =1 rotate back green's function and stop the code.
1707 : ! --------------------------------------------------------------------------------------------------
1708 0 : if (testcode == 1) then
1709 :
1710 : call testcode_ctqmc(paw_dmft%dmftqmc_l,fw1_nd(:,:,:),fw1(:,:),gtmp_nd(:,:,:),gw_tmp_nd(:,:,:), &
1711 0 : & levels_ctqmc(:),hybri_limit(:,:),nflavor,2,paw_dmft%temp,testrot,testcode,umod(:,:))
1712 :
1713 0 : write(message,'(2a)') ch10,' testcode end of test calculation'
1714 0 : ABI_ERROR(message)
1715 : end if
1716 :
1717 0 : if (testcode == 2) then
1718 0 : write(message,'(2a)') ch10,' testcode 2 end of test calculation'
1719 0 : ABI_ERROR(message)
1720 : end if
1721 :
1722 : end if
1723 34 : call timab(704,2,tsec(:))
1724 : ! =================================================================
1725 : ! END CALL TO CTQMC SOLVERS
1726 : ! =================================================================
1727 :
1728 :
1729 : ! Print green function is files directly from CTQMC
1730 : ! --------------------------------------------------
1731 34 : call ctqmcoutput_printgreen(paw_dmft,gtmp_nd,gtmp_ndc,gw_tmp_nd,gtmp,gw_tmp,iatom)
1732 :
1733 :
1734 : ! If the CTQMC code in ABINIT was used, then destroy it and deallocate arrays
1735 : ! ----------------------------------------------------------------------------
1736 : ! if(paw_dmft%dmft_solv<6.and.paw_dmft%dmft_solv>7) then
1737 : ! Nothing just hybrid var problem
1738 : ! else
1739 34 : write(message,'(a,2x,a)') ch10," == Destroy CTQMC"
1740 34 : call wrtout(std_out,message,'COLL')
1741 34 : if (paw_dmft%dmft_solv == 5) then
1742 34 : call CtqmcInterface_finalize(hybrid)
1743 : end if
1744 34 : if (paw_dmft%dmft_solv == 8) then
1745 0 : call CtqmcoffdiagInterface_finalize(hybridoffdiag)
1746 : end if
1747 34 : if (paw_dmft%dmft_solv == 10) then
1748 0 : call CtqmcoffdiagInterfaceComplex_finalize(hybridoffdiagComplex)
1749 : end if
1750 34 : write(message,'(a,2x,a)') ch10," == Destroy CTQMC done"
1751 34 : call wrtout(std_out,message,'COLL')
1752 34 : ABI_FREE(hybri_limit)
1753 34 : ABI_FREE(levels_ctqmc_nd)
1754 34 : ABI_FREE(levels_ctqmc)
1755 34 : ABI_FREE(levels_ctqmc_complex)
1756 34 : ABI_FREE(fw1)
1757 34 : ABI_FREE(fw1_nd)
1758 :
1759 : ! ____________________________________________________________
1760 : !
1761 : ! FOURTH PART : USE OUTPUT OF CTQMC AND THEN DO BACK ROTATION
1762 : ! ____________________________________________________________
1763 : !
1764 :
1765 : ! Put green's function values from CTQMC into green structure
1766 : !------------------------------------------------------------
1767 34 : call ctqmcoutput_to_green(green,paw_dmft,gtmp_nd,gtmp_ndc,gw_tmp_nd,gtmp,gw_tmp,iatom,leg_measure,opt_nondiag,opt_complex)
1768 :
1769 : ! Deallocate arrays for CTQMC
1770 : !----------------------------
1771 34 : if (paw_dmft%dmft_solv < 6) then
1772 34 : ABI_FREE(gw_tmp)
1773 : end if
1774 34 : ABI_FREE(gw_tmp_nd)
1775 34 : ABI_FREE(gtmp)
1776 34 : ABI_FREE(gtmp_nd)
1777 68 : if(paw_dmft%dmft_solv .eq. 10) then
1778 0 : ABI_FREE(gtmp_ndc)
1779 : endif
1780 :
1781 : ! Do Fourier transform if it was not done (ie if TRIQS is used without legendre measurement)
1782 : !-------------------------------------------------------------------------------------------
1783 : ! if(opt_nondiag==1) then ! (As leg_measure is activated by defautl, this fourier is never done).
1784 : ! if(paw_dmft%dmft_solv>=6.and..not.leg_measure.and.paw_dmft%dmft_solv<=7) then
1785 : ! write(message,'(2a,i3,13x,a)') ch10,' === Direct Fourier Transform t->w of Weiss Field'
1786 : ! call wrtout(std_out,message,'COLL')
1787 : ! call fourier_green(cryst_struc,green,paw_dmft,&
1788 : ! & pawang,opt_ksloc=2,opt_tw=1)
1789 : ! end if
1790 : ! endif
1791 :
1792 : ! end if
1793 :
1794 : end do ! iatom
1795 34 : call timab(703,2,tsec(:))
1796 : ! ==================================================================
1797 : ! End big loop over atoms to compute hybridization and do the CTQMC
1798 : ! ==================================================================
1799 :
1800 34 : call timab(705,1,tsec(:))
1801 34 : if (paw_dmft%dmft_prgn == 1) then
1802 0 : call print_green('QMC_diag_notsym',green,1,paw_dmft,opt_wt=2)
1803 0 : call print_green('QMC_diag_notsym',green,1,paw_dmft,opt_wt=1)
1804 : end if
1805 : ! write(message,'(i3,4x,2e21.14)') 6,weiss_for_rot%oper(1)%matlu(1)%mat(1,1,1,1,1)
1806 : ! call wrtout(std_out,message,'COLL') ! debug
1807 : ! =================================================================
1808 : ! Inverse Weiss, then
1809 : ! Copy Weiss_for_rot into weiss and rotate back weiss to the original basis
1810 : ! =================================================================
1811 :
1812 : ! ABI_MALLOC(shift,(natom))
1813 : ! do ifreq=1,paw_dmft%dmft_nwlo
1814 : ! ! First weiss_for_rot contains -G_0^-1+iw_n
1815 : ! ! -------------------------------------------
1816 : ! ! Compute G_0^-1-iw_n
1817 : ! ! --------------------
1818 : ! write(6,*) "1"
1819 : ! if(opt_fk==1) call fac_matlu(weiss_for_rot%oper(ifreq)%matlu,natom,-cone)
1820 : !
1821 : !
1822 : ! write(6,*) "2"
1823 : ! ! Compute G_0^-1
1824 : ! ! --------------------
1825 : ! shift(:)=cmplx(zero,paw_dmft%omega_lo(ifreq),kind=dp)
1826 : ! if(opt_fk==1) call shift_matlu(weiss_for_rot%oper(ifreq)%matlu,natom,shift,signe=1)
1827 : !
1828 : ! write(6,*) "3"
1829 : ! ! Compute G_0
1830 : ! ! --------------------
1831 : ! call inverse_oper(weiss_for_rot%oper(ifreq),option=1,prtopt=1)
1832 : ! ! No need to copy if weiss_for_rot is a pointer to weiss ...
1833 : !! if(useylm==1) call slm2ylm_matlu(weiss%oper(ifreq)%matlu,natom,2,0)
1834 : !! if(opt_diag/=0) call rotate_matlu(weiss%oper(ifreq)%matlu,eigvectmatlu,natom,3,0)
1835 : !
1836 : ! ! Compute G_0 in the original basis
1837 : ! ! --------------------
1838 : ! call rotate_matlu(weiss_for_rot%oper(ifreq)%matlu,eigvectmatlu,natom,3,0)
1839 : ! end do
1840 : ! ABI_FREE(shift)
1841 :
1842 : ! =================================================================
1843 : ! Here compute Self energy from Dyson and print it
1844 : ! Warning : Weiss_for_rot is inversed inside dyson
1845 : ! =================================================================
1846 : ! call initialize_self(self,paw_dmft)
1847 : ! call dyson(green,paw_dmft,self,weiss_for_rot,opt_weissself=2)
1848 : ! call rw_self(self,mpi_enreg,paw_dmft,prtopt=2,opt_rw=2,opt_char="diag")
1849 : ! call destroy_self(self)
1850 : !write(message,'(i3,4x,2e21.14)') 7,weiss%oper(1)%matlu(1)%mat(1,1,1,1,1)
1851 : !call wrtout(std_out,message,'COLL') ! debug
1852 :
1853 : ! =================================================================
1854 : ! Rotate back green function to original basis (non-diagonal)
1855 : ! (and Weiss for further use: might be useful if an back Fourier
1856 : ! transformation is done).
1857 : ! =================================================================
1858 34 : if (pawprtvol >= 3) then
1859 28 : write(message,'(a,2x,a)') ch10, & ! debug
1860 56 : & " == Print Green's function for tau=0+ in the CTQMC basis" ! debug
1861 28 : call wrtout(std_out,message,'COLL') ! debug
1862 28 : call print_matlu(green%oper_tau(1)%matlu(:),natom,1,compl=1) ! debug
1863 28 : write(message,'(a,2x,a)') ch10,& ! debug
1864 56 : & " == Print Green's function for smallest freq in the CTQMC basis" ! debug
1865 28 : call wrtout(std_out,message,'COLL') ! debug
1866 28 : call print_matlu(green%oper(1)%matlu(:),natom,1) ! debug
1867 : end if ! pawprtvol>=3
1868 :
1869 : ! === Compute rotated Occupations in green%occup_tau
1870 34 : call occup_green_tau(green)
1871 :
1872 34 : if (pawprtvol >= 3) then
1873 : ! === Compute non rotated Occupations in green%occup_tau
1874 28 : write(message,'(a,2x,a)') ch10," == Occupations from G(tau=0-) in the CTQMC basis"
1875 28 : call wrtout(std_out,message,'COLL')
1876 28 : call print_matlu(green%occup_tau%matlu(:),natom,1)
1877 : end if ! pawprtvol>=3
1878 :
1879 : ! =================================================================
1880 : !
1881 : ! === Compute magnetic moments from CT-QMC occupations for
1882 : ! the x,y and z axes when SOC is activated
1883 : !
1884 : ! =================================================================
1885 34 : if (paw_dmft%nspinor .eq. 2) then
1886 0 : ABI_MALLOC(matlumag,(natom))
1887 0 : ABI_MALLOC(muzeem,(natom))
1888 0 : ABI_MALLOC(muspin,(natom))
1889 0 : ABI_MALLOC(muorb,(natom))
1890 0 : write(message,'(a,2x,a)') ch10,"== Magnetic moments from CT-QMC occupation matrix "
1891 0 : call wrtout(std_out,message,'COLL')
1892 :
1893 0 : do iatom=1,cryst_struc%natom
1894 0 : lpawu=paw_dmft%lpawu(iatom)
1895 0 : if(lpawu .ne. -1) then
1896 0 : write(message,'(a,3x,a,i4)') ch10,"-------> For Correlated Atom",iatom
1897 0 : call wrtout(std_out,message,'COLL')
1898 :
1899 : ! == orbital angular momentum
1900 0 : do icomp=1,3 !x,y,z components
1901 0 : muorb(iatom)=czero
1902 0 : call init_matlu(natom=natom,nspinor=paw_dmft%nspinor,nsppol=paw_dmft%nsppol,lpawu_natom=paw_dmft%lpawu,matlu=matlumag)
1903 0 : call copy_matlu(green%occup_tau%matlu,matlumag,natom)
1904 0 : if (usejmj == 1) then
1905 0 : call ylm2jmj_matlu(matlumag,natom,2,paw_dmft)
1906 : else
1907 0 : call rotate_matlu(matlumag,eigvectmatlu,natom=natom,inverse=0)
1908 : endif
1909 0 : call magmomforb_matlu(matlumag,muorb,natom=natom,option=icomp,optprt=0)
1910 0 : write(message,'(a,2x,a,i4,a,f8.4)') ch10," Orbital angular momentum for axis ", icomp, " is ", REAL(muorb(iatom))
1911 0 : call wrtout(std_out,message,'COLL')
1912 0 : call destroy_matlu(matlumag,(natom))
1913 : end do
1914 :
1915 : ! == spin angular momentum
1916 0 : do icomp=1,3 !x,y,z components
1917 0 : muspin(iatom)=czero
1918 0 : call init_matlu(natom=natom,nspinor=paw_dmft%nspinor,nsppol=paw_dmft%nsppol,lpawu_natom=paw_dmft%lpawu,matlu=matlumag)
1919 0 : call copy_matlu(green%occup_tau%matlu,matlumag,natom=natom)
1920 0 : if (usejmj == 1) then
1921 0 : call ylm2jmj_matlu(matlumag,natom,2,paw_dmft)
1922 : else
1923 0 : call rotate_matlu(matlumag,eigvectmatlu,natom=natom,inverse=0)
1924 : endif
1925 0 : call magmomfspin_matlu(matlumag,muspin,natom=natom,option=icomp,optprt=0)
1926 0 : write(message,'(a,2x,a,i4,a,f8.4)') ch10," Spin angular momentum for axis ", icomp, " is ", REAL(muspin(iatom))
1927 0 : call wrtout(std_out,message,'COLL')
1928 0 : call destroy_matlu(matlumag,(natom))
1929 : end do
1930 :
1931 : ! == total angular momentum (L_u + 2*S_u)
1932 0 : do icomp=1,3 !x,y,z components
1933 0 : muzeem(iatom)=czero
1934 0 : call init_matlu(natom=natom,nspinor=paw_dmft%nspinor,nsppol=paw_dmft%nsppol,lpawu_natom=paw_dmft%lpawu,matlu=matlumag)
1935 0 : call copy_matlu(green%occup_tau%matlu,matlumag,natom=natom)
1936 0 : if (usejmj == 1) then
1937 0 : call ylm2jmj_matlu(matlumag,natom,2,paw_dmft)
1938 : else
1939 0 : call rotate_matlu(matlumag,eigvectmatlu,natom=natom,inverse=0)
1940 : endif
1941 0 : call magmomfzeeman_matlu(matlumag,muzeem,natom=natom,option=icomp,optprt=0)
1942 0 : write(message,'(a,2x,a,i4,a,f8.4)') ch10," Zeeman angular momentum for axis ", icomp, " is ", REAL(muzeem(iatom))
1943 0 : call wrtout(std_out,message,'COLL')
1944 0 : call destroy_matlu(matlumag,(natom))
1945 : end do
1946 : endif !lpawu
1947 : end do !iatom
1948 0 : ABI_FREE(matlumag)
1949 0 : ABI_FREE(muzeem)
1950 0 : ABI_FREE(muspin)
1951 0 : ABI_FREE(muorb)
1952 : end if !nspinor
1953 : ! =================================================================
1954 :
1955 34 : if (opt_diag /= 0) then
1956 14 : write(message,'(a,2x,a)') ch10," == Rotate Green's function back to original basis "
1957 14 : call wrtout(std_out,message,'COLL')
1958 : end if
1959 : ! write(message,'(i3,4x,2e21.14)') 8,weiss%oper(1)%matlu(1)%mat(1,1,1,1,1)
1960 : ! call wrtout(std_out,message,'COLL') ! debug
1961 :
1962 : ! Rotate oper_tau into Ylm basis and then Slm basis
1963 : ! -------------------------------------------------------------
1964 : ! do itau=1,paw_dmft%dmftqmc_l
1965 : ! if (opt_diag /= 0) call rotate_matlu(green%oper_tau(itau)%matlu(:),eigvectmatlu(:),natom,3,0)
1966 : ! if (useylm == 1) call slm2ylm_matlu(green%oper_tau(itau)%matlu(:),natom,2,0)
1967 : ! end do
1968 7584 : do itau=1,paw_dmft%dmftqmc_l
1969 7550 : if (opt_diag /= 0) then
1970 700 : call rotate_matlu(green%oper_tau(itau)%matlu(:),eigvectmatlu(:),natom,0)
1971 : end if
1972 7550 : if (usejmj == 1) then
1973 0 : call ylm2jmj_matlu(green%oper_tau(itau)%matlu(:),natom,2,paw_dmft)
1974 : endif
1975 7584 : if (useylm == 1) then
1976 0 : call slm2ylm_matlu(green%oper_tau(itau)%matlu(:),natom,paw_dmft,2,0)
1977 : end if
1978 : end do ! itau
1979 :
1980 : ! Rotate occup_tau into Ylm basis and then Slm basis
1981 :
1982 : ! Rotate occup_tau into Ylm basis and then Slm basis
1983 : !-------------------------------------------------------------
1984 34 : if (opt_diag /= 0) then
1985 14 : call rotate_matlu(green%occup_tau%matlu(:),eigvectmatlu(:),natom,0)
1986 : end if
1987 34 : if (usejmj == 1) then
1988 0 : write(message,'(a,2x,a)') ch10," == Occupations from G(tau=0-) in the jmj basis"
1989 0 : call wrtout(std_out,message,'COLL')
1990 0 : call ylm2jmj_matlu(green%occup_tau%matlu(:),natom,2,paw_dmft)
1991 0 : call print_matlu(green%occup_tau%matlu(:),natom,1)
1992 : endif
1993 34 : if (useylm == 1) then
1994 0 : write(message,'(a,2x,a)') ch10," == Occupations from G(tau=0-) in the Ylm basis"
1995 0 : call wrtout(std_out,message,'COLL')
1996 0 : call print_matlu(green%occup_tau%matlu(:),natom,1)
1997 0 : call slm2ylm_matlu(green%occup_tau%matlu(:),natom,paw_dmft,2,0)
1998 : end if
1999 : ! write(message,'(a,2x,a)') ch10," == Occupations from G(tau=0-) in the Slm basis"
2000 : ! call wrtout(std_out,message,'COLL')
2001 : ! call print_matlu(green%occup_tau%matlu(:),natom,1)
2002 :
2003 : ! Put Weiss off diagonal terms to zero because Green function will not have any offdiag terms
2004 : ! ------------------------------------------------------------------------------
2005 : ! (if opt_nondiag=0 ie dmft_solv=5)
2006 34 : if (opt_nondiag == 0) then
2007 17963 : do ifreq=1,nwlo
2008 17963 : call zero_matlu(weiss%oper(ifreq)%matlu(:),natom,onlynondiag=1)
2009 : end do ! ifreq
2010 : end if ! opt_nondiag=0
2011 : ! ( if opt_nondiag=0, then:
2012 : ! As Green's function is diagonal, one suppress off diag terms in Weiss, if any.
2013 : ! (If off diag are non zero in the density matrix and thus in the Green's function,
2014 : ! there is a warning in checkreal_matlu above).)
2015 :
2016 : ! Rotate Green's and Weiss functions into Ylm basis and then Slm basis
2017 : !-------------------------------------------------------------
2018 :
2019 17963 : do ifreq=1,nwlo
2020 17929 : if (opt_diag /= 0) then
2021 1260 : call rotate_matlu(green%oper(ifreq)%matlu(:),eigvectmatlu(:),natom,0)
2022 1260 : call rotate_matlu(weiss%oper(ifreq)%matlu(:),eigvectmatlu(:),natom,0)
2023 : end if
2024 17929 : if (usejmj == 1) then
2025 0 : call ylm2jmj_matlu(green%oper(ifreq)%matlu(:),natom,2,paw_dmft)
2026 0 : call ylm2jmj_matlu(weiss%oper(ifreq)%matlu(:),natom,2,paw_dmft)
2027 : endif
2028 17963 : if (useylm == 1) then
2029 0 : call slm2ylm_matlu(green%oper(ifreq)%matlu(:),natom,paw_dmft,2,0)
2030 0 : call slm2ylm_matlu(weiss%oper(ifreq)%matlu(:),natom,paw_dmft,2,0)
2031 : end if
2032 : end do ! ifreq
2033 :
2034 : !write(message,'(i3,4x,2e21.14)') 10,weiss%oper(1)%matlu(1)%mat(1,1,1,1,1)
2035 : !call wrtout(std_out,message,'COLL') ! debug
2036 :
2037 34 : if (pawprtvol >= 3) then
2038 : !< HACK >
2039 28 : write(message,'(a,2x,a)') ch10,& ! debug
2040 56 : & " == Print diagonalized weiss_for_rot function after rotation for small freq in the ctqmc basis" ! debug
2041 28 : call wrtout(std_out,message,'COLL') ! debug
2042 28 : call print_matlu(weiss_for_rot%oper(1)%matlu(:),natom,1) ! debug
2043 :
2044 : !</ HACK >
2045 28 : write(message,'(a,2x,a)') ch10,& ! debug
2046 56 : & " == Print Weiss function for smallest freq in the Slm basis" ! debug
2047 28 : call wrtout(std_out,message,'COLL') ! debug
2048 28 : call print_matlu(weiss%oper(1)%matlu(:),natom,1) ! debug
2049 :
2050 17453 : do ifreq=1,nwlo
2051 17453 : call sym_matlu(weiss%oper(ifreq)%matlu(:),paw_dmft)
2052 : end do
2053 28 : write(message,'(a,2x,a)') ch10,& ! debug
2054 56 : & " == Print symmetrized Weiss function for smallest freq in the Slm basis" ! debug
2055 28 : call wrtout(std_out,message,'COLL') ! debug
2056 28 : call print_matlu(weiss%oper(1)%matlu(:),natom,1) ! debug
2057 28 : write(message,'(a,2x,a)') ch10, & ! debug
2058 56 : & " == Print Green's function for tau=0+ in the Slm basis" ! debug
2059 28 : call wrtout(std_out,message,'COLL') ! debug
2060 28 : call print_matlu(green%oper_tau(1)%matlu(:),natom,1) ! debug
2061 28 : write(message,'(a,2x,a)') ch10,& ! debug
2062 56 : & " == Print Green's function for smallest freq in the Slm basis" ! debug
2063 28 : call wrtout(std_out,message,'COLL') ! debug
2064 28 : call print_matlu(green%oper(1)%matlu(:),natom,1) ! debug
2065 : end if ! pawprtvol>=3
2066 :
2067 164 : ABI_MALLOC(matlu1,(natom))
2068 34 : call init_matlu(natom,nspinor,nsppol,paw_dmft%lpawu(:),matlu1(:))
2069 34 : call copy_matlu(green%occup_tau%matlu(:),matlu1(:),natom)
2070 34 : call sym_matlu(matlu1(:),paw_dmft)
2071 :
2072 34 : write(message,'(a,2x,a)') ch10," == Occupations from G(tau=0-) in the Slm basis"
2073 34 : call wrtout(std_out,message,'COLL')
2074 34 : call print_matlu(green%occup_tau%matlu(:),natom,1)
2075 :
2076 34 : write(message,'(a,2x,a)') ch10," == Symmetrized occupations"
2077 34 : call wrtout(std_out,message,'COLL')
2078 34 : call print_matlu(matlu1(:),natom,1)
2079 :
2080 34 : call diff_matlu("CTQMC occupations","Symmetrized CTQMC occupations",green%occup_tau%matlu(:),matlu1(:),natom,0,tol4,ierr=ierr)
2081 34 : call destroy_matlu(matlu1(:),natom)
2082 96 : ABI_FREE(matlu1)
2083 :
2084 : ! =================================================================
2085 : ! Symmetrize green function G(tau) and G(ifreq) to recover symmetry
2086 : ! artificially broken by QMC
2087 : ! =================================================================
2088 34 : write(message,'(a,2x,a)') ch10," == Symmetrize Green's function after CTQMC "
2089 34 : call wrtout(std_out,message,'COLL')
2090 :
2091 68 : do itau=1,1 !paw_dmft%dmftqmc_l
2092 68 : call sym_matlu(green%oper_tau(itau)%matlu(:),paw_dmft)
2093 : end do ! itau
2094 :
2095 : ! Perform symetry on GPU if requested
2096 34 : if (paw_dmft%gpu_option == ABI_GPU_OPENMP) then
2097 : #ifdef HAVE_OPENMP_OFFLOAD
2098 : ! 1) Init green_oper_ndat
2099 : call init_oper_ndat(paw_dmft,green_oper_ndat,nwlo,nkpt=green%oper(1)%nkpt,opt_ksloc=2,gpu_option=paw_dmft%gpu_option)
2100 : if (green%oper(1)%has_operks == 0) then
2101 : green_oper_ndat%paral = 1
2102 : green_oper_ndat%shiftk = green%distrib%shiftk
2103 : end if
2104 : ! 2) Copy green%oper(:)%matlu into green_oper_ndat (CPU->GPU transfer)
2105 : call copy_oper_to_ndat(green%oper,green_oper_ndat,nwlo,green%nw,green%distrib%proct,green%distrib%me_freq,.false.)
2106 :
2107 : ! 3) Perform sym_matlu on green_oper_ndat (GPU enabled)
2108 : call sym_matlu(green_oper_ndat%matlu(:),paw_dmft)
2109 :
2110 : ! 4) Copy back green%oper(:)%matlu from green_oper_ndat (GPU->CPU transfer)
2111 : call copy_oper_from_ndat(green_oper_ndat,green%oper,nwlo,green%nw,green%distrib%proct,&
2112 : & green%distrib%me_freq,.false.)
2113 : ! 5) Destroy green_oper_ndat
2114 : call destroy_oper(green_oper_ndat)
2115 : #endif
2116 : else
2117 17963 : do ifreq=1,paw_dmft%dmft_nwlo
2118 17963 : call sym_matlu(green%oper(ifreq)%matlu(:),paw_dmft)
2119 : end do ! ifreq
2120 : end if
2121 :
2122 :
2123 34 : if (pawprtvol >= 3) then
2124 28 : write(message,'(a,2x,a)') ch10, & ! debug
2125 56 : & " == Print Green's function for tau=0+ after symmetrization" ! debug
2126 28 : call wrtout(std_out,message,'COLL') ! debug
2127 28 : call print_matlu(green%oper_tau(1)%matlu(:),natom,1) ! debug
2128 28 : write(message,'(a,2x,a)') ch10, & ! debug
2129 56 : & " == Print Green's function for smallest freq after symmetrization" ! debug
2130 28 : call wrtout(std_out,message,'COLL') ! debug
2131 28 : call print_matlu(green%oper(1)%matlu(:),natom,1) ! debug
2132 : end if ! pawprtvol>=3
2133 34 : if (paw_dmft%dmft_prgn == 1) then
2134 0 : call print_green('QMC_sym',green,1,paw_dmft,opt_wt=2)
2135 0 : call print_green('QMC_sym',green,1,paw_dmft,opt_wt=1)
2136 : end if
2137 :
2138 : ! === Compute Occupations (Symmetrized from oper_tau)
2139 34 : call occup_green_tau(green)
2140 :
2141 : ! === Print occupations
2142 : ! call printocc_green(green,6,paw_dmft,3)
2143 :
2144 34 : call destroy_oper(energy_level)
2145 34 : call destroy_matlu(dmat_diag(:),natom)
2146 34 : call destroy_matlu(eigvectmatlu(:),natom)
2147 34 : call destroy_matlu(udens_atoms(:),natom)
2148 96 : ABI_FREE(dmat_diag)
2149 96 : do iatom=1,natom
2150 62 : lpawu = paw_dmft%lpawu(iatom)
2151 62 : if (lpawu == -1) cycle
2152 34 : ABI_FREE(magmom_orb(iatom)%value)
2153 34 : ABI_FREE(magmom_spin(iatom)%value)
2154 96 : ABI_FREE(magmom_tot(iatom)%value)
2155 : end do
2156 96 : ABI_FREE(udens_atoms)
2157 96 : ABI_FREE(eigvectmatlu)
2158 96 : ABI_FREE(magmom_orb)
2159 96 : ABI_FREE(magmom_spin)
2160 96 : ABI_FREE(magmom_tot)
2161 96 : ABI_FREE(matlumag_orb)
2162 96 : ABI_FREE(matlumag_spin)
2163 96 : ABI_FREE(matlumag_tot)
2164 34 : call destroy_green(weiss_for_rot)
2165 : ! call destroy_green(gw_loc)
2166 : ! call destroy_green(greendft)
2167 :
2168 : ! destroy limit of hybridization
2169 34 : call destroy_matlu(hybri_coeff(:),paw_dmft%natom)
2170 96 : ABI_FREE(hybri_coeff)
2171 :
2172 34 : call destroy_vee(paw_dmft,vee_rotated(:))
2173 96 : ABI_FREE(vee_rotated)
2174 34 : call timab(705,2,tsec(:))
2175 34 : call timab(701,2,tsec(:))
2176 :
2177 272 : end subroutine qmc_prep_ctqmc
2178 : !!***
2179 :
2180 : !!****f* m_forctqmc/testcode_ctqmc_b
2181 : !! NAME
2182 : !! testcode_ctqmc_b
2183 : !!
2184 : !! FUNCTION
2185 : !! Setup ultra simple hybridization to test CTQMC in simple situations.
2186 : !!
2187 : !! INPUTS
2188 : !! temp = temperature
2189 : !! dmftqmc_l = number of times slices
2190 : !! levels_ctqmc_nd=level matrix
2191 : !!
2192 : !! OUTPUT
2193 : !! fw1_nd=hybridization matrix
2194 : !! umod = value of U
2195 : !! hybri_limit= limit of F
2196 : !! weiss_for_rot= weiss function
2197 : !! hybri_coeff
2198 : !!
2199 : !! SIDE EFFECTS
2200 : !!
2201 : !! NOTES
2202 : !!
2203 : !! SOURCE
2204 :
2205 0 : subroutine testcode_ctqmc_b(energy_level,hybri_coeff,weiss_for_rot,dmftqmc_l,fw1_nd,levels_ctqmc,&
2206 0 : & levels_ctqmc_nd,hybri_limit,temp,umod,opt_diag,opt_fk)
2207 :
2208 : !Arguments ------------------------------------
2209 : !scalars
2210 : integer, intent(in) :: dmftqmc_l,opt_diag,opt_fk
2211 : real(dp), intent(in) :: temp
2212 : real(dp), intent(out) :: umod(2,2)
2213 : real(dp), intent(inout) :: levels_ctqmc(:)
2214 : complex(dp), intent(out) :: fw1_nd(:,:,:)
2215 : complex(dp), intent(inout) :: levels_ctqmc_nd(:,:)
2216 : complex(dp), intent(inout) :: hybri_limit(:,:)
2217 : type(oper_type) :: energy_level
2218 : type(matlu_type), allocatable :: hybri_coeff(:)
2219 : type(green_type) :: weiss_for_rot
2220 :
2221 : !Local variables ------------------------------
2222 : integer :: ifreq,iatom,ima,imb,ispa,ispb,ndim
2223 : real(dp) :: omega
2224 : real(dp) :: facnd, facd
2225 : character(len=30) :: tmpfil
2226 : ! ************************************************************************
2227 0 : facnd=0.8d0
2228 0 : facd=1.0d0
2229 0 : ndim=2*energy_level%matlu(iatom)%lpawu+1
2230 : !write(6,*) "fac",facnd,facd
2231 0 : levels_ctqmc_nd(2,2) = energy_level%matlu(iatom)%mat(imb+(ispb-1)*ndim,imb+(ispb-1)*ndim,1)
2232 0 : levels_ctqmc_nd(1,1) = energy_level%matlu(iatom)%mat(ima+(ispa-1)*ndim,ima+(ispa-1)*ndim,1)
2233 0 : levels_ctqmc(2) = real(energy_level%matlu(iatom)%mat(imb+(ispb-1)*ndim,imb+(ispb-1)*ndim,1),kind=dp)
2234 0 : levels_ctqmc(1) = real(energy_level%matlu(iatom)%mat(ima+(ispa-1)*ndim,ima+(ispa-1)*ndim,1),kind=dp)
2235 0 : if(opt_diag/=1) then
2236 0 : levels_ctqmc_nd(1,2) = energy_level%matlu(iatom)%mat(ima+(ispa-1)*ndim,imb+(ispb-1)*ndim,1)
2237 0 : levels_ctqmc_nd(2,1) = energy_level%matlu(iatom)%mat(imb+(ispb-1)*ndim,ima+(ispa-1)*ndim,1)
2238 : end if
2239 0 : hybri_limit(1,1) = facd*hybri_coeff(iatom)%mat(ima+(ispa-1)*ndim,ima+(ispa-1)*ndim,1)
2240 0 : hybri_limit(2,2) = facd*hybri_coeff(iatom)%mat(imb+(ispb-1)*ndim,imb+(ispb-1)*ndim,1)
2241 0 : hybri_limit(1,2) = facnd*hybri_coeff(iatom)%mat(ima+(ispa-1)*ndim,imb+(ispb-1)*ndim,1)
2242 0 : hybri_limit(2,1) = facnd*hybri_coeff(iatom)%mat(imb+(ispb-1)*ndim,ima+(ispa-1)*ndim,1)
2243 : !write(6,*) "hybri_limit",hybri_limit
2244 : !write(6,*) "levels_ctqmc",levels_ctqmc
2245 0 : umod=zero
2246 :
2247 : tmpfil = 'fw1_nd_re'
2248 : !if (open_file(newunit=unt,message,file=trim(tmpfil),status='unknown',form='formatted')/=0) then
2249 : ! ABI_ERROR(message)
2250 : !end if
2251 0 : tmpfil = 'fw1_nd_im'
2252 : !if (open_file(newunit=unt2,message,file=trim(tmpfil),status='unknown',form='formatted')/=0) then
2253 : ! ABI_ERROR(message)
2254 : !end if
2255 0 : write(std_out,*) "testcode==2",ispa,ispb,ima,imb
2256 0 : write(std_out,*) "opt_fk==",opt_fk
2257 0 : do ifreq=1,dmftqmc_l
2258 0 : if (opt_fk==1) then
2259 0 : fw1_nd(ifreq,1,1) = facd*weiss_for_rot%oper(ifreq)%matlu(iatom)%mat(ima+(ispa-1)*ndim,ima+(ispa-1)*ndim,1)
2260 0 : fw1_nd(ifreq,2,2) = facd*weiss_for_rot%oper(ifreq)%matlu(iatom)%mat(imb+(ispb-1)*ndim,imb+(ispb-1)*ndim,1)
2261 : !fw1_nd(ifreq,1,2) = weiss_for_rot%oper(ifreq)%matlu(iatom)%mat(ima,imb,1,ispa,ispb)
2262 : !fw1_nd(ifreq,2,1) = weiss_for_rot%oper(ifreq)%matlu(iatom)%mat(imb,ima,1,ispb,ispa)
2263 0 : fw1_nd(ifreq,1,2) = facnd*weiss_for_rot%oper(ifreq)%matlu(iatom)%mat(ima+(ispa-1)*ndim,imb+(ispb-1)*ndim,1)
2264 0 : fw1_nd(ifreq,2,1) = facnd*weiss_for_rot%oper(ifreq)%matlu(iatom)%mat(imb+(ispb-1)*ndim,ima+(ispa-1)*ndim,1)
2265 0 : omega=pi*temp*(two*float(ifreq)-1)
2266 0 : else if (opt_fk==0) then
2267 0 : fw1_nd(ifreq,1,1) = facd*weiss_for_rot%oper(ifreq)%matlu(iatom)%mat(ima+(ispa-1)*ndim,ima+(ispa-1)*ndim,1)
2268 0 : fw1_nd(ifreq,2,2) = facd*weiss_for_rot%oper(ifreq)%matlu(iatom)%mat(imb+(ispb-1)*ndim,imb+(ispb-1)*ndim,1)
2269 0 : fw1_nd(ifreq,1,2) = facnd*weiss_for_rot%oper(ifreq)%matlu(iatom)%mat(ima+(ispa-1)*ndim,imb+(ispb-1)*ndim,1)
2270 0 : fw1_nd(ifreq,2,1) = facnd*weiss_for_rot%oper(ifreq)%matlu(iatom)%mat(imb+(ispb-1)*ndim,ima+(ispa-1)*ndim,1)
2271 0 : call xginv(fw1_nd(ifreq,:,:),2)
2272 : end if
2273 : end do
2274 0 : end subroutine testcode_ctqmc_b
2275 : !!***
2276 :
2277 :
2278 : !!****f* m_forctqmc/testcode_ctqmc
2279 : !! NAME
2280 : !! testcode_ctqmc
2281 : !!
2282 : !! FUNCTION
2283 : !! Setup ultra simple hybridization to test CTQMC in simple situations.
2284 : !!
2285 : !! INPUTS
2286 : !! gtmp_nd
2287 : !! gw_tmp_nd
2288 : !! temp = temperature
2289 : !! dmftqmc_l = number of times slices
2290 : !! nflavor = number of flavor
2291 : !! testrot = 0/1 if rotation of hybridization is tested or not
2292 : !! testcode = 1 if tests are activated.
2293 : !! opt = 1/2 if pre or postprocessing of CTQMC data.
2294 : !!
2295 : !! OUTPUT
2296 : !! fw1_nd = non diagonal hybridization
2297 : !! fw1 = hybridization
2298 : !! umod = value of U
2299 : !!
2300 : !!
2301 : !! SIDE EFFECTS
2302 : !! gtmp_nd
2303 : !! gw_tmp_nd
2304 : !!
2305 : !! NOTES
2306 : !!
2307 : !! SOURCE
2308 :
2309 0 : subroutine testcode_ctqmc(dmftqmc_l,fw1_nd,fw1,gtmp_nd,gw_tmp_nd,levels_ctqmc,hybri_limit,&
2310 : & nflavor,opt,temp,testrot,testcode,umod)
2311 :
2312 :
2313 : !Arguments ------------------------------------
2314 : !scalars
2315 : integer, intent(in) :: dmftqmc_l,nflavor,testrot,testcode,opt
2316 : real(dp), intent(in) :: temp
2317 : real(dp), intent(out) :: umod(2,2)
2318 : complex(dp), intent(inout) :: gw_tmp_nd(:,:,:)
2319 : real(dp), intent(inout) :: gtmp_nd(:,:,:)
2320 : complex(dp), intent(out) :: fw1(:,:)
2321 : complex(dp), intent(out) :: fw1_nd(:,:,:)
2322 : real(dp), intent(inout) :: levels_ctqmc(:)
2323 : complex(dp), intent(inout) :: hybri_limit(:,:)
2324 :
2325 : !Local variables ------------------------------
2326 : character(len=500) :: message
2327 : integer :: ifreq, itau,realrot,simplehyb
2328 : real(dp) :: omega
2329 : real(dp) :: tbi1,tbi2,e2,tbi3,tbi4,e3,e4,tbi21,tbi12,e3b,e4b,tbi21b,tbi12b
2330 : complex(dp) :: e1
2331 : ! arrays
2332 : complex(dp) :: RR(2,2)
2333 : complex(dp) :: RR1(2,2)
2334 : complex(dp) :: RRi(2,2)
2335 : complex(dp) :: RRt(2,2)
2336 : ! ************************************************************************
2337 0 : if (testcode==0) return
2338 0 : if (nflavor/=2) then
2339 0 : write(message,'(2a)') ch10,' testcode nflavor.ne.2'
2340 0 : ABI_ERROR(message)
2341 : end if
2342 :
2343 : simplehyb=2
2344 : simplehyb=1
2345 0 : simplehyb=3
2346 : !=========================
2347 : ! Built rotation matrix
2348 : !=========================
2349 : realrot=0
2350 0 : realrot=2
2351 : if (realrot==1) then
2352 : ! Real rotation
2353 : !=========================
2354 : RR(1,1) = SQRT(3.d0)/2.d0
2355 : RR(1,2) = -1.d0/2.d0
2356 : RR(2,1) = 1.d0/2.d0
2357 : RR(2,2) = SQRT(3.d0)/2.d0
2358 : else if (realrot==2) then
2359 : ! Real rotation
2360 : !=========================
2361 0 : RR(1,1) = SQRT(1.d0/2.d0)
2362 0 : RR(1,2) = -SQRT(1.d0/2.d0)
2363 0 : RR(2,1) = SQRT(1.d0/2.d0)
2364 0 : RR(2,2) = SQRT(1.d0/2.d0)
2365 : else
2366 : ! Complex rotation
2367 : !=========================
2368 : RR(1,1) = CMPLX(one,two)
2369 : RR(1,2) = CMPLX(one,one)
2370 : RR(2,1) = CMPLX(one,-one)
2371 : RR(2,2) = CMPLX(-one,two)
2372 : RR=RR/sqrt(seven)
2373 : end if
2374 : ! Check rotation is unitary
2375 : !==========================
2376 0 : RRi(1,1) = conjg(RR(1,1))
2377 0 : RRi(1,2) = conjg(RR(2,1))
2378 0 : RRi(2,1) = conjg(RR(1,2))
2379 0 : RRi(2,2) = conjg(RR(2,2))
2380 0 : RR1(:,:) = MATMUL ( RR(:,:) , RRi(:,:) )
2381 : !write(6,*) "RR1",RR1
2382 0 : if(abs(RR1(1,1)-one).gt.tol7.or.abs(RR1(1,2)).gt.tol7.or.abs(RR1(2,2)-one).gt.tol7.or.abs(RR1(2,1)).gt.tol7) then
2383 0 : write(message,'(2a)') ch10,' testcode error in rotation matrix'
2384 0 : ABI_ERROR(message)
2385 : end if
2386 :
2387 :
2388 : !=================================
2389 : ! Built hybridization for CTQMC
2390 : !=================================
2391 0 : if (opt==1) then
2392 :
2393 : ! Parameters: tight-binding + U
2394 : ! firt test of the code try umod=0, and (tbi1,tbi2,e1,e2)=(2,1,0.5,0.0) testrot=1
2395 : ! second test of the code try umod=four, and (tbi1,tbi2,e1,e2)=(2,1,0.0,0.0) testrot=1
2396 : !=======================================================================================
2397 0 : fw1_nd(:,:,:)= czero
2398 0 : tbi1=2.0_dp
2399 0 : tbi2=1.0_dp
2400 0 : tbi3=1.0_dp
2401 0 : tbi4=1.0_dp
2402 0 : tbi12=2.5_dp
2403 0 : tbi12b=2.5_dp
2404 0 : tbi21=2.5_dp
2405 0 : tbi21b=2.5_dp
2406 0 : e1=cmplx(0.0,0.0,8)
2407 0 : e2=zero
2408 0 : e3=0.2
2409 0 : e4=0.3
2410 0 : e3b=0.3
2411 0 : e4b=-0.2
2412 0 : umod(:,:)=0.d0
2413 :
2414 : if(testrot==1.and.(abs(tbi1-tbi2)<tol6)) then
2415 : write(message,'(3a)') ch10,' testrot=1 with tbi1=tbi2 is equivalent' &
2416 : ,'to testrot=0: change testrot'
2417 : ABI_WARNING(message)
2418 : end if
2419 : ! Built fw1_nd
2420 : !==============
2421 0 : do ifreq=1,dmftqmc_l
2422 :
2423 0 : omega=pi*temp*(two*float(ifreq)-1)
2424 :
2425 : if(simplehyb==1) then
2426 : fw1_nd(ifreq,1,1) = -umod(1,1)/two+tbi1**2/(dcmplx(0.d0,omega)-e1)
2427 : fw1_nd(ifreq,2,2) = -umod(1,1)/two+tbi2**2/(dcmplx(0.d0,omega)-e2)
2428 : fw1(ifreq,1) = -umod(1,1)/two+tbi1**2/(dcmplx(0.d0,omega)-e1)
2429 : fw1(ifreq,2) = -umod(1,1)/two+tbi2**2/(dcmplx(0.d0,omega)-e2)
2430 : hybri_limit(1,1)=tbi1**2
2431 : hybri_limit(2,2)=tbi2**2
2432 : hybri_limit(1,2)=0.d0
2433 : hybri_limit(2,1)=0.d0
2434 : else if(simplehyb==2) then
2435 : fw1_nd(ifreq,1,1) = -umod(1,1)/two+tbi1**2/(dcmplx(0.d0,omega)-e1)+tbi3**2/(dcmplx(0.d0,omega)-e3)
2436 : fw1_nd(ifreq,2,2) = -umod(1,1)/two+tbi2**2/(dcmplx(0.d0,omega)-e2)+tbi4**2/(dcmplx(0.d0,omega)-e4)
2437 : fw1(ifreq,1) = -umod(1,1)/two+tbi1**2/(dcmplx(0.d0,omega)-e1)
2438 : fw1(ifreq,2) = -umod(1,1)/two+tbi2**2/(dcmplx(0.d0,omega)-e2)
2439 : else if(simplehyb==3) then
2440 0 : fw1_nd(ifreq,1,1) = -umod(1,1)/two+tbi1**2/(dcmplx(0.d0,omega)-e1)
2441 0 : fw1_nd(ifreq,2,2) = -umod(1,1)/two+tbi2**2/(dcmplx(0.d0,omega)-e2)
2442 0 : fw1_nd(ifreq,1,2) = tbi12**2/(dcmplx(0.d0,omega)-e3)+tbi12b**2/(dcmplx(0.d0,omega)-e3b)
2443 0 : fw1_nd(ifreq,2,1) = tbi21**2/(dcmplx(0.d0,omega)-e4)+tbi21b**2/(dcmplx(0.d0,omega)-e4b)
2444 0 : fw1(ifreq,1) = -umod(1,1)/two+tbi1**2/(dcmplx(0.d0,omega)-e1)
2445 0 : fw1(ifreq,2) = -umod(1,1)/two+tbi2**2/(dcmplx(0.d0,omega)-e2)
2446 0 : hybri_limit(1,1)=tbi1**2
2447 0 : hybri_limit(2,2)=tbi2**2
2448 0 : hybri_limit(1,2)=tbi12**2+tbi12b**2
2449 0 : hybri_limit(2,1)=tbi21**2+tbi21b**2
2450 : end if
2451 0 : write(132,*) omega,real(fw1_nd(ifreq,1,1)),aimag(fw1_nd(ifreq,1,1))
2452 0 : write(133,*) omega,real(fw1_nd(ifreq,1,2)),aimag(fw1_nd(ifreq,1,2))
2453 0 : write(134,*) omega,real(fw1_nd(ifreq,2,1)),aimag(fw1_nd(ifreq,2,1))
2454 0 : write(135,*) omega,real(fw1_nd(ifreq,2,2)),aimag(fw1_nd(ifreq,2,2))
2455 0 : write(1234,*) omega, real(fw1(ifreq,1)),aimag(fw1(ifreq,1))
2456 : end do
2457 : ! Built level and limit of hybridization
2458 : !=======================================
2459 0 : levels_ctqmc(1:nflavor)=-umod(1,1)/two
2460 :
2461 0 : write(std_out,*) "fw1_nd"
2462 0 : write(std_out,*) fw1_nd(1,1,1), fw1_nd(1,1,2)
2463 0 : write(std_out,*) fw1_nd(1,2,1), fw1_nd(1,2,2)
2464 0 : write(std_out,*) "fw1"
2465 0 : write(std_out,*) fw1(1,1), fw1(1,2)
2466 0 : write(std_out,*) fw1(2,1), fw1(2,2)
2467 :
2468 : ! Rotate hybridization if testrot=1
2469 : !==================================
2470 0 : if(testrot==1) then
2471 :
2472 0 : do ifreq=1,dmftqmc_l
2473 0 : RRt(:,:) = MATMUL ( RR(:,:) , fw1_nd(ifreq,:,:) )
2474 : !write(6,*) "RRt"
2475 : !write(6,*) RRt(1,1), RRt(1,2)
2476 : !write(6,*) RRt(2,1), RRt(2,2)
2477 0 : RR1(:,:) = MATMUL ( RRt(:,:) , RRi(:,:) )
2478 : !write(6,*) "RR1"
2479 : !write(6,*) RR1(1,1), RR1(1,2)
2480 : !write(6,*) RR1(2,1), RR1(2,2)
2481 0 : fw1_nd(ifreq,:,:)=RR1(:,:)
2482 0 : omega=pi*temp*(two*float(ifreq)+1)
2483 0 : write(3322,*) omega,real(fw1_nd(ifreq,1,1)),aimag(fw1_nd(ifreq,1,1))
2484 0 : write(232,*) omega,real(fw1_nd(ifreq,1,1)),aimag(fw1_nd(ifreq,1,1))
2485 0 : write(233,*) omega,real(fw1_nd(ifreq,1,2)),aimag(fw1_nd(ifreq,1,2))
2486 0 : write(234,*) omega,real(fw1_nd(ifreq,2,1)),aimag(fw1_nd(ifreq,2,1))
2487 0 : write(235,*) omega,real(fw1_nd(ifreq,2,2)),aimag(fw1_nd(ifreq,2,2))
2488 : end do
2489 :
2490 : ! Rotate limit of hybridization
2491 : !=======================================
2492 0 : RRt(:,:) = MATMUL ( RR(:,:) , hybri_limit(:,:) )
2493 0 : RR1(:,:) = MATMUL ( RRt(:,:) , RRi(:,:) )
2494 0 : hybri_limit(:,:)=RR1(:,:)
2495 :
2496 : end if
2497 : ! rajouter test real(fw1_nd(1,:,:)) doit etre diagonale
2498 :
2499 : !======================================
2500 : ! Rotate Green's function from CTQMC
2501 : !======================================
2502 0 : else if(opt==2) then
2503 :
2504 0 : write(std_out,*) "gw_tmp_nd"
2505 0 : write(std_out,*) gw_tmp_nd(1,1,1), gw_tmp_nd(1,1,2)
2506 0 : write(std_out,*) gw_tmp_nd(1,2,1), gw_tmp_nd(1,2,2)
2507 : ! Rotate Green's function back
2508 : !==============================
2509 0 : if(testrot==1) then
2510 0 : do ifreq=1,dmftqmc_l
2511 0 : RRt(1:nflavor,1:nflavor) = MATMUL ( RRi(1:nflavor,1:nflavor),gw_tmp_nd(ifreq,1:nflavor,1:nflavor) )
2512 0 : RR1(1:nflavor,1:nflavor) = MATMUL ( RRt(1:nflavor,1:nflavor),RR(1:nflavor,1:nflavor) )
2513 0 : gw_tmp_nd(ifreq,1:nflavor,1:nflavor)=RR1(1:nflavor,1:nflavor)
2514 : end do
2515 :
2516 0 : write(std_out,*) "gw_tmp_nd after rotation"
2517 0 : write(std_out,*) gw_tmp_nd(1,1,1), gw_tmp_nd(1,1,2)
2518 0 : write(std_out,*) gw_tmp_nd(1,2,1), gw_tmp_nd(1,2,2)
2519 :
2520 0 : do itau=1,dmftqmc_l
2521 0 : RRt(1:nflavor,1:nflavor) = MATMUL ( RRi(1:nflavor,1:nflavor),gtmp_nd(itau,1:nflavor,1:nflavor) )
2522 0 : RR1(1:nflavor,1:nflavor) = MATMUL ( RRt(1:nflavor,1:nflavor),RR(1:nflavor,1:nflavor) )
2523 0 : gtmp_nd(itau,1:nflavor,1:nflavor)=real(RR1(1:nflavor,1:nflavor))
2524 : end do
2525 :
2526 : ! Rotate Green's function for comparison with testrot=1
2527 : !======================================================
2528 0 : else if (testrot==0) then ! produce rotated green's function to compare to testrot=1 case
2529 :
2530 0 : do itau=1,dmftqmc_l
2531 0 : RRt(1:nflavor,1:nflavor) = MATMUL ( RR(1:nflavor,1:nflavor),gtmp_nd(itau,1:nflavor,1:nflavor) )
2532 0 : RR1(1:nflavor,1:nflavor) = MATMUL ( RRt(1:nflavor,1:nflavor),RRi(1:nflavor,1:nflavor) )
2533 0 : write(444,*) real(itau-1)/(temp*real(dmftqmc_l)),real(RR1(1,1)),real(RR1(2,2)),real(RR1(1,2)),real(RR1(2,1))
2534 : end do
2535 :
2536 : end if
2537 :
2538 : ! Print out rotated Green's function
2539 : !=====================================
2540 0 : do itau=1,dmftqmc_l
2541 0 : write(555,'(e14.5,4(2e14.5,3x))') real(itau-1)/(temp*real(dmftqmc_l)),gtmp_nd(itau,1,1),&
2542 0 : & gtmp_nd(itau,2,2),gtmp_nd(itau,1,2),gtmp_nd(itau,2,1)
2543 : end do
2544 :
2545 0 : write(message,'(2a)') ch10,' testcode end of test calculation'
2546 0 : ABI_ERROR(message)
2547 :
2548 : end if
2549 0 : close(444)
2550 0 : close(555)
2551 :
2552 : end subroutine testcode_ctqmc
2553 : !!***
2554 :
2555 : !!****f* m_forctqmc/ctqmcoutput_to_green
2556 : !! NAME
2557 : !! ctqmcoutput_to_green
2558 : !!
2559 : !! FUNCTION
2560 : !! Put values of green function from ctqmc into green datatype
2561 : !! Symetrize over spin if calculation is non magnetic
2562 : !!
2563 : !! INPUTS
2564 : !! paw_dmft <type(paw_dmft_type)>= DMFT data structure
2565 : !! gtmp_nd(dmftqmc_l,nflavor,nflavor) = Green's fct in imag time (with off diag terms)
2566 : !! gtmp_ndc(dmftqmc_l,nflavor,nflavor) = Complex Green's fct in imag time (with off diag terms)
2567 : !! gw_tmp_nd(nb_of_frequency,nflavor,nflavor) = Green's fct in imag freq (with off diag terms)
2568 : !! gtmp(dmftqmc_l,nflavor) = Green's fct in imag time (diag)
2569 : !! gw_tmp(nb_of_frequency,nflavor+1) =Green's fct in imag freq (diag)
2570 : !! iatom = atoms on which the calculation has been done
2571 : !! leg_measure = logical, to Legendre Measurement or not (if done Green function is frequency is computed)
2572 : !! opt_nondiag = integer, it activated, then
2573 : !! opt_complex = integer, 1 activate complex Gtau
2574 : !!
2575 : !! OUTPUT
2576 : !! green <type(green_type)>= green's function
2577 : !!
2578 : !!
2579 : !! SIDE EFFECTS
2580 : !!
2581 : !! NOTES
2582 : !!
2583 : !! SOURCE
2584 :
2585 34 : subroutine ctqmcoutput_to_green(green,paw_dmft,gtmp_nd,gtmp_ndc,gw_tmp_nd,gtmp,gw_tmp,iatom,leg_measure,opt_nondiag,opt_complex)
2586 :
2587 : !Arguments ------------------------------------
2588 : !scalars
2589 : type(paw_dmft_type), intent(in) :: paw_dmft
2590 : type(green_type), intent(inout) :: green
2591 : real(dp), allocatable, intent(in) :: gtmp_nd(:,:,:)
2592 : complex(dpc), allocatable, intent(in) :: gtmp_ndc(:,:,:)
2593 : complex(dpc), allocatable, intent(in) :: gw_tmp(:,:)
2594 : complex(dpc), allocatable, intent(in) :: gw_tmp_nd(:,:,:)
2595 : real(dp), allocatable, intent(in) :: gtmp(:,:)
2596 : integer, intent(in) :: iatom,opt_nondiag,opt_complex
2597 : logical(kind=1), intent(in) :: leg_measure
2598 : character(len=500) :: message
2599 :
2600 : !Local variables ------------------------------
2601 : integer :: ifreq, itau,im1,im2,isppol,ispinor1,ispinor2,iflavor1
2602 : integer :: iflavor2,tndim,ispinor,iflavor,im,nflavor
2603 : ! ************************************************************************
2604 34 : tndim=2*paw_dmft%lpawu(iatom)+1
2605 34 : nflavor=2*(tndim)
2606 :
2607 7584 : do itau=1,paw_dmft%dmftqmc_l
2608 459584 : green%oper_tau(itau)%matlu(iatom)%mat(:,:,:)=czero
2609 : end do
2610 358 : green%occup_tau%matlu(iatom)%mat(nflavor:,:,:)=czero
2611 :
2612 17963 : do ifreq=1,paw_dmft%dmft_nwlo
2613 1102093 : green%oper(ifreq)%matlu(iatom)%mat(:,:,:)=czero
2614 : end do
2615 1820 : green%occup%matlu(iatom)%mat(:,:,:)=czero
2616 :
2617 : ! built time and frequency green's function from output of CTQMC
2618 : ! =================================================================
2619 34 : if(opt_nondiag==1 .and. opt_complex==0) then
2620 0 : do isppol=1,paw_dmft%nsppol
2621 0 : do ispinor1=1,paw_dmft%nspinor
2622 0 : do im1=1,tndim
2623 0 : iflavor1=im1+tndim*(ispinor1-1)+tndim*(isppol-1)
2624 0 : do ispinor2=1,paw_dmft%nspinor
2625 0 : do im2=1,tndim
2626 0 : iflavor2=im2+tndim*(ispinor2-1)+tndim*(isppol-1)
2627 0 : do itau=1,paw_dmft%dmftqmc_l
2628 : green%oper_tau(itau)%matlu(iatom)%mat(im1+(ispinor1-1)*tndim,im2+(ispinor2-1)*tndim,isppol)=&
2629 0 : & gtmp_nd(itau,iflavor1,iflavor2)
2630 : ! symetrize over spin if nsppol=nspinor=1
2631 0 : if(paw_dmft%nsppol==1.and.paw_dmft%nspinor==1) then
2632 : green%oper_tau(itau)%matlu(iatom)%mat(im1+(ispinor1-1)*tndim,im2+(ispinor2-1)*tndim,isppol)=&
2633 0 : & (gtmp_nd(itau,iflavor1,iflavor2)+gtmp_nd(itau,iflavor1+tndim,iflavor2+tndim))/two
2634 : end if
2635 : end do !itau
2636 0 : if(paw_dmft%dmft_solv<6.or.leg_measure) then
2637 0 : do ifreq=1,paw_dmft%dmft_nwlo
2638 : green%oper(ifreq)%matlu(iatom)%mat(im1+(ispinor1-1)*tndim,im2+(ispinor2-1)*tndim,isppol)=&
2639 0 : & gw_tmp_nd(ifreq,iflavor1,iflavor2)
2640 : ! symetrize over spin if nsppol=nspinor=1
2641 0 : if(paw_dmft%nsppol==1.and.paw_dmft%nspinor==1) then
2642 : green%oper(ifreq)%matlu(iatom)%mat(im1+(ispinor1-1)*tndim,im2+(ispinor2-1)*tndim,isppol)=&
2643 : & (gw_tmp_nd(ifreq,iflavor1,iflavor2)+&
2644 0 : & gw_tmp_nd(ifreq,iflavor1+tndim,iflavor2+tndim))/two
2645 : end if
2646 : end do ! ifreq
2647 : end if
2648 : end do ! im2
2649 : end do ! ispinor2
2650 : end do ! im1
2651 : end do ! ispinor
2652 : end do ! isppol
2653 : != Complex case
2654 34 : elseif(opt_nondiag==1 .and. opt_complex==1) then
2655 0 : do isppol=1,paw_dmft%nsppol
2656 0 : do ispinor1=1,paw_dmft%nspinor
2657 0 : do im1=1,tndim
2658 0 : iflavor1=im1+tndim*(ispinor1-1)+tndim*(isppol-1)
2659 0 : do ispinor2=1,paw_dmft%nspinor
2660 0 : do im2=1,tndim
2661 0 : iflavor2=im2+tndim*(ispinor2-1)+tndim*(isppol-1)
2662 0 : do itau=1,paw_dmft%dmftqmc_l
2663 : green%oper_tau(itau)%matlu(iatom)%mat(im1+(ispinor1-1)*tndim,im2+(ispinor2-1)*tndim,isppol)=&
2664 0 : & gtmp_ndc(itau,iflavor1,iflavor2)
2665 : ! symetrize over spin if nsppol=nspinor=1
2666 0 : if(paw_dmft%nsppol==1.and.paw_dmft%nspinor==1) then
2667 : green%oper_tau(itau)%matlu(iatom)%mat(im1+(ispinor1-1)*tndim,im2+(ispinor2-1)*tndim,isppol)=&
2668 0 : & (gtmp_ndc(itau,iflavor1,iflavor2)+gtmp_ndc(itau,iflavor1+tndim,iflavor2+tndim))/two
2669 : end if
2670 : end do !itau
2671 0 : do ifreq=1,paw_dmft%dmft_nwlo
2672 : green%oper(ifreq)%matlu(iatom)%mat(im1+(ispinor1-1)*tndim,im2+(ispinor2-1)*tndim,isppol)=&
2673 0 : & gw_tmp_nd(ifreq,iflavor1,iflavor2)
2674 : ! symetrize over spin if nsppol=nspinor=1
2675 0 : if(paw_dmft%nsppol==1.and.paw_dmft%nspinor==1) then
2676 : green%oper(ifreq)%matlu(iatom)%mat(im1+(ispinor1-1)*tndim,im2+(ispinor2-1)*tndim,isppol)=&
2677 : & (gw_tmp_nd(ifreq,iflavor1,iflavor2)+&
2678 0 : & gw_tmp_nd(ifreq,iflavor1+tndim,iflavor2+tndim))/two
2679 : end if
2680 : end do ! ifreq
2681 : end do ! im2
2682 : end do ! ispinor2
2683 : end do ! im1
2684 : end do ! ispinor
2685 : end do ! isppol
2686 : else
2687 34 : iflavor=0
2688 88 : do isppol=1,paw_dmft%nsppol
2689 142 : do ispinor=1,paw_dmft%nspinor
2690 378 : do im=1,tndim
2691 270 : iflavor=iflavor+1
2692 72270 : do itau=1,paw_dmft%dmftqmc_l
2693 72000 : green%oper_tau(itau)%matlu(iatom)%mat(im+(ispinor-1)*tndim,im+(ispinor-1)*tndim,isppol)=gtmp(itau,iflavor)
2694 : ! symetrize over spin if nsppol=paw_dmft%nspinor=1
2695 72270 : if(paw_dmft%nsppol==1.and.paw_dmft%nspinor==1) then
2696 : green%oper_tau(itau)%matlu(iatom)%mat(im+(ispinor-1)*tndim,im+(ispinor-1)*tndim,isppol)=&
2697 4900 : & (gtmp(itau,iflavor)+gtmp(itau,iflavor+tndim))/two
2698 : end if
2699 : end do
2700 : ! ifreq2=0
2701 173482 : do ifreq=1,paw_dmft%dmft_nwlo
2702 : ! if(paw_dmft%select_log(ifreq)==1) then
2703 : ! ifreq2=ifreq2+1
2704 173158 : green%oper(ifreq)%matlu(iatom)%mat(im+(ispinor-1)*tndim,im+(ispinor-1)*tndim,isppol)=gw_tmp(ifreq,iflavor)
2705 : ! symetrize over spin if nsppol=paw_dmft%nspinor=1
2706 173428 : if(paw_dmft%nsppol==1.and.paw_dmft%nspinor==1) then
2707 : green%oper(ifreq)%matlu(iatom)%mat(im+(ispinor-1)*tndim,im+(ispinor-1)*tndim,isppol)=&
2708 8820 : & (gw_tmp(ifreq,iflavor)+gw_tmp(ifreq,iflavor+tndim))/two
2709 : end if
2710 : end do
2711 : end do
2712 : end do
2713 : end do
2714 : end if
2715 34 : if(paw_dmft%nsppol==1.and.paw_dmft%nspinor==1) then
2716 14 : write(message,'(a,2x,a,f13.5)') ch10,&
2717 28 : & " == nsppol==1 and nspden==1: Green functions from CTQMC have been symetrized over spin"
2718 14 : call wrtout(std_out,message,'COLL')
2719 : end if
2720 :
2721 34 : end subroutine ctqmcoutput_to_green
2722 : !!***
2723 :
2724 : !!****f* m_forctqmc/ctqmcoutput_printgreen
2725 : !! NAME
2726 : !! ctqmcoutput_printgreen
2727 : !!
2728 : !! FUNCTION
2729 : !! Print values of green function in files.
2730 : !! Symetrize imaginary time Green's function in a peculiar case
2731 : !! (dmft_solv=8 and natom=1). Should be moved later.
2732 : !!
2733 : !! INPUTS
2734 : !! paw_dmft <type(paw_dmft_type)>= DMFT data structure
2735 : !! gtmp_nd(dmftqmc_l,nflavor,nflavor) = Green's fct in imag time (with off diag terms)
2736 : !! gtmp_ndc(dmftqmc_l,nflavor,nflavor) = Complex Green's fct in imag time (with off diag terms)
2737 : !! gw_tmp_nd(nb_of_frequency,nflavor,nflavor) = Green's fct in imag freq (with off diag terms)
2738 : !! gtmp(dmftqmc_l,nflavor) = Green's fct in imag time (diag)
2739 : !! gw_tmp(nb_of_frequency,nflavor+1) =Green's fct in imag freq (diag)
2740 : !! iatom = atoms on which the calculation has been done
2741 : !!
2742 : !! OUTPUT
2743 : !!
2744 : !!
2745 : !! SIDE EFFECTS
2746 : !!
2747 : !! NOTES
2748 : !!
2749 : !! SOURCE
2750 :
2751 34 : subroutine ctqmcoutput_printgreen(paw_dmft,gtmp_nd,gtmp_ndc,gw_tmp_nd,gtmp,gw_tmp,iatom)
2752 :
2753 : !Arguments ------------------------------------
2754 : !scalars
2755 : type(paw_dmft_type), intent(in) :: paw_dmft
2756 : real(dp), allocatable, intent(inout) :: gtmp_nd(:,:,:)
2757 : complex(dpc), allocatable, intent(in) :: gtmp_ndc(:,:,:)
2758 : complex(dpc), allocatable, intent(in) :: gw_tmp(:,:)
2759 : complex(dpc), allocatable, intent(in) :: gw_tmp_nd(:,:,:)
2760 : real(dp), allocatable, intent(in) :: gtmp(:,:)
2761 : integer, intent(in) :: iatom
2762 :
2763 : !Local variables ------------------------------
2764 : character(len=500) :: message
2765 : integer :: ifreq, itau,iflavor1
2766 : integer :: tndim,iflavor,nflavor
2767 : character(len=2) :: gtau_iter,iatomnb
2768 : integer :: unt
2769 : ! ************************************************************************
2770 34 : tndim=2*paw_dmft%lpawu(iatom)+1
2771 34 : nflavor=2*(tndim)
2772 : !----------------------------------------
2773 : ! <DEBUG>
2774 : !----------------------------------------
2775 : ! Construct UNIT
2776 34 : if(paw_dmft%idmftloop < 10) then
2777 34 : write(gtau_iter,'("0",i1)') paw_dmft%idmftloop
2778 0 : elseif(paw_dmft%idmftloop >= 10 .and. paw_dmft%idmftloop < 100) then
2779 0 : write(gtau_iter,'(i2)') paw_dmft%idmftloop
2780 : else
2781 0 : gtau_iter="xx"
2782 : end if
2783 34 : if(iatom < 10) then
2784 34 : write(iatomnb,'("0",i1)') iatom
2785 0 : elseif(iatom >= 10 .and. iatom < 100) then
2786 0 : write(iatomnb,'(i2)') iatom
2787 : else
2788 0 : iatomnb='xx'
2789 : end if
2790 :
2791 34 : if(paw_dmft%myproc .eq. mod(paw_dmft%nproc+1,paw_dmft%nproc)) then
2792 : ! < HACK >
2793 19 : if(paw_dmft%dmft_solv==6.or.paw_dmft%dmft_solv==7) then
2794 0 : if (open_file(trim(paw_dmft%filapp)//"_atom_"//iatomnb//"_Gw_"//gtau_iter//".dat", message, newunit=unt) /=0) then
2795 0 : ABI_ERROR(message)
2796 : end if
2797 0 : do ifreq=1,paw_dmft%dmft_nwli
2798 0 : write(unt,'(29f21.14)') paw_dmft%omega_lo(ifreq),((gw_tmp_nd(ifreq,iflavor,iflavor)), iflavor=1, nflavor)
2799 : end do
2800 0 : close(unt)
2801 : else
2802 19 : if(paw_dmft%dmft_solv==5) then
2803 19 : if (open_file(trim(paw_dmft%filapp)//"_atom_"//iatomnb//"_Gtau_"//gtau_iter//".dat", message, newunit=unt) /= 0) then
2804 0 : ABI_ERROR(message)
2805 : end if
2806 2769 : do itau=1,paw_dmft%dmftqmc_l
2807 2750 : write(unt,'(29f21.14)') float(itau-1)/float(paw_dmft%dmftqmc_l)/paw_dmft%temp,&
2808 5519 : (gtmp(itau,iflavor), iflavor=1, nflavor)
2809 : end do
2810 213 : write(unt,'(29f21.14)') 1/paw_dmft%temp, (-1_dp-gtmp(1,iflavor), iflavor=1, nflavor)
2811 19 : close(unt)
2812 : endif
2813 : ! if(paw_dmft%dmft_solv==8 ) then
2814 : ! if (open_file(trim(paw_dmft%filapp)//"_atom_"//iatomnb//"_Gtau_offdiag_unsym_"//gtau_iter//".dat",&
2815 : !& message, newunit=unt) /= 0) then
2816 : ! ABI_ERROR(message)
2817 : ! end if
2818 : ! do itau=1,paw_dmft%dmftqmc_l
2819 : ! write(unt,'(196f21.14)') float(itau-1)/float(paw_dmft%dmftqmc_l)/paw_dmft%temp,&
2820 : ! ((gtmp_nd(itau,iflavor,iflavor1), iflavor=1, nflavor),iflavor1=1, nflavor)
2821 : ! end do
2822 : ! close(unt)
2823 : ! endif
2824 19 : if(paw_dmft%dmft_solv .eq. 8) then
2825 0 : if (open_file(trim(paw_dmft%filapp)//"_atom_"//iatomnb//"_Gtau_diag_CTQMC_"//gtau_iter//".dat",&
2826 : & message, newunit=unt) /= 0) then
2827 0 : ABI_ERROR(message)
2828 : end if
2829 0 : do itau=1,paw_dmft%dmftqmc_l
2830 0 : write(unt,'(196f21.14)') float(itau-1)/float(paw_dmft%dmftqmc_l)/paw_dmft%temp,&
2831 0 : & (gtmp_nd(itau,iflavor,iflavor), iflavor=1,nflavor)
2832 : end do
2833 0 : close(unt)
2834 0 : if (open_file(trim(paw_dmft%filapp)//"_atom_"//iatomnb//"_Gtau_full_CTQMC_"//gtau_iter//".dat",&
2835 : & message, newunit=unt) /= 0) then
2836 0 : ABI_ERROR(message)
2837 : end if
2838 0 : do itau=1, paw_dmft%dmftqmc_l
2839 0 : write(unt,'(392f21.14)') float(itau-1)/float(paw_dmft%dmftqmc_l)/paw_dmft%temp,&
2840 0 : & ((gtmp_nd(itau,iflavor,iflavor1),iflavor=1,nflavor), iflavor1=1, nflavor)
2841 : end do
2842 0 : close(unt)
2843 : endif
2844 : !complex solver
2845 19 : if(paw_dmft%dmft_solv .eq. 10) then
2846 0 : if (open_file(trim(paw_dmft%filapp)//"_atom_"//iatomnb//"_Gtau_diag_CTQMC_"//gtau_iter//".dat",&
2847 : & message, newunit=unt) /= 0) then
2848 0 : ABI_ERROR(message)
2849 : end if
2850 0 : do itau=1,paw_dmft%dmftqmc_l
2851 0 : write(unt,'(196f21.14)') float(itau-1)/float(paw_dmft%dmftqmc_l)/paw_dmft%temp,&
2852 0 : & (gtmp_ndc(itau,iflavor,iflavor), iflavor=1,nflavor)
2853 : end do
2854 0 : close(unt)
2855 0 : if (open_file(trim(paw_dmft%filapp)//"_atom_"//iatomnb//"_Gtau_full_CTQMC_"//gtau_iter//".dat",&
2856 : & message, newunit=unt) /= 0) then
2857 0 : ABI_ERROR(message)
2858 : end if
2859 0 : do itau=1, paw_dmft%dmftqmc_l
2860 0 : write(unt,'(2x,393(e18.10e3,2x))') float(itau-1)/float(paw_dmft%dmftqmc_l)/paw_dmft%temp,&
2861 0 : & ((dble(gtmp_ndc(itau,iflavor,iflavor1)),aimag(gtmp_ndc(itau,iflavor,iflavor1)),iflavor=1,nflavor), iflavor1=1, nflavor)
2862 : end do
2863 0 : close(unt)
2864 : endif
2865 : ! if(paw_dmft%natom==1) then ! If natom>1, it should be moved outside the loop over atoms
2866 : ! ABI_MALLOC(matlu1,(paw_dmft%natom))
2867 : ! call init_matlu(paw_dmft%natom,paw_dmft%nspinor,paw_dmft%nsppol,paw_dmft%lpawu,matlu1)
2868 : ! do itau=1,paw_dmft%dmftqmc_l
2869 : ! do isppol=1,paw_dmft%nsppol
2870 : ! do ispinor1=1,paw_dmft%nspinor
2871 : ! do im1=1,tndim
2872 : ! iflavor1=im1+tndim*(ispinor1-1)+tndim*(isppol-1)
2873 : ! do ispinor2=1,paw_dmft%nspinor
2874 : ! do im2=1,tndim
2875 : ! iflavor2=im2+tndim*(ispinor2-1)+tndim*(isppol-1)
2876 : ! matlu1(iatom)%mat(im1,im2,isppol,ispinor1,ispinor2)=&
2877 : !& gtmp_nd(itau,iflavor1,iflavor2)
2878 : ! end do ! im2
2879 : ! end do ! ispinor2
2880 : ! end do ! im1
2881 : ! end do ! ispinor
2882 : ! end do ! isppol
2883 : ! call rotate_matlu(matlu1,eigvectmatlu,paw_dmft%natom,3,0)
2884 : ! call slm2ylm_matlu(matlu1,paw_dmft%natom,2,0)
2885 : ! call sym_matlu(cryst_struc,matlu1,pawang,paw_dmft)
2886 : ! call slm2ylm_matlu(matlu1,paw_dmft%natom,1,0)
2887 : ! call rotate_matlu(matlu1,eigvectmatlu,paw_dmft%natom,3,1)
2888 : ! do isppol=1,paw_dmft%nsppol
2889 : ! do ispinor1=1,paw_dmft%nspinor
2890 : ! do im1=1,tndim
2891 : ! iflavor1=im1+tndim*(ispinor1-1)+tndim*(isppol-1)
2892 : ! do ispinor2=1,paw_dmft%nspinor
2893 : ! do im2=1,tndim
2894 : ! iflavor2=im2+tndim*(ispinor2-1)+tndim*(isppol-1)
2895 : ! gtmp_nd(itau,iflavor1,iflavor2)=&
2896 : ! matlu1(iatom)%mat(im1,im2,isppol,ispinor1,ispinor2)
2897 : ! end do ! im2
2898 : ! end do ! ispinor2
2899 : ! end do ! im1
2900 : ! end do ! ispinor
2901 : ! end do ! isppol
2902 : ! end do !itau
2903 : ! call destroy_matlu(matlu1,paw_dmft%natom)
2904 : ! ABI_FREE(matlu1)
2905 : ! endif ! if natom=1
2906 : ! if (open_file(trim(paw_dmft%filapp)//"_atom_"//iatomnb//"_Gtau_offdiag_"//gtau_iter//".dat",&
2907 : !& message, newunit=unt) /= 0) then
2908 : ! ABI_ERROR(message)
2909 : ! end if
2910 : ! do itau=1,paw_dmft%dmftqmc_l
2911 : ! write(unt,'(196f21.14)') float(itau-1)/float(paw_dmft%dmftqmc_l)/paw_dmft%temp,&
2912 : ! ((gtmp_nd(itau,iflavor,iflavor1), iflavor=1, nflavor),iflavor1=1, nflavor)
2913 : ! end do
2914 : ! close(unt)
2915 : ! endif
2916 : !open(unit=4243, file=trim(paw_dmft%filapp)//"_atom_"//iatomnb//"_F_"//gtau_iter//".dat")
2917 : !call BathOperator_printF(paw_dmft%hybrid(iatom)%hybrid%bath,4243) !Already comment here
2918 : !close(4243)
2919 19 : if(paw_dmft%dmft_solv==5) then
2920 19 : if (open_file(trim(paw_dmft%filapp)//"_atom_"//iatomnb//"_Gw_"//gtau_iter//".dat", message, newunit=unt) /= 0) then
2921 0 : ABI_ERROR(message)
2922 : end if
2923 6275 : do ifreq=1,paw_dmft%dmft_nwlo
2924 6256 : write(unt,'(29f21.14)') paw_dmft%omega_lo(ifreq), &
2925 12531 : & (gw_tmp(ifreq,iflavor), iflavor=1, nflavor)
2926 : end do
2927 : endif
2928 19 : close(unt)
2929 :
2930 19 : if(paw_dmft%dmft_solv==8 .or. paw_dmft%dmft_solv==10) then
2931 0 : if (open_file(trim(paw_dmft%filapp)//"_atom_"//iatomnb//"_Gw_diag_"//gtau_iter//".dat", message, newunit=unt) /= 0) then
2932 0 : ABI_ERROR(message)
2933 : end if
2934 0 : do ifreq=1,paw_dmft%dmft_nwlo
2935 0 : write(unt,'(29f21.14)') paw_dmft%omega_lo(ifreq), &
2936 0 : & (gw_tmp_nd(ifreq,iflavor,iflavor), iflavor=1, nflavor)
2937 : end do
2938 : endif
2939 19 : close(unt)
2940 :
2941 19 : if(paw_dmft%dmft_solv==8 .or. paw_dmft%dmft_solv==10) then
2942 0 : if (open_file(trim(paw_dmft%filapp)//"_atom_"//iatomnb//"_Gw_Offdiag_"//gtau_iter//".dat", message, newunit=unt) /= 0) then
2943 0 : ABI_ERROR(message)
2944 : end if
2945 0 : do ifreq=1,paw_dmft%dmft_nwlo
2946 0 : write(unt,'(296f21.14)') paw_dmft%omega_lo(ifreq), &
2947 0 : & ((gw_tmp_nd(ifreq,iflavor,iflavor1), iflavor=iflavor1, nflavor),iflavor1=1, nflavor)
2948 : end do
2949 : endif
2950 19 : close(unt)
2951 :
2952 : end if
2953 : ! </ HACK >
2954 : end if
2955 :
2956 :
2957 34 : end subroutine ctqmcoutput_printgreen
2958 : !!***
2959 :
2960 : !!****f* m_forctqmc/ctqmc_calltriqs
2961 : !! NAME
2962 : !! ctqmc_calltriqs
2963 : !!
2964 : !! FUNCTION
2965 : !! Call TRIQS solver and perform calculation of Green's function using
2966 : !! Legendre coefficients.
2967 : !!
2968 : !! INPUTS
2969 : !! paw_dmft <type(paw_dmft_type)>= DMFT data structure
2970 : !! cryst_struc <type(crystal_t)>=crystal structure data
2971 : !! hu <type(hu_type)>= U interaction
2972 : !! levels_ctqmc(nflavor) = atomic levels
2973 : !! gw_tmp_nd(nb_of_frequency,nflavor,nflavor) = Green's fct in imag freq (with off diag terms)
2974 : !! gtmp_nd(dmftqmc_l,nflavor,nflavor) = Green's fct in imag time (with off diag terms)
2975 : !! fw1_nd(dmft_nwlo,nflavor,nflavor) = Hybridization fct in imag time (with off diag terms)
2976 : !! leg_measure = logical, true is legendre measurement is activated
2977 : !! iatom= index of atom
2978 : !!
2979 : !! OUTPUT
2980 : !!
2981 : !!
2982 : !! SIDE EFFECTS
2983 : !!
2984 : !! NOTES
2985 : !!
2986 : !! SOURCE
2987 :
2988 0 : subroutine ctqmc_calltriqs(paw_dmft,cryst_struc,hu,levels_ctqmc,gtmp_nd,gw_tmp_nd,fw1_nd,leg_measure,iatom)
2989 :
2990 : #if defined HAVE_TRIQS_v3_2 || defined HAVE_TRIQS_v2_0 || defined HAVE_TRIQS_v1_4
2991 : use TRIQS_CTQMC !Triqs module
2992 : #endif
2993 : #if defined HAVE_PYTHON_INVOCATION
2994 : use m_invoke_python
2995 : #endif
2996 : use, intrinsic :: iso_c_binding
2997 :
2998 : !Arguments ------------------------------------
2999 : !scalars
3000 : type(paw_dmft_type), intent(in) :: paw_dmft
3001 : type(crystal_t),intent(in) :: cryst_struc
3002 : type(hu_type), intent(in) :: hu(cryst_struc%ntypat)
3003 : real(dp), allocatable, target, intent(inout) :: gtmp_nd(:,:,:)
3004 : complex(dp), allocatable, target, intent(inout) :: gw_tmp_nd(:,:,:)
3005 : complex(dp), allocatable, target, intent(in) :: fw1_nd(:,:,:)
3006 : real(dp), allocatable, target, intent(inout) :: levels_ctqmc(:)
3007 : logical(kind=1), intent(in) :: leg_measure
3008 : integer, intent(in) :: iatom
3009 :
3010 : !Local variables ------------------------------
3011 0 : complex(dp), allocatable, target ::fw1_nd_tmp(:,:,:)
3012 0 : complex(dp), allocatable, target :: g_iw(:,:,:)
3013 0 : real(dp), allocatable, target :: u_mat_ij(:,:)
3014 0 : real(dp), allocatable, target :: u_mat_ijkl(:,:,:,:)
3015 0 : real(dp), allocatable, target :: u_mat_ijkl_tmp(:,:,:,:)
3016 0 : real(dp), allocatable, target :: gl_nd(:,:,:)
3017 : type(c_ptr) :: levels_ptr, fw1_nd_ptr, u_mat_ij_ptr, u_mat_ijkl_ptr, g_iw_ptr, gtau_ptr, gl_ptr
3018 0 : real(dp), allocatable :: jbes(:)
3019 : character(len=500) :: message
3020 : integer :: ifreq, iflavor1
3021 : integer :: iflavor2,iflavor,nflavor,iflavor3,itypat
3022 : integer :: nfreq,ntau,nleg,ileg
3023 : integer :: verbosity_solver ! min 0 -> max 3
3024 : logical(kind=1) :: rot_inv = .false.
3025 : #if defined HAVE_TRIQS_v2_0 || defined HAVE_TRIQS_v1_4 || defined HAVE_PYTHON_INVOCATION
3026 : logical(kind=1) :: hist = .false.
3027 : logical(kind=1) :: wrt_files = .true.
3028 : logical(kind=1) :: tot_not = .true.
3029 : #endif
3030 : real(dp) :: beta,besp,bespp,xx
3031 : complex(dp) :: u_nl
3032 :
3033 : #if defined HAVE_PYTHON_INVOCATION
3034 : !----------
3035 : !Variables for writing out the NETCDF file when calling PYTHON_INVOCATION
3036 : !----------
3037 : integer(kind=4) :: ncid
3038 : integer(kind=4) :: dim_one_id, dim_nflavor_id, dim_nwlo_id, dim_nwli_id
3039 : integer(kind=4) :: dim_qmc_l_id, dim_nleg_id
3040 : integer(kind=4), dimension(2) :: dim_u_mat_ij_id
3041 : integer(kind=4), dimension(3) :: dim_fw1_id, dim_g_iw_id, dim_gl_id, dim_gtau_id
3042 : integer(kind=4), dimension(4) :: dim_u_mat_ijkl_id
3043 : integer(kind=4) :: var_rot_inv_id, var_leg_measure_id, var_hist_id, var_wrt_files_id
3044 : integer(kind=4) :: var_tot_not_id, var_n_orbitals_id, var_n_freq_id, var_n_tau_id, var_n_l_id, var_n_cycles_id
3045 : integer(kind=4) :: var_cycle_length_id, var_ntherm_id, var_verbo_id, var_seed_id, var_beta_id
3046 : integer(kind=4) :: var_levels_id, var_u_mat_ij_id, var_u_mat_ijkl_id, var_real_fw1_nd_id, var_imag_fw1_nd_id
3047 : integer(kind=4) :: var_real_g_iw_id, var_imag_g_iw_id, var_gtau_id, var_gl_id, var_spacecomm_id
3048 :
3049 : integer :: itau
3050 :
3051 : integer(kind=4) :: varid
3052 : logical :: file_exists
3053 : complex :: i
3054 : character(len=100) :: filename
3055 :
3056 : real(dp), allocatable, target :: new_re_g_iw(:,:,:), new_im_g_iw(:,:,:)
3057 : real(dp), allocatable, target :: new_g_tau(:,:,:), new_gl(:,:,:)
3058 : !----------
3059 : #endif
3060 : ! ************************************************************************
3061 :
3062 : ! fw1_nd: Hybridation
3063 : ! levels_ctqmc: niveaux
3064 : ! hu(itypat)%udens(:,:) : U_ij
3065 : ! hu(itypat)%u(:,:,:,:) : uijkl
3066 : ! temperature : paw_dmft%temp
3067 : ! paw_dmft%dmftqmc_l: nombre de points en temps -1
3068 : ! paw_dmft%dmftqmc_n: nombre de cycles
3069 : ! ?? Quelles sorties: Les fonctions de Green
3070 : ! frequence/temps/Legendre.
3071 : ! Double occupations ?? <n_i n_j>
3072 : ! test n_tau > 2*nfreq => ntau = 2*nfreq + 1
3073 : ! for non diagonal code:
3074 : ! call CtqmcInterface_run(hybrid,fw1_nd(1:paw_dmft%dmftqmc_l,:,:),Gtau=gtmp_nd,&
3075 : !& Gw=gw_tmp_nd,D=Doccsum,E=green%ecorr_qmc(iatom),&
3076 : !& Noise=Noise,matU=hu(itypat)%udens,opt_levels=levels_ctqmc,hybri_limit=hybri_limit)
3077 : !Check choice of user to fix model bool var for the solver
3078 0 : if (paw_dmft%dmft_solv==6) then
3079 0 : rot_inv = .false.
3080 : else !obviously paw_dmft%dmft_solv==7 with rot invariant terms
3081 0 : rot_inv = .true.
3082 : end if
3083 :
3084 0 : nfreq = paw_dmft%dmft_nwli
3085 : !paw_dmft%dmft_nwlo = paw_dmft%dmft_nwli !transparent for user
3086 0 : ntau = paw_dmft%dmftqmc_l !(2*paw_dmft%dmftqmc_l)+1 !nfreq=paw_dmft%dmft_nwli
3087 0 : nleg = paw_dmft%dmft_triqs_nleg
3088 0 : nflavor=2*(2*paw_dmft%lpawu(iatom)+1)
3089 0 : itypat=cryst_struc%typat(iatom)
3090 :
3091 :
3092 0 : verbosity_solver = paw_dmft%prtvol
3093 0 : beta = 1.0/(paw_dmft%temp*Ha_eV)
3094 :
3095 : !Allocation in/output array phase:
3096 0 : ABI_MALLOC(fw1_nd_tmp,(1:nflavor,1:nflavor,1:nfreq)) !column major
3097 0 : ABI_MALLOC(g_iw,(1:nflavor,1:nflavor,1:nfreq)) !column major
3098 0 : ABI_MALLOC(u_mat_ij,(1:nflavor,1:nflavor)) !column major
3099 0 : ABI_MALLOC(u_mat_ijkl,(1:nflavor,1:nflavor,1:nflavor,1:nflavor)) !column major
3100 0 : ABI_MALLOC(u_mat_ijkl_tmp,(1:nflavor,1:nflavor,1:nflavor,1:nflavor)) !column major
3101 :
3102 0 : if ( leg_measure ) then !only if functionality is enabled
3103 0 : ABI_MALLOC(gl_nd,(1:nleg,1:nflavor,1:nflavor)) !column major !nl = 30 by default
3104 : end if
3105 :
3106 : !Conversion datas Ha -> eV (some duplications for test...)
3107 : !fw1_nd_tmp = fw1_nd(1:paw_dmft%dmftqmc_l,:,:) * Ha_eV !fw1_nd = fw1_nd * Ha_eV !Ok?
3108 :
3109 0 : do iflavor=1,nflavor
3110 0 : do iflavor1=1,nflavor
3111 0 : do ifreq=1,nfreq
3112 0 : fw1_nd_tmp(iflavor,iflavor1,ifreq) = fw1_nd(ifreq,iflavor,iflavor1) * Ha_eV
3113 : ! WRITE(500,*) "[IN Fortran] F[ w= ",ifreq," l= ",iflavor," l_= ",iflavor1,"] = ",fw1_nd(ifreq,iflavor,iflavor1)
3114 : end do
3115 : end do
3116 : end do
3117 :
3118 : !Report test
3119 : ! WRITE(502,*) hu(itypat)%udens
3120 : ! do ifreq=1,paw_dmft%dmftqmc_l
3121 : ! write(501,*) ((fw1_nd(ifreq,iflavor,iflavor1),iflavor=1,nflavor),iflavor1=1,nflavor)
3122 : ! enddo
3123 : !write(866,*)paw_dmft%dmft_nwlo,paw_dmft%dmftqmc_l
3124 : !write(866,*) u_mat_ij
3125 : ! do iflavor=1,nflavor+1
3126 : ! do iflavor1=1,nflavor+1
3127 : ! WRITE(502,*) "[OUT Fortran] U(i,j)[ l= ",iflavor," l_= ",iflavor1,"] = ",hu(itypat)%udens(iflavor,iflavor1)
3128 : ! enddo
3129 : ! enddo
3130 :
3131 : ! if(paw_dmft%myproc==0) then
3132 : ! do iflavor=1,nflavor
3133 : ! do iflavor1=1,nflavor
3134 : ! do iflavor2=1,nflavor
3135 : ! do iflavor3=1,nflavor
3136 : ! write(490,*), hu(itypat)%vee(iflavor,iflavor1,iflavor2,iflavor3)
3137 : ! enddo
3138 : ! enddo
3139 : ! enddo
3140 : ! enddo
3141 : ! endif
3142 :
3143 : ! if(paw_dmft%myproc==0) then
3144 : ! do iflavor=1,nflavor
3145 : ! do iflavor1=1,nflavor
3146 : ! write(491,*), hu(itypat)%udens(iflavor,iflavor1) !(1,1,1,1)
3147 : ! enddo
3148 : ! enddo
3149 : ! endif
3150 :
3151 : ! do iflavor=1,nflavor
3152 : ! do iflavor1=1,nflavor
3153 : ! do iflavor2=1,nflavor
3154 : ! do iflavor3=1,nflavor
3155 : ! WRITE(552,*), hu(itypat)%vee!(iflavor,iflavor1,iflavor2,iflavor3)
3156 : ! enddo
3157 : ! enddo
3158 : ! enddo
3159 : ! enddo
3160 :
3161 0 : call vee_ndim2tndim_hu_r(paw_dmft%lpawu(iatom),dble(hu(itypat)%vee),u_mat_ijkl_tmp,1)
3162 0 : do iflavor=1,nflavor
3163 0 : do iflavor1=1,nflavor
3164 0 : do iflavor2=1,nflavor
3165 0 : do iflavor3=1,nflavor
3166 0 : u_mat_ijkl(iflavor,iflavor1,iflavor2,iflavor3) = Ha_eV * u_mat_ijkl_tmp(iflavor,iflavor1,iflavor2,iflavor3)
3167 : end do
3168 : end do
3169 : end do
3170 : end do
3171 :
3172 : !u_mat_ijkl = Ha_eV * reshape( u_mat_ijkl , [nflavor,nflavor,nflavor,nflavor] ) !column -> row major + conversion
3173 0 : u_mat_ij = transpose( dble(hu(itypat)%udens) ) * Ha_eV !column -> row major + conversion
3174 0 : levels_ctqmc = levels_ctqmc * Ha_eV
3175 :
3176 : !Location array in memory for C++ pointer args to pass
3177 : !----------------------------------------------------
3178 0 : g_iw_ptr = C_LOC( gw_tmp_nd ) !C_LOC( g_iw )
3179 0 : gtau_ptr = C_LOC( gtmp_nd ) !C_LOC( gtau )
3180 0 : gl_ptr = C_LOC( gl_nd )
3181 0 : fw1_nd_ptr = C_LOC( fw1_nd_tmp )
3182 0 : u_mat_ij_ptr = C_LOC( u_mat_ij )
3183 0 : u_mat_ijkl_ptr = C_LOC( u_mat_ijkl )
3184 0 : levels_ptr = C_LOC( levels_ctqmc )
3185 :
3186 : !Calling interfaced TRIQS solver subroutine from src/67_triqs_ext package
3187 0 : if (paw_dmft%dmft_solv==9) then
3188 : #ifndef HAVE_PYTHON_INVOCATION
3189 0 : write(message,'(23a)') ch10,' Python invocation flag requiered! You need to install ABINIT with ',&
3190 0 : 'enable_python_invocation = yes" in your "configure.ac" file.'
3191 0 : call wrtout(std_out,message,'COLL')
3192 0 : ABI_ERROR(message)
3193 : #else
3194 : ! Creating the NETCDF file
3195 : ! write(std_out, "(a)") trim(paw_dmft%filapp)
3196 : write(filename, '(a, a)') trim(paw_dmft%filnamei), "_abinit_output_for_py.nc"
3197 : write(std_out, '(3a)') ch10, " Creating NETCDF file: ", trim(filename)
3198 : NCF_CHECK(nf90_create(filename, NF90_CLOBBER, ncid))
3199 :
3200 : ! Defining the dimensions of the variables to write in the NETCDF file
3201 : NCF_CHECK(nf90_def_dim(ncid, "one", 1, dim_one_id))
3202 : NCF_CHECK(nf90_def_dim(ncid, "nflavor", nflavor, dim_nflavor_id))
3203 : NCF_CHECK(nf90_def_dim(ncid, "nwlo", paw_dmft%dmft_nwlo, dim_nwlo_id))
3204 : NCF_CHECK(nf90_def_dim(ncid, "nwli", paw_dmft%dmft_nwli, dim_nwli_id))
3205 : NCF_CHECK(nf90_def_dim(ncid, "qmc_l", paw_dmft%dmftqmc_l, dim_qmc_l_id))
3206 : NCF_CHECK(nf90_def_dim(ncid, "nleg", nleg, dim_nleg_id))
3207 :
3208 : dim_u_mat_ij_id = (/ dim_nflavor_id, dim_nflavor_id /)
3209 : dim_u_mat_ijkl_id = (/ dim_nflavor_id, dim_nflavor_id, dim_nflavor_id, dim_nflavor_id /)
3210 : dim_fw1_id = (/ dim_nflavor_id, dim_nflavor_id, dim_nwli_id /)
3211 : dim_g_iw_id = (/ dim_nwli_id, dim_nflavor_id, dim_nflavor_id /)
3212 : dim_gtau_id = (/ dim_qmc_l_id, dim_nflavor_id, dim_nflavor_id /)
3213 : dim_gl_id = (/ dim_nleg_id, dim_nflavor_id, dim_nflavor_id /)
3214 :
3215 : ! Defining the variables
3216 : NCF_CHECK(nf90_def_var(ncid, "rot_inv", NF90_INT, dim_one_id, var_rot_inv_id))
3217 : NCF_CHECK(nf90_def_var(ncid, "leg_measure", NF90_INT, dim_one_id, var_leg_measure_id))
3218 : NCF_CHECK(nf90_def_var(ncid, "hist", NF90_INT, dim_one_id, var_hist_id))
3219 : NCF_CHECK(nf90_def_var(ncid, "wrt_files", NF90_INT, dim_one_id, var_wrt_files_id))
3220 : NCF_CHECK(nf90_def_var(ncid, "tot_not", NF90_INT, dim_one_id, var_tot_not_id))
3221 : NCF_CHECK(nf90_def_var(ncid, "n_orbitals", NF90_INT, dim_one_id, var_n_orbitals_id))
3222 : NCF_CHECK(nf90_def_var(ncid, "n_freq", NF90_INT, dim_one_id, var_n_freq_id))
3223 : NCF_CHECK(nf90_def_var(ncid, "n_tau", NF90_INT, dim_one_id, var_n_tau_id))
3224 : NCF_CHECK(nf90_def_var(ncid, "n_l", NF90_INT, dim_one_id, var_n_l_id))
3225 : NCF_CHECK(nf90_def_var(ncid, "n_cycles", NF90_INT, dim_one_id, var_n_cycles_id))
3226 : NCF_CHECK(nf90_def_var(ncid, "cycle_length", NF90_INT, dim_one_id, var_cycle_length_id))
3227 : NCF_CHECK(nf90_def_var(ncid, "ntherm", NF90_INT, dim_one_id, var_ntherm_id))
3228 : NCF_CHECK(nf90_def_var(ncid, "verbo", NF90_INT, dim_one_id, var_verbo_id))
3229 : NCF_CHECK(nf90_def_var(ncid, "seed", NF90_INT, dim_one_id, var_seed_id))
3230 : NCF_CHECK(nf90_def_var(ncid, "beta", NF90_FLOAT, dim_one_id, var_beta_id))
3231 : NCF_CHECK(nf90_def_var(ncid, "levels", NF90_DOUBLE, dim_nflavor_id, var_levels_id))
3232 : NCF_CHECK(nf90_def_var(ncid, "u_mat_ij", NF90_DOUBLE, dim_u_mat_ij_id, var_u_mat_ij_id))
3233 : NCF_CHECK(nf90_def_var(ncid, "u_mat_ijkl", NF90_DOUBLE, dim_u_mat_ijkl_id, var_u_mat_ijkl_id))
3234 : NCF_CHECK(nf90_def_var(ncid, "real_fw1_nd", NF90_DOUBLE, dim_fw1_id, var_real_fw1_nd_id))
3235 : NCF_CHECK(nf90_def_var(ncid, "imag_fw1_nd", NF90_DOUBLE, dim_fw1_id, var_imag_fw1_nd_id))
3236 : NCF_CHECK(nf90_def_var(ncid, "real_g_iw", NF90_DOUBLE, dim_g_iw_id, var_real_g_iw_id))
3237 : NCF_CHECK(nf90_def_var(ncid, "imag_g_iw", NF90_DOUBLE, dim_g_iw_id, var_imag_g_iw_id))
3238 : NCF_CHECK(nf90_def_var(ncid, "gtau", NF90_DOUBLE, dim_gtau_id, var_gtau_id))
3239 : NCF_CHECK(nf90_def_var(ncid, "gl", NF90_DOUBLE, dim_gl_id, var_gl_id))
3240 : NCF_CHECK(nf90_def_var(ncid, "spacecomm", NF90_INT, dim_one_id, var_spacecomm_id))
3241 : NCF_CHECK(nf90_enddef(ncid))
3242 :
3243 : ! Filling the variables with actual data
3244 : if (rot_inv) then
3245 : NCF_CHECK(nf90_put_var(ncid, var_rot_inv_id, 1))
3246 : else
3247 : NCF_CHECK(nf90_put_var(ncid, var_rot_inv_id, 0))
3248 : end if
3249 : if (leg_measure) then
3250 : NCF_CHECK(nf90_put_var(ncid, var_leg_measure_id, 1))
3251 : else
3252 : NCF_CHECK(nf90_put_var(ncid, var_leg_measure_id, 0))
3253 : end if
3254 : if (hist) then
3255 : NCF_CHECK(nf90_put_var(ncid, var_hist_id, 1))
3256 : else
3257 : NCF_CHECK(nf90_put_var(ncid, var_hist_id, 0))
3258 : end if
3259 : if (wrt_files) then
3260 : NCF_CHECK(nf90_put_var(ncid, var_wrt_files_id, 1))
3261 : else
3262 : NCF_CHECK(nf90_put_var(ncid, var_wrt_files_id, 0))
3263 : end if
3264 : if (tot_not) then
3265 : NCF_CHECK(nf90_put_var(ncid, var_tot_not_id, 1))
3266 : else
3267 : NCF_CHECK(nf90_put_var(ncid, var_tot_not_id, 0))
3268 : end if
3269 : NCF_CHECK(nf90_put_var(ncid, var_n_orbitals_id, nflavor))
3270 : NCF_CHECK(nf90_put_var(ncid, var_n_freq_id, nfreq))
3271 : NCF_CHECK(nf90_put_var(ncid, var_n_tau_id, ntau))
3272 : NCF_CHECK(nf90_put_var(ncid, var_n_l_id, nleg))
3273 : NCF_CHECK(nf90_put_var(ncid, var_n_cycles_id, int(paw_dmft%dmftqmc_n/paw_dmft%nproc)))
3274 : NCF_CHECK(nf90_put_var(ncid, var_cycle_length_id, paw_dmft%dmftctqmc_meas*2*2*nflavor))
3275 : NCF_CHECK(nf90_put_var(ncid, var_ntherm_id, paw_dmft%dmftqmc_therm))
3276 : NCF_CHECK(nf90_put_var(ncid, var_verbo_id, verbosity_solver))
3277 : NCF_CHECK(nf90_put_var(ncid, var_seed_id, paw_dmft%dmftqmc_seed))
3278 : NCF_CHECK(nf90_put_var(ncid, var_beta_id, beta))
3279 : NCF_CHECK(nf90_put_var(ncid, var_levels_id, levels_ctqmc))
3280 : NCF_CHECK(nf90_put_var(ncid, var_u_mat_ij_id, u_mat_ij))
3281 : NCF_CHECK(nf90_put_var(ncid, var_u_mat_ijkl_id, u_mat_ijkl))
3282 : NCF_CHECK(nf90_put_var(ncid, var_real_fw1_nd_id, real(fw1_nd_tmp)))
3283 : NCF_CHECK(nf90_put_var(ncid, var_imag_fw1_nd_id, aimag(fw1_nd_tmp)))
3284 : NCF_CHECK(nf90_put_var(ncid, var_real_g_iw_id, real(gw_tmp_nd)))
3285 : NCF_CHECK(nf90_put_var(ncid, var_imag_g_iw_id, aimag(gw_tmp_nd)))
3286 : NCF_CHECK(nf90_put_var(ncid, var_gtau_id, gtmp_nd))
3287 : NCF_CHECK(nf90_put_var(ncid, var_gl_id, gl_nd))
3288 : NCF_CHECK(nf90_put_var(ncid, var_spacecomm_id, paw_dmft%spacecomm))
3289 : NCF_CHECK(nf90_close(ncid))
3290 :
3291 : write(std_out, '(4a)') ch10, " NETCDF file ", trim(filename), " written; Launching python invocation"
3292 :
3293 : ! Invoking python to execute the script
3294 : call invoke_python_run_script (0, paw_dmft%myproc, trim(paw_dmft%filnamei), paw_dmft%spacecomm)
3295 : ! call Invoke_python_triqs (paw_dmft%myproc, trim(paw_dmft%filnamei)//c_null_char)
3296 : call xmpi_barrier(paw_dmft%spacecomm)
3297 : call flush_unit(std_out)
3298 :
3299 : ! Allocating the fortran variables for the results
3300 : ABI_MALLOC(new_re_g_iw,(nflavor,nflavor, paw_dmft%dmft_nwli))
3301 : ABI_MALLOC(new_im_g_iw,(nflavor,nflavor, paw_dmft%dmft_nwli))
3302 : ABI_MALLOC(new_g_tau,(nflavor,nflavor, paw_dmft%dmftqmc_l))
3303 : ABI_MALLOC(new_gl,(nflavor,nflavor, nleg))
3304 : i = (0, 1)
3305 :
3306 : ! Check if file exists
3307 : write(filename, '(a, a)') trim(paw_dmft%filnamei), "_py_output_for_abinit.nc"
3308 :
3309 : INQUIRE(FILE=filename, EXIST=file_exists)
3310 : if(.not. file_exists) then
3311 : write(message,'(4a)') ch10,' Cannot find file ', trim(filename), '! Make sure the python script writes it with the right name and at the right place!'
3312 : call wrtout(std_out,message,'COLL')
3313 : ABI_ERROR(message)
3314 : endif
3315 :
3316 : write(std_out, '(3a)') ch10, " Reading NETCDF file ", trim(filename)
3317 :
3318 : ! Opening the NETCDF file
3319 : NCF_CHECK(nf90_open(filename, nf90_nowrite, ncid))
3320 :
3321 : ! Read from the file
3322 : ! Re{G_iw}
3323 : write(std_out, '(2a)') ch10, " -- Re[G(iw_n)]"
3324 : NCF_CHECK(nf90_inq_varid(ncid, "re_g_iw", varid))
3325 : NCF_CHECK(nf90_get_var(ncid, varid, new_re_g_iw))
3326 : ! Im{G_iw}
3327 : write(std_out, '(2a)') ch10, " -- Im[G(iw_n)]"
3328 : NCF_CHECK(nf90_inq_varid(ncid, "im_g_iw", varid))
3329 : NCF_CHECK(nf90_get_var(ncid, varid, new_im_g_iw))
3330 : ! G_tau
3331 : write(std_out, '(2a)') ch10, " -- G(tau)"
3332 : NCF_CHECK(nf90_inq_varid(ncid, "g_tau", varid))
3333 : NCF_CHECK(nf90_get_var(ncid, varid, new_g_tau))
3334 : ! G_l
3335 : write(std_out, '(2a)') ch10, " -- G_l"
3336 : NCF_CHECK(nf90_inq_varid(ncid, "gl", varid))
3337 : NCF_CHECK(nf90_get_var(ncid, varid, new_gl))
3338 :
3339 : ! Assigning data
3340 : do iflavor1=1, nflavor
3341 : do iflavor2=1, nflavor
3342 : do ifreq=1, paw_dmft%dmft_nwli
3343 : gw_tmp_nd(ifreq, iflavor1, iflavor2) = new_re_g_iw(iflavor1, iflavor2, ifreq) &
3344 : & + i*new_im_g_iw(iflavor1, iflavor2, ifreq)
3345 : end do
3346 : do itau=1, paw_dmft%dmftqmc_l
3347 : gtmp_nd(itau, iflavor1, iflavor2) = new_g_tau(iflavor1, iflavor2, itau)
3348 : end do
3349 : do ileg=1, nleg
3350 : gl_nd(ileg, iflavor1, iflavor2) = new_gl(iflavor1, iflavor2, ileg)
3351 : end do
3352 : end do
3353 : end do
3354 :
3355 : ! Deallocating
3356 : ABI_FREE(new_re_g_iw)
3357 : ABI_FREE(new_im_g_iw)
3358 : ABI_FREE(new_g_tau)
3359 : ABI_FREE(new_gl)
3360 : #endif
3361 : elseif(paw_dmft%dmft_solv == 6 .or. paw_dmft%dmft_solv == 7) then
3362 : !Calling interfaced TRIQS solver subroutine from src/01_triqs_ext package
3363 : !----------------------------------------------------
3364 : #if defined HAVE_TRIQS_v2_0 || defined HAVE_TRIQS_v1_4
3365 : call Ctqmc_triqs_run ( rot_inv, leg_measure, hist, wrt_files, tot_not, &
3366 : & nflavor, nfreq, ntau , nleg, int(paw_dmft%dmftqmc_n/paw_dmft%nproc), &
3367 : & paw_dmft%dmftctqmc_meas*2*2*nflavor, paw_dmft%dmftqmc_therm, &
3368 : & verbosity_solver, paw_dmft%dmftqmc_seed,beta, &
3369 : & levels_ptr, u_mat_ij_ptr, u_mat_ijkl_ptr, fw1_nd_ptr, &
3370 : !& g_iw_ptr, gtau_ptr, gl_ptr, paw_dmft%spacecomm )
3371 : & g_iw_ptr, gtau_ptr, gl_ptr, paw_dmft%myproc )
3372 : #endif
3373 : endif
3374 :
3375 : !WRITE(*,*) "Hello Debug"
3376 : !call xmpi_barrier(paw_dmft%spacecomm) !Resynch all processus after calling Impurity solver from TRIQS
3377 :
3378 : !Report output datas from TRIQS to Abinit
3379 : !Interacting G(iw)
3380 : ! OG Commented these loops because they are useless
3381 : !do ifreq=1,nfreq
3382 : ! do iflavor1=1,nflavor
3383 : ! do iflavor=1,nflavor
3384 : ! ! gw_tmp_nd(ifreq,iflavor,iflavor1) = g_iw(iflavor,iflavor1,ifreq) !* Ha_eV !because 1/ G0(eV)
3385 : ! ! WRITE(503,*) "[OUT Fortran] G(iw)[ w= ",ifreq," l= ",iflavor," l_= ",iflavor1,"] = ",gw_tmp_nd(ifreq,iflavor,iflavor1)!g_iw(iflavor,iflavor1,ifreq)
3386 : ! end do
3387 : ! end do
3388 : !end do
3389 :
3390 : ! Convert in Ha
3391 0 : gw_tmp_nd = gw_tmp_nd*Ha_eV
3392 :
3393 : ! do iflavor1=1,nflavor
3394 : ! do iflavor=1,nflavor
3395 : !
3396 : ! WRITE(510,*) "[OUT Fortran] U[ l= ",iflavor," l_= ",iflavor1,"] = ",u_mat_ij(iflavor,iflavor1)
3397 : ! enddo
3398 : ! enddo
3399 :
3400 : ! if(paw_dmft%myproc==0) write(6,*) "essai",paw_dmft%myproc, gw_tmp_nd(2,1,1)
3401 : ! if(paw_dmft%myproc==1) write(6,*) "essai",paw_dmft%myproc,gw_tmp_nd(2,1,1)
3402 : ! if(paw_dmft%myproc==0) write(621,*) "essai",paw_dmft%myproc, gw_tmp_nd(2,1,1)
3403 : ! if(paw_dmft%myproc==1) write(622,*) "essai",paw_dmft%myproc,gw_tmp_nd(2,1,1)
3404 : ! call flush_unit(621)
3405 : ! call flush_unit(622)
3406 : ! write(message,*) ch10, "essai",paw_dmft%myproc, paw_dmft%myproc,paw_dmft%dmftqmc_seed!gw_tmp_nd(2,1,1)
3407 : ! call wrtout(555,message,'PERS',.true.)
3408 : ! if(paw_dmft%myproc==0) write(499,*) "essai",paw_dmft%myproc, paw_dmft%dmftqmc_seed
3409 : ! if(paw_dmft%myproc==1) write(498,*) "essai",paw_dmft%myproc,paw_dmft%dmftqmc_seed
3410 :
3411 : !Its associated G(tau): Problem of compatibility => paw_dmft%dmftqmc_l < (2*paw_dmft%dmftqmc_l)+1 => We report only paw_dmft%dmftqmc_l = first values of G(tau)...
3412 : ! do iflavor=1,nflavor
3413 : ! do iflavor1=1,nflavor
3414 : ! do itau=1,ntau
3415 : ! if ( modulo(itau,2) == 1 ) then !Problem of binding: paw_dmft%dmftqmc_l =! ntau => We take one value by 2 and Write in file all the G(tau) out function from TRIQS
3416 : !gtmp_nd(itau,iflavor,iflavor1) = gtau(iflavor,iflavor1,itau)
3417 : ! endif
3418 : ! if(paw_dmft%myproc==0) then
3419 : ! WRITE(504,*) "[OUT Fortran] G[ tau= ",itau," l= ",iflavor," l_= ",iflavor1,"] = ",gtmp_nd(itau,iflavor,iflavor1) !gtmp_nd(itau,iflavor,iflavor1) !passage ok avec ntau/iflavor1/iflavor (iflavor,iflavor1,ntau)
3420 : ! endif
3421 : ! enddo
3422 : ! enddo
3423 : ! enddo
3424 :
3425 : ! Write Legendre Polynoms G(L) for extrapolation of Interacting G(iw) by FT, only if leg_measure == TRUE
3426 : ! -------------------------------------------------------------------------------------------
3427 0 : if (leg_measure) then
3428 0 : do ileg=1,nleg
3429 0 : WRITE(505,*) ileg,((gl_nd(ileg,iflavor,iflavor1),iflavor=1,nflavor),iflavor1=1,nflavor)
3430 : end do
3431 0 : close(505)
3432 : end if
3433 : ! f(paw_dmft%myproc==0) then
3434 : ! do itau=1,paw_dmft%dmftqmc_l
3435 : ! write(490,*) ((gtmp_nd(itau,iflavor,iflavor1),iflavor=1,nflavor),iflavor1=1,nflavor)
3436 : ! enddo
3437 : ! ndif
3438 0 : ABI_FREE( fw1_nd_tmp )
3439 0 : ABI_FREE( g_iw )
3440 0 : ABI_FREE( u_mat_ijkl )
3441 0 : ABI_FREE( u_mat_ijkl_tmp )
3442 0 : ABI_FREE( u_mat_ij )
3443 :
3444 :
3445 : ! Compute Green's function in imaginary freq using Legendre coefficients
3446 : ! -----------------------------------------------------------------------
3447 0 : if (leg_measure) then
3448 0 : call xmpi_barrier(paw_dmft%spacecomm)
3449 0 : call flush_unit(std_out)
3450 0 : write(message,'(2a)') ch10," == Compute G(iw_n) from Legendre coefficients"
3451 0 : call wrtout(std_out,message,'COLL')
3452 0 : ABI_MALLOC( jbes, (nleg))
3453 0 : gw_tmp_nd=czero
3454 :
3455 : ! write(77,*) " TEST OF BESSEL S ROUTINES 0 0"
3456 :
3457 : ! xx=0_dp
3458 : ! ileg=0
3459 : ! call sbf8(ileg+1,xx,jbes)
3460 : ! write(77,*) "T0 A",jbes(ileg+1)
3461 : ! call jbessel(jbes(ileg+1),besp,bespp,ileg,1,xx)
3462 : ! write(77,*) "T0 B",jbes(ileg+1)
3463 : ! write(77,*) "T0 C",bessel_jn(ileg,xx)
3464 :
3465 : ! write(77,*) " TEST OF BESSEL S ROUTINES 1.5 0"
3466 :
3467 : ! xx=1.5_dp
3468 : ! ileg=0
3469 : ! call sbf8(ileg+1,xx,jbes)
3470 : ! write(77,*) "T1 A",jbes(ileg+1)
3471 : ! call jbessel(jbes(ileg+1),besp,bespp,ileg,1,xx)
3472 : ! write(77,*) "T1 B",jbes(ileg+1)
3473 : ! write(77,*) "T1 C",bessel_jn(ileg,xx)
3474 :
3475 : ! write(77,*) " TEST OF BESSEL S ROUTINES 1.5 1"
3476 :
3477 : ! xx=1.5_dp
3478 : ! ileg=1
3479 : ! call sbf8(ileg+1,xx,jbes)
3480 : ! write(77,*) "T2 A",jbes(ileg+1)
3481 : ! call jbessel(jbes(ileg+1),besp,bespp,ileg,1,xx)
3482 : ! write(77,*) "T2 B",jbes(ileg+1)
3483 : ! write(77,*) "T2 C",bessel_jn(ileg,xx)
3484 :
3485 :
3486 0 : do ifreq=1,paw_dmft%dmft_nwli
3487 0 : xx=real(2*ifreq-1,kind=dp)*pi/two
3488 0 : if(xx<=100_dp) call sbf8(nleg,xx,jbes)
3489 0 : do ileg=1,nleg
3490 : ! write(77,*) "A",ifreq,jbes(ileg),xx
3491 :
3492 0 : if(xx>=99) call jbessel(jbes(ileg),besp,bespp,ileg-1,1,xx)
3493 : ! write(77,*) "B",ifreq,jbes(ileg),xx
3494 :
3495 : !write(77,*) "C",ifreq,jbes(ileg),xx
3496 :
3497 0 : u_nl=sqrt(float(2*ileg-1))*(-1)**(ifreq-1)*cmplx(0_dp,one)**(ileg)*jbes(ileg)
3498 0 : write(77,*) "----------",ileg,jbes(ileg), u_nl,gl_nd(ileg,1,1)
3499 :
3500 0 : do iflavor=1,nflavor
3501 0 : do iflavor1=1,nflavor
3502 : gw_tmp_nd(ifreq,iflavor,iflavor1)= gw_tmp_nd(ifreq,iflavor,iflavor1) + &
3503 0 : & u_nl*gl_nd(ileg,iflavor,iflavor1)
3504 : end do
3505 : end do
3506 :
3507 : ! write(77,*) "------------------", gw_tmp_nd(ifreq,1,1)
3508 :
3509 : end do
3510 : ! write(77,*) "------------------ sum ", gw_tmp_nd(ifreq,1,1)
3511 : end do
3512 0 : ABI_FREE( jbes )
3513 0 : call xmpi_barrier(paw_dmft%spacecomm)
3514 0 : call flush_unit(std_out)
3515 : end if
3516 0 : gw_tmp_nd = gw_tmp_nd*Ha_eV
3517 :
3518 :
3519 0 : if ( leg_measure ) then !only if functionality is enabled
3520 0 : ABI_FREE(gl_nd)
3521 : end if
3522 :
3523 :
3524 0 : end subroutine ctqmc_calltriqs
3525 : !!***
3526 :
3527 : !!****f* m_forctqmc/ctqmc_calltriqs_c
3528 : !! NAME
3529 : !! ctqmc_calltriqs_c
3530 : !!
3531 : !! FUNCTION
3532 : !! This routines calls TRIQS/CTHYB using the C++ API in order
3533 : !! to solve the impurity model.
3534 : !!
3535 : !! INPUTS
3536 : !! paw_dmft <type(paw_dmft_type)>= DMFT data structure
3537 : !! green <type(green_type)>= green's function
3538 : !! self <type(self_type)>= self-energy
3539 : !! hu <type(hu_type)>= U interaction
3540 : !! weiss <type(green_type)>= inverse of weiss function
3541 : !! self_new <type(self_type)>= impurity self-energy
3542 : !! pawprtvol = flag for printing
3543 : !!
3544 : !! OUTPUT
3545 : !!
3546 : !! SIDE EFFECTS
3547 : !!
3548 : !! NOTES
3549 : !!
3550 : !! SOURCE
3551 :
3552 0 : subroutine ctqmc_calltriqs_c(paw_dmft,green,self,hu,weiss,self_new,pawprtvol)
3553 :
3554 : #if defined HAVE_TRIQS_INTERNAL || defined HAVE_TRIQS_v3_2
3555 : use TRIQS_CTQMC
3556 : #endif
3557 : use ISO_C_BINDING
3558 :
3559 : !Arguments ------------------------------------
3560 : integer, intent(in) :: pawprtvol
3561 : type(paw_dmft_type), intent(in) :: paw_dmft
3562 : type(green_type), target, intent(inout) :: green,weiss
3563 : type(self_type), intent(inout) :: self,self_new
3564 : type(hu_type), intent(inout) :: hu(paw_dmft%ntypat)
3565 : !Local variables ------------------------------
3566 : integer :: basis,i,iatom,iblock,iflavor,iflavor1,iflavor2,ifreq,ilam,ileg,im,im1,integral,isppol,isub
3567 : integer :: itau,itypat,iw,l,len_t,lpawu,myproc,natom,ncon,ndim,nflavor,nflavor_max,ngauss,nleg,nmoments
3568 : integer :: nspinor,nsppol,nsub,ntau,ntot,nwlo,p,pad_elam,pad_lambda,read_data,rot_type_vee,tndim,unt,verbo,wdlr_size
3569 : integer, target :: ndlr
3570 : logical :: debug,density_matrix,entropy,leg_measure,nondiag,off_diag,rot_inv
3571 : real(dp) :: besp,bespp,beta,dx,elam,emig_tot,err,err_,fact,fact2,shift_mu,tau,tol,xtau,xx
3572 : complex(dp) :: mself_1,mself_2,occ_tmp,u_nl
3573 : complex(dp), target :: eu
3574 0 : type(oper_type), target :: energy_level
3575 0 : type(self_type) :: hybmwdhyb
3576 : type(c_ptr) :: block_ptr,eu_ptr,flavor_ptr,fname_data_ptr,fname_dataw_ptr,fname_histo_ptr,ftau_ptr,gl_ptr,gtau_ptr
3577 : type(c_ptr) :: inner_ptr,levels_ptr,mself_1_ptr,mself_2_ptr,ndlr_ptr,occ_ptr,siz_ptr,udens_ptr,vee_ptr,wdlr_ptr
3578 : type(c_ptr) :: chiloc_ptr,magmom_ptr
3579 0 : integer, allocatable :: flavor_list(:,:,:),nblocks(:)
3580 0 : integer, target, allocatable :: block_list(:,:),flavor_tmp(:,:),inner_list(:,:),siz_block(:,:)
3581 0 : real(dp), allocatable :: adlr(:,:),bdlr(:),elam_list(:),emig(:),gl_dlr_re(:),gl_dlr_im(:),jbes(:),lam_list(:)
3582 0 : real(dp), allocatable :: leg_array(:,:),moment_fit(:),t_lp(:,:),tpoints(:),tweights(:),wdlr(:),wdlr_beta(:,:)
3583 0 : real(dp), target, allocatable :: wdlr_tmp(:), chiloc_tmp(:,:), magmom_array(:)
3584 0 : complex(dp), allocatable :: adlr_iw(:,:),gl_dlr(:,:,:,:),gl_tmp(:,:,:,:),gtau_dlr(:,:,:),gtau_leg(:,:,:),shift(:)
3585 0 : complex(dp), target, allocatable :: gl(:,:,:),gtau(:,:,:),levels_ctqmc(:,:),moments_self_1(:),moments_self_2(:),occ(:)
3586 0 : type(matlu_type), allocatable :: eigvectmatlu(:),matlu_tmp(:)
3587 0 : type(matlu_type), target, allocatable :: dmat_ctqmc(:),ftau(:),udens_rot(:)
3588 0 : type(matlu_type), pointer :: matlu_pt(:) => null()
3589 0 : type(vee_type), target, allocatable :: vee_rot(:)
3590 0 : type(coeff2c_type), allocatable :: magmom_tot(:)
3591 0 : type(matlu_type), allocatable :: matlumag_tot(:)
3592 : character(len=1) :: tag_block4
3593 : character(len=2) :: tag_block,tag_block3,tag_lam
3594 : character(len=4) :: tag_at
3595 : character(len=14) :: tag_elam,tag_lambda
3596 : character(len=500) :: stringfile,tag_block2,tag_lam2
3597 : character(len=10000) :: message
3598 : character(len=fnlen), target :: fname_data,fname_dataw,fname_histo
3599 : ! ************************************************************************
3600 :
3601 0 : basis = paw_dmft%dmftctqmc_basis
3602 0 : beta = one / paw_dmft%temp
3603 0 : debug = paw_dmft%dmft_triqs_prt_entropy
3604 0 : density_matrix = paw_dmft%dmft_triqs_measure_density_matrix
3605 0 : entropy = (paw_dmft%dmft_triqs_entropy == 1)
3606 0 : integral = paw_dmft%dmft_triqs_compute_integral
3607 0 : leg_measure = paw_dmft%dmft_triqs_leg_measure
3608 0 : myproc = paw_dmft%myproc
3609 0 : natom = paw_dmft%natom
3610 0 : nflavor_max = 2 * (2*paw_dmft%maxlpawu+1)
3611 0 : ngauss = paw_dmft%dmft_triqs_gaussorder
3612 0 : nleg = paw_dmft%dmft_triqs_nleg
3613 0 : nspinor = paw_dmft%nspinor
3614 0 : nsppol = paw_dmft%nsppol
3615 0 : nsub = paw_dmft%dmft_triqs_nsubdivisions
3616 0 : ntau = paw_dmft%dmftqmc_l
3617 0 : nwlo = paw_dmft%dmft_nwlo
3618 0 : off_diag = paw_dmft%dmft_triqs_off_diag
3619 0 : rot_inv = (paw_dmft%dmft_solv == 7)
3620 0 : shift_mu = paw_dmft%dmft_triqs_shift_mu
3621 0 : tol = paw_dmft%dmft_triqs_tol_block
3622 :
3623 0 : if (rot_inv) then
3624 0 : write(message,'(a,3x,a)') ch10,"== Rotationally Invariant Terms Included"
3625 : else
3626 0 : write(message,'(a,3x,a)') ch10,"== Density-Density Terms Included"
3627 : end if
3628 0 : call wrtout(std_out,message,"COLL")
3629 :
3630 0 : ABI_MALLOC(block_list,(nflavor_max,natom))
3631 0 : ABI_MALLOC(dmat_ctqmc,(natom))
3632 0 : ABI_MALLOC(eigvectmatlu,(natom))
3633 0 : ABI_MALLOC(flavor_list,(nflavor_max,nflavor_max,natom))
3634 0 : ABI_MALLOC(ftau,(natom))
3635 0 : ABI_MALLOC(inner_list,(nflavor_max,natom))
3636 0 : ABI_MALLOC(matlu_tmp,(natom))
3637 0 : ABI_MALLOC(nblocks,(natom))
3638 0 : ABI_MALLOC(shift,(natom))
3639 0 : ABI_MALLOC(siz_block,(nflavor_max,natom))
3640 0 : ABI_MALLOC(udens_rot,(natom))
3641 0 : ABI_MALLOC(vee_rot,(natom))
3642 :
3643 0 : call init_matlu(natom,nspinor,nsppol,paw_dmft%lpawu(:),dmat_ctqmc(:))
3644 0 : call init_matlu(natom,nspinor,nsppol,paw_dmft%lpawu(:),eigvectmatlu(:))
3645 0 : call init_matlu(natom,2,ntau,paw_dmft%lpawu(:),ftau(:))
3646 0 : call init_matlu(natom,nspinor,nsppol,paw_dmft%lpawu(:),matlu_tmp(:))
3647 0 : call init_matlu(natom,2,1,paw_dmft%lpawu(:),udens_rot(:))
3648 :
3649 0 : call init_oper(paw_dmft,energy_level,opt_ksloc=2)
3650 :
3651 0 : call init_vee(paw_dmft,vee_rot(:))
3652 :
3653 0 : call compute_levels(energy_level,self%hdc,paw_dmft)
3654 :
3655 0 : write(message,'(a,3x,a)') ch10,"== Print Occupation matrix in cubic basis"
3656 0 : call wrtout(std_out,message,"COLL")
3657 0 : call print_matlu(green%occup%matlu(:),natom,1)
3658 :
3659 0 : call compute_moments_loc(green,self,energy_level,weiss,0)
3660 :
3661 : ! Build hybridization and remove spurious 0th order moment
3662 0 : do ifreq=1,nwlo
3663 0 : shift(:) = cmplx(zero,paw_dmft%omega_lo(ifreq),kind=dp)
3664 0 : call shift_matlu(weiss%oper(ifreq)%matlu(:),natom,shift(:))
3665 0 : call fac_matlu(weiss%oper(ifreq)%matlu(:),natom,-cone)
3666 0 : call add_matlu(weiss%oper(ifreq)%matlu(:),energy_level%matlu(:),matlu_tmp(:),natom,-1)
3667 0 : call add_matlu(matlu_tmp(:),weiss%moments(1)%matlu(:),weiss%oper(ifreq)%matlu(:),natom,-1)
3668 : end do ! ifreq
3669 :
3670 0 : call zero_matlu(weiss%moments(1)%matlu(:),natom)
3671 :
3672 0 : write(message,'(a,3x,a)') ch10,"== Print Delta(iw) for first frequency in cubic basis"
3673 0 : call wrtout(std_out,message,"COLL")
3674 0 : call print_matlu(weiss%oper(1)%matlu(:),natom,1)
3675 :
3676 : if (basis == 0) then
3677 0 : write(message,'(a,3x,a)') ch10,"== Switching to CTQMC basis: staying in cubic basis"
3678 : else if (basis == 1) then
3679 0 : write(message,'(a,3x,2a)') ch10,"== Switching to CTQMC basis: using basis that", &
3680 0 : & " diagonalizes the electronic levels"
3681 : else if (basis == 2) then
3682 0 : write(message,'(a,3x,2a)') ch10,"== Switching to CTQMC basis: using basis that", &
3683 0 : & " diagonalizes the occupation matrix"
3684 : else if (basis == 3) then
3685 0 : write(message,'(a,3x,a)') ch10,"== Switching to CTQMC basis: using Ylm basis"
3686 : else if (basis == 4) then
3687 0 : write(message,'(a,3x,a)') ch10,"== Switching to CTQMC basis: using JmJ basis"
3688 : end if
3689 0 : call wrtout(std_out,message,"COLL")
3690 :
3691 0 : if (basis == 1) then
3692 0 : call checkdiag_matlu(energy_level%matlu(:),natom,tol,nondiag)
3693 0 : if (.not. nondiag) then
3694 0 : basis = 0
3695 0 : write(message,'(a,3x,a)') ch10,"== Electronic levels are already diagonal: staying in the cubic basis"
3696 : else
3697 0 : write(message,'(a,3x,a)') ch10,"== Switching to Ylm basis first"
3698 : end if ! nondiag
3699 0 : call wrtout(std_out,message,"COLL")
3700 : end if ! basis=1
3701 :
3702 0 : if (basis == 2) then
3703 0 : call checkdiag_matlu(green%occup%matlu(:),natom,tol,nondiag)
3704 0 : if (.not. nondiag) then
3705 0 : basis = 0
3706 0 : write(message,'(a,3x,a)') ch10,"== Occupation matrix is already diagonal: staying in the cubic basis"
3707 : else
3708 0 : write(message,'(a,3x,a)') ch10,"== Switching to Ylm basis first"
3709 : end if ! not nondiag
3710 0 : call wrtout(std_out,message,"COLL")
3711 : end if ! basis=2
3712 :
3713 0 : call copy_matlu(green%occup%matlu(:),dmat_ctqmc(:),natom)
3714 :
3715 0 : if (basis > 0) then ! First switch to Ylm basis in every case
3716 0 : call slm2ylm_matlu(energy_level%matlu(:),natom,paw_dmft,1,0)
3717 0 : call slm2ylm_matlu(dmat_ctqmc(:),natom,paw_dmft,1,0)
3718 0 : do i=2,weiss%nmoments-1
3719 0 : call slm2ylm_matlu(weiss%moments(i)%matlu(:),natom,paw_dmft,1,0)
3720 : end do ! i
3721 0 : do ifreq=1,nwlo
3722 0 : if (weiss%distrib%procf(ifreq) /= myproc) cycle
3723 0 : call slm2ylm_matlu(weiss%oper(ifreq)%matlu(:),natom,paw_dmft,1,0)
3724 : end do ! ifreq
3725 : end if ! basis>0
3726 :
3727 0 : if (basis == 1 .or. basis == 2) then
3728 : ! Find block structure in Ylm basis and diagonalize for each block (extremely useful in the
3729 : ! case of degenerate levels ; this ensures minimal mixing of Ylm and thus maximal number of subspaces)
3730 0 : if (basis == 1) then
3731 0 : matlu_pt => energy_level%matlu(:)
3732 : else
3733 0 : matlu_pt => dmat_ctqmc(:)
3734 : end if ! basis
3735 :
3736 0 : if (pawprtvol >= 3) then
3737 0 : if (basis == 1) then
3738 0 : write(message,'(a,3x,a)') ch10,"== Print Energy levels in Ylm basis"
3739 : else
3740 0 : write(message,'(a,3x,a)') ch10,"== Print Occupation matrix in Ylm basis"
3741 : end if
3742 0 : call wrtout(std_out,message,"COLL")
3743 :
3744 0 : call print_matlu(matlu_pt(:),natom,1)
3745 : end if ! pawprtvol>=3
3746 :
3747 : call find_block_structure(paw_dmft,block_list(:,:),inner_list(:,:), &
3748 0 : & flavor_list(:,:,:),siz_block(:,:),nblocks(:),matlu_pt(:),natom,nflavor_max)
3749 0 : call diag_block(matlu_pt)
3750 0 : matlu_pt => null()
3751 :
3752 : ! Make sure every process has the same rotation matrix in case of degenerate levels
3753 0 : call xmpi_matlu(eigvectmatlu(:),natom,paw_dmft%spacecomm,master=0,option=2)
3754 :
3755 0 : if (basis == 1) then
3756 0 : call rotate_matlu(dmat_ctqmc(:),eigvectmatlu(:),natom,1)
3757 : else
3758 0 : call rotate_matlu(energy_level%matlu(:),eigvectmatlu(:),natom,1)
3759 : end if ! basis
3760 0 : do i=2,weiss%nmoments-1
3761 0 : call rotate_matlu(weiss%moments(i)%matlu(:),eigvectmatlu(:),natom,1)
3762 : end do ! i
3763 0 : do ifreq=1,nwlo
3764 0 : if (weiss%distrib%procf(ifreq) /= myproc) cycle
3765 0 : call rotate_matlu(weiss%oper(ifreq)%matlu(:),eigvectmatlu(:),natom,1)
3766 : end do ! ifreq
3767 : end if ! basis=1 or 2
3768 :
3769 0 : if (basis == 4) then
3770 0 : call ylm2jmj_matlu(energy_level%matlu(:),natom,1,paw_dmft)
3771 0 : call ylm2jmj_matlu(dmat_ctqmc(:),natom,1,paw_dmft)
3772 0 : do i=2,weiss%nmoments-1
3773 0 : call ylm2jmj_matlu(weiss%moments(i)%matlu(:),natom,1,paw_dmft)
3774 : end do
3775 0 : do ifreq=1,nwlo
3776 0 : if (weiss%distrib%procf(ifreq) /= myproc) cycle
3777 0 : call ylm2jmj_matlu(weiss%oper(ifreq)%matlu(:),natom,1,paw_dmft)
3778 : end do ! ifreq
3779 : end if ! basis=4
3780 :
3781 0 : if (basis == 0) then
3782 0 : do iatom=1,natom
3783 0 : lpawu = paw_dmft%lpawu(iatom)
3784 0 : if (lpawu == -1) cycle
3785 0 : itypat = paw_dmft%typat(iatom)
3786 0 : udens_rot(iatom)%mat(:,:,1) = hu(itypat)%udens(:,:)
3787 0 : vee_rot(iatom)%mat(:,:,:,:) = hu(itypat)%veeslm2(:,:,:,:)
3788 : end do ! iatom
3789 : else
3790 0 : call gather_oper(weiss%oper(:),weiss%distrib,paw_dmft,opt_ksloc=2)
3791 0 : rot_type_vee = 4
3792 0 : if (basis == 3) rot_type_vee = 2
3793 0 : if (basis == 4) rot_type_vee = 3
3794 0 : call rotatevee_hu(hu(:),paw_dmft,pawprtvol,eigvectmatlu(:),rot_type_vee,udens_rot(:),vee_rot(:))
3795 : end if ! basis
3796 :
3797 0 : write(message,'(a,3x,a)') ch10,"== Print Energy levels in CTQMC basis"
3798 0 : call wrtout(std_out,message,"COLL")
3799 0 : call print_matlu(energy_level%matlu(:),natom,1)
3800 :
3801 0 : write(message,'(a,3x,a)') ch10,"== Print Occupation matrix in CTQMC basis"
3802 0 : call wrtout(std_out,message,"COLL")
3803 0 : call print_matlu(dmat_ctqmc(:),natom,1)
3804 :
3805 0 : write(message,'(a,3x,a)') ch10,"== Print Delta(iw) for first frequency in CTQMC basis"
3806 0 : call wrtout(std_out,message,"COLL")
3807 0 : call print_matlu(weiss%oper(1)%matlu(:),natom,1)
3808 :
3809 : ! Possibly set the imaginary part and off-diagonal elements to 0 now that we
3810 : ! are in the CTQMC basis. This is extremely important to do it explicitly instead of
3811 : ! simply sending the real part or the diagonal elements to TRIQS since this modifies
3812 : ! the electronic levels and hybridization that are used in Dyson's equation later.
3813 :
3814 : #ifndef HAVE_TRIQS_COMPLEX
3815 0 : write(message,'(a,3x,2a)') ch10,"== The imaginary part of Delta(tau) and the ", &
3816 0 : & "electronic levels is now set to 0"
3817 0 : call wrtout(std_out,message,"COLL")
3818 : ! Symmetrizing Delta(iw) is equivalent to neglecting the imaginary part of Delta(tau)
3819 0 : err = zero
3820 0 : do ifreq=1,nwlo
3821 0 : call symmetrize_matlu(weiss%oper(ifreq)%matlu(:),natom,err=err_)
3822 0 : if (err_ > err) err = err_
3823 : end do ! ifreq
3824 0 : do i=2,weiss%nmoments-1
3825 0 : call symmetrize_matlu(weiss%moments(i)%matlu(:),natom,err=err_)
3826 0 : if (err_ > err) err = err_
3827 : end do ! i
3828 0 : call zero_matlu(energy_level%matlu(:),natom,onlyimag=1,err=err_)
3829 0 : if (err_ > err) err = err_
3830 0 : if (err > tol) then
3831 0 : write(message,'(2a)') "WARNING: This is not a good approximation ; the imaginary ", &
3832 0 : & "part is non negligible !"
3833 0 : ABI_WARNING(message)
3834 : end if ! err>tol
3835 : #endif
3836 :
3837 0 : err = zero
3838 0 : if ((.not. rot_inv) .or. (.not. off_diag)) then
3839 0 : call zero_matlu(energy_level%matlu(:),natom,onlynondiag=1,err=err_)
3840 0 : if (err_ > err) err = err_
3841 : end if
3842 :
3843 0 : if (.not. off_diag) then
3844 0 : write(message,'(a,3x,2a)') ch10,"== The off-diagonal elements of the hybridization ", &
3845 0 : & "and the electronic levels are now set to 0"
3846 0 : call wrtout(std_out,message,"COLL")
3847 0 : do ifreq=1,nwlo
3848 0 : call zero_matlu(weiss%oper(ifreq)%matlu(:),natom,onlynondiag=1,err=err_)
3849 0 : if (err_ > err) err = err_
3850 : end do ! ifreq
3851 0 : do i=2,weiss%nmoments-1
3852 0 : call zero_matlu(weiss%moments(i)%matlu(:),natom,onlynondiag=1,err=err_)
3853 0 : if (err_ > err) err = err_
3854 : end do ! i
3855 0 : if (err > tol) then
3856 0 : write(message,'(2a)') "WARNING: This is not a good approximation ; the off-diagonal ", &
3857 0 : & "elements are non negligible !"
3858 0 : ABI_WARNING(message)
3859 : end if ! err>tol
3860 : end if ! not off_diag
3861 :
3862 : ! Prepare DLR frequencies
3863 0 : if (.not. leg_measure) then
3864 0 : wdlr_size = 1000 ! make sure this is big enough
3865 0 : ABI_MALLOC(wdlr_tmp,(wdlr_size))
3866 0 : ndlr_ptr = C_LOC(ndlr)
3867 0 : wdlr_ptr = C_LOC(wdlr_tmp)
3868 : #if defined HAVE_TRIQS_INTERNAL || defined HAVE_TRIQS_v3_2
3869 : call build_dlr(wdlr_size,ndlr_ptr,wdlr_ptr,paw_dmft%dmft_triqs_lambda,paw_dmft%dmft_triqs_epsilon)
3870 : #endif
3871 0 : if (ndlr > wdlr_size) then
3872 0 : write(message,'(a,i4,2a)') "You have more than ",wdlr_size," DLR frequencies.", &
3873 0 : & " Something is wrong here."
3874 0 : ABI_ERROR(message)
3875 : end if
3876 :
3877 0 : ABI_MALLOC(wdlr,(ndlr))
3878 0 : ABI_MALLOC(wdlr_beta,(ndlr,4))
3879 0 : wdlr(:) = wdlr_tmp(1:ndlr)
3880 0 : wdlr_beta(:,1) = wdlr(:) / beta
3881 0 : do i=2,4
3882 0 : wdlr_beta(:,i) = wdlr_beta(:,i-1) * wdlr_beta(:,1)
3883 : end do
3884 0 : ABI_FREE(wdlr_tmp)
3885 0 : ABI_MALLOC(adlr,(ndlr,ntau))
3886 0 : ABI_MALLOC(adlr_iw,(ndlr,nwlo))
3887 :
3888 0 : do ifreq=1,nwlo
3889 0 : do iw=1,ndlr
3890 0 : adlr_iw(iw,ifreq) = k_iw(paw_dmft%omega_lo(ifreq),wdlr_beta(iw,1))
3891 : end do ! iw
3892 : end do ! ifreq
3893 :
3894 0 : do itau=1,ntau
3895 0 : do iw=1,ndlr
3896 0 : adlr(iw,itau) = k_it(dble(itau-1)/dble(ntau-1),wdlr(iw))
3897 : end do ! iw
3898 : end do ! itau
3899 :
3900 0 : write(tag_at,'(i4)') ndlr
3901 0 : write(message,'(a,3x,3a)') ch10,"== There are ",trim(adjustl(tag_at))," DLR frequencies"
3902 0 : call wrtout(std_out,message,"COLL")
3903 0 : write(message,'(3x,1000(e10.3,2x))') wdlr_beta(:,1)
3904 0 : call wrtout(std_out,message,"COLL")
3905 0 : call identity_oper(green%moments(1),2)
3906 : end if ! not leg_measure
3907 :
3908 : ! ntot is total number of lambda pts, + 1 is because we add the case lambda = 1 (which has no reason to be included in the
3909 : ! Gauss-Legendre grid), since we need it for the rest of the SCF calculation
3910 0 : ntot = merge(ngauss*nsub+1,1,integral>0.and.entropy)
3911 :
3912 0 : ABI_MALLOC(elam_list,(ntot))
3913 0 : ABI_MALLOC(lam_list,(ntot)) ! scaling factors of U matrix for thermodynamic integration
3914 0 : lam_list(ntot) = one
3915 0 : green%integral = zero
3916 0 : green%ekin_imp = zero
3917 :
3918 : ! Prepare Gauss-Legendre quadrature for thermodynamic integration over U
3919 0 : if (integral > 0 .and. entropy) then
3920 :
3921 0 : ABI_MALLOC(tweights,(ngauss))
3922 0 : ABI_MALLOC(tpoints,(ngauss))
3923 :
3924 : ! Calculation of Gauss-Legendre grid (on [-1,1]) of size ngauss
3925 0 : call coeffs_gausslegint(-one,one,tpoints(:),tweights(:),ngauss)
3926 :
3927 0 : dx = one / dble(nsub)
3928 :
3929 : ! Split [0,1] into nsub intervals [x_i,x_{i+1}],i=1,nsub with x_i=(i-1)*dx
3930 0 : do isub=1,nsub
3931 : ! For each interval, the Gauss-Legendre grid of size ngauss is mapped from the
3932 : ! t-world where t in [-1,1] to the x-world where x in [x_{isub},x_{isub+1}]
3933 0 : lam_list((isub-1)*ngauss+1:isub*ngauss) = (dble(isub)*two+tpoints(:)-one) * dx * half
3934 : end do ! ilam
3935 :
3936 : end if ! integral and entropy
3937 :
3938 : ! Build most optimal block structure in CTQMC basis
3939 0 : write(message,'(a,3x,2a)') ch10,"== Searching for the most optimal block structure of", &
3940 0 : & " the electronic levels and the hybridization"
3941 0 : call wrtout(std_out,message,"COLL")
3942 :
3943 : call find_block_structure(paw_dmft,block_list(:,:),inner_list(:,:),flavor_list(:,:,:), &
3944 0 : & siz_block(:,:),nblocks(:),energy_level%matlu(:),natom,nflavor_max,hyb=weiss)
3945 :
3946 0 : nmoments = weiss%nmoments - 2
3947 :
3948 : ! Inverse Fourier transform of the hybridization
3949 0 : call fourier_inv(paw_dmft,nmoments,ntau,ftau(:),weiss%oper(:),weiss%moments(2:nmoments+1))
3950 :
3951 0 : if (entropy) then
3952 0 : ABI_MALLOC(emig,(natom))
3953 : ! Cubic splines to compute the derivative of Delta(iw)
3954 0 : call initialize_self(hybmwdhyb,paw_dmft,opt_moments=1)
3955 0 : call cubic_spline()
3956 0 : call copy_matlu(energy_level%matlu(:),hybmwdhyb%moments(1)%matlu(:),natom)
3957 0 : do i=2,weiss%nmoments-1
3958 0 : call copy_matlu(weiss%moments(i)%matlu(:),hybmwdhyb%moments(i)%matlu(:),natom)
3959 0 : call fac_matlu(hybmwdhyb%moments(i)%matlu(:),natom,cmplx(dble(i),zero,kind=dp))
3960 : end do ! i
3961 : end if ! entropy
3962 :
3963 : ! Solve impurity model for each atom
3964 0 : do iatom=1,natom
3965 :
3966 0 : lpawu = paw_dmft%lpawu(iatom)
3967 0 : if (lpawu == -1) cycle
3968 0 : ndim = 2*lpawu + 1
3969 0 : tndim = nspinor * ndim
3970 0 : nflavor = 2 * ndim
3971 :
3972 : !Local Spin-Spin correlation function
3973 0 : if (paw_dmft%dmft_triqs_chiloc > 0) then
3974 :
3975 : ! == slm case : \hat{S_z} = n_up - n_down
3976 0 : ABI_MALLOC(chiloc_tmp,(1:ntau,1:ntau))
3977 0 : chiloc_ptr = C_LOC(chiloc_tmp)
3978 :
3979 : ! == Mj case : \hat{J_z} = n_mj * \mu_mjz
3980 0 : if(nspinor .eq. 2 .and. basis .eq. 4) then
3981 0 : magmom_ptr = C_NULL_PTR
3982 :
3983 0 : ABI_MALLOC(magmom_tot,(natom))
3984 0 : ABI_MALLOC(matlumag_tot,(natom))
3985 :
3986 0 : lpawu = paw_dmft%lpawu(iatom)
3987 0 : if (lpawu == -1) cycle
3988 0 : ABI_MALLOC(magmom_tot(iatom)%value,(2*(2*lpawu+1),2*(2*lpawu+1)))
3989 0 : magmom_tot(iatom)%value=czero
3990 :
3991 0 : call init_matlu(natom=1,nspinor=paw_dmft%nspinor,nsppol=paw_dmft%nsppol,lpawu_natom=paw_dmft%lpawu,matlu=matlumag_tot)
3992 0 : call zero_matlu(matlumag_tot,natom=1)
3993 0 : call magmomjmj_matlu(matlumag_tot,natom=1)
3994 0 : call gather_matlu(matlumag_tot,magmom_tot,natom=1,option=1,prtopt=0)
3995 0 : call destroy_matlu(matlumag_tot,natom=1)
3996 : !
3997 0 : ABI_MALLOC(magmom_array,(nflavor*nflavor))
3998 0 : magmom_array(:) = zero
3999 0 : magmom_array = reshape(real(magmom_tot(iatom)%value), (/nflavor*nflavor/))
4000 0 : magmom_ptr = C_LOC(magmom_array)
4001 : end if
4002 : end if !end chiloc
4003 :
4004 0 : write(tag_at,'(i4)') iatom
4005 0 : write(tag_block,'(i2)') nblocks(iatom)
4006 0 : write(message,'(a,3x,6a)') ch10,"== Solving impurity model for atom ",trim(adjustl(tag_at)), &
4007 0 : & ", where there are ",trim(adjustl(tag_block))," blocks",ch10
4008 0 : call wrtout(std_out,message,'COLL')
4009 :
4010 0 : do iblock=1,nblocks(iatom)
4011 0 : write(tag_block,'(i2)') iblock - 1
4012 0 : tag_block2 = ""
4013 0 : do iflavor=1,siz_block(iblock,iatom)
4014 0 : write(tag_block3,'(i2)') flavor_list(iflavor,iblock,iatom)
4015 0 : tag_block2 = trim(tag_block2) // " " // trim(adjustl(tag_block3))
4016 : end do ! iflavor
4017 0 : tag_block4 = ""
4018 0 : if (siz_block(iblock,iatom) > 1) tag_block4 = "s"
4019 0 : write(message,'(2x,4a,1x,a)') "--> Block ",trim(adjustl(tag_block))," contains flavor",trim(adjustl(tag_block4)),trim(adjustl(tag_block2))
4020 0 : call wrtout(std_out,message,'COLL')
4021 : end do ! iblock
4022 :
4023 0 : write(message,'(a,3x,2a)') ch10,"== Schematic of the block structure",ch10
4024 0 : call wrtout(std_out,message,'COLL')
4025 :
4026 0 : iflavor = 1
4027 0 : do iblock=1,nblocks(iatom)
4028 0 : do iflavor1=1,siz_block(iblock,iatom)
4029 0 : tag_block2 = ""
4030 0 : do iflavor2=1,iflavor-1
4031 0 : tag_block2 = trim(tag_block2) // " ."
4032 : end do ! iflavor2
4033 0 : do iflavor2=1,iflavor1-1
4034 0 : tag_block2 = trim(tag_block2) // " x"
4035 : end do ! iflavor2
4036 0 : write(tag_block,'(i2)') flavor_list(iflavor1,iblock,iatom)
4037 0 : i = merge(1,2,flavor_list(iflavor1,iblock,iatom)>=10)
4038 0 : tag_block2 = trim(tag_block2) // repeat(" ",i) // trim(adjustl(tag_block))
4039 0 : do iflavor2=iflavor1+1,siz_block(iblock,iatom)
4040 0 : tag_block2 = trim(tag_block2) // " x"
4041 : end do ! iflavor2
4042 0 : do iflavor2=iflavor+siz_block(iblock,iatom),nflavor
4043 0 : tag_block2 = trim(tag_block2) // " ."
4044 : end do ! iflavor2
4045 0 : write(message,'(4x,a)') tag_block2
4046 0 : call wrtout(std_out,message,'COLL')
4047 : end do ! iflavor1
4048 0 : iflavor = iflavor + siz_block(iblock,iatom)
4049 : end do ! iblock
4050 :
4051 0 : call int2char4(iatom,tag_at)
4052 0 : ABI_CHECK((tag_at(1:1)/='#'),'Bug: string length too short!')
4053 :
4054 0 : if (myproc == 0 .and. off_diag) then
4055 :
4056 0 : if (open_file(trim(paw_dmft%filapp)//"_Hybridization_offdiag_iatom"//tag_at//".dat",message,newunit=unt) /= 0) ABI_ERROR(message)
4057 0 : write(unt,'(6a)') "# Off-diagonal components of Delta(tau) in the CTQMC basis",ch10, &
4058 0 : & "# Columns are ordered this way:",ch10, &
4059 0 : & "# Imaginary Time ((Re(Delta_{ij}) Im(Delta_{ij}),i=1,2*(2*l+1)),j=1,2*(2*l+1)) where the", &
4060 0 : & " leftmost index varies first"
4061 :
4062 0 : do itau=1,ntau
4063 0 : write(unt,'(2x,393(e18.10e3,2x))') beta*dble(itau-1)/dble(ntau-1), &
4064 0 : & ((dble(ftau(iatom)%mat(im,im1,itau)),aimag(ftau(iatom)%mat(im,im1,itau)),im=1,nflavor),im1=1,nflavor)
4065 : end do ! itau
4066 0 : close(unt)
4067 :
4068 : end if ! myproc=0
4069 :
4070 0 : if (myproc == 0) then
4071 :
4072 0 : if (open_file(trim(paw_dmft%filapp)//"_Hybridization_diag_iatom"//tag_at//".dat",message,newunit=unt) /= 0) ABI_ERROR(message)
4073 0 : write(unt,'(5a)') "# Diagonal components of Delta(tau) in the CTQMC basis",ch10, &
4074 0 : & "# Columns are ordered this way:",ch10, &
4075 0 : & "# Imaginary Time (Delta_{ii},i=1,2*(2*l+1))"
4076 :
4077 0 : do itau=1,ntau
4078 0 : write(unt,'(2x,393(e25.17e3,2x))') beta*dble(itau-1)/dble(ntau-1),(dble(ftau(iatom)%mat(im,im,itau)),im=1,nflavor)
4079 : end do ! itau
4080 0 : close(unt)
4081 :
4082 : end if ! myproc=0
4083 :
4084 0 : ABI_MALLOC(levels_ctqmc,(nflavor,nflavor))
4085 0 : ABI_MALLOC(gtau,(ntau,nflavor,nflavor))
4086 0 : gtau(:,:,:) = czero
4087 0 : if (density_matrix) then
4088 0 : ABI_MALLOC(occ,(nflavor))
4089 : end if
4090 0 : if ((.not. leg_measure) .and. density_matrix) then
4091 0 : ABI_MALLOC(moments_self_1,(nflavor))
4092 0 : ABI_MALLOC(moments_self_2,(nflavor))
4093 : end if
4094 : if (leg_measure) then
4095 0 : ABI_MALLOC(gl,(nleg,nflavor,nflavor))
4096 0 : gl(:,:,:) = czero
4097 : end if
4098 0 : ABI_MALLOC(flavor_tmp,(nflavor,nflavor))
4099 :
4100 0 : levels_ctqmc(:,:) = czero
4101 0 : do isppol=1,nsppol
4102 : levels_ctqmc(1+(isppol-1)*ndim:tndim+(isppol-1)*ndim,1+(isppol-1)*ndim:tndim+(isppol-1)*ndim) = &
4103 0 : & energy_level%matlu(iatom)%mat(:,:,isppol)
4104 0 : if (nsppol == 1 .and. nspinor == 1) levels_ctqmc(1+ndim:2*ndim,1+ndim:2*ndim) = levels_ctqmc(1:ndim,1:ndim)
4105 : end do ! isppol
4106 :
4107 : ! Need to slice flavor_list to make it size nflavor*nflavor instead of size nflavor_max*nflavor_max
4108 0 : flavor_tmp(:,:) = flavor_list(1:nflavor,1:nflavor,iatom)
4109 :
4110 0 : block_ptr = C_LOC(block_list(:,iatom))
4111 0 : eu_ptr = C_LOC(eu)
4112 0 : flavor_ptr = C_LOC(flavor_tmp(:,:))
4113 0 : fname_data_ptr = C_LOC(fname_data)
4114 0 : fname_dataw_ptr = C_LOC(fname_dataw)
4115 0 : fname_histo_ptr = C_LOC(fname_histo)
4116 0 : ftau_ptr = C_LOC(ftau(iatom)%mat(:,:,:))
4117 0 : gl_ptr = C_LOC(gl(:,:,:))
4118 0 : gtau_ptr = C_LOC(gtau(:,:,:))
4119 0 : inner_ptr = C_LOC(inner_list(:,iatom))
4120 0 : levels_ptr = C_LOC(levels_ctqmc(:,:))
4121 0 : mself_1_ptr = C_LOC(moments_self_1(:))
4122 0 : mself_2_ptr = C_LOC(moments_self_2(:))
4123 0 : occ_ptr = C_LOC(occ(:))
4124 0 : siz_ptr = C_LOC(siz_block(:,iatom))
4125 0 : udens_ptr = C_LOC(udens_rot(iatom)%mat(:,:,1))
4126 0 : vee_ptr = C_LOC(vee_rot(iatom)%mat(:,:,:,:))
4127 :
4128 0 : verbo = 1
4129 :
4130 0 : do ilam=1,ntot
4131 :
4132 0 : if (ilam /= ntot) then
4133 0 : write(message,'(a,3x,a,f6.4,a)') ch10,"== Thermodynamic integration over interaction for lambda= ",lam_list(ilam),ch10
4134 0 : call wrtout(std_out,message,'COLL')
4135 :
4136 : ! Integrate over diagonal electronic levels
4137 0 : do isppol=1,nsppol
4138 0 : do im=1,tndim
4139 0 : iflavor = im + (isppol-1)*ndim
4140 0 : levels_ctqmc(iflavor,iflavor) = energy_level%matlu(iatom)%mat(im,im,isppol) + (lam_list(ilam)-one)*shift_mu
4141 0 : if (nsppol == 1 .and. nspinor == 1) levels_ctqmc(iflavor+ndim,iflavor+ndim) = levels_ctqmc(iflavor,iflavor)
4142 : end do ! im
4143 : end do ! isppol
4144 :
4145 : end if ! ilam/=ntot
4146 :
4147 0 : if (ilam == ntot .and. entropy .and. integral == 1) then
4148 0 : do isppol=1,nsppol
4149 0 : do im=1,tndim
4150 0 : iflavor = im + (isppol-1)*ndim
4151 0 : levels_ctqmc(iflavor,iflavor) = energy_level%matlu(iatom)%mat(im,im,isppol)
4152 0 : if (nsppol == 1 .and. nspinor == 1) levels_ctqmc(iflavor+ndim,iflavor+ndim) = levels_ctqmc(iflavor,iflavor)
4153 : end do ! im
4154 : end do ! isppol
4155 : end if
4156 :
4157 0 : if (ilam == 2) verbo = 0
4158 :
4159 0 : if (ilam < 10) then
4160 0 : write(tag_lam,'("0",i1)') ilam
4161 : else
4162 0 : write(tag_lam,'(i2)') ilam
4163 : end if
4164 :
4165 0 : tag_lam2 = ""
4166 0 : if (ilam /= ntot) tag_lam2 = "_ilam" // tag_lam
4167 :
4168 0 : read_data = paw_dmft%dmft_triqs_read_ctqmcdata
4169 0 : stringfile = "_iatom" // tag_at // trim(adjustl(tag_lam2)) // ".h5"
4170 :
4171 0 : if (paw_dmft%idmftloop == 1) then
4172 0 : read_data = 0
4173 : if (paw_dmft%dmft_triqs_read_ctqmcdata == 1 .and. paw_dmft%ireadctqmcdata == 1) read_data = 1
4174 0 : fname_data = trim(adjustl(paw_dmft%filctqmcdatain)) // stringfile
4175 : else
4176 0 : fname_data = trim(adjustl(paw_dmft%filapp)) // "_CTQMC_DATA" // stringfile
4177 : end if
4178 0 : len_t = len(trim(adjustl(fname_data))) + 1
4179 0 : fname_data(len_t:len_t) = c_null_char
4180 :
4181 0 : fname_dataw = trim(adjustl(paw_dmft%filapp)) // "_CTQMC_DATA" // stringfile
4182 0 : len_t = len(trim(adjustl(fname_dataw))) + 1
4183 0 : fname_dataw(len_t:len_t) = c_null_char
4184 :
4185 0 : fname_histo = trim(adjustl(paw_dmft%filapp)) // "_CTQMC_HISTOGRAM_iatom" // tag_at // trim(adjustl(tag_lam2)) // ".dat"
4186 0 : len_t = len(trim(adjustl(fname_histo))) + 1
4187 0 : fname_histo(len_t:len_t) = c_null_char
4188 :
4189 0 : call flush_unit(std_out)
4190 :
4191 : #if defined HAVE_TRIQS_INTERNAL || defined HAVE_TRIQS_v3_2
4192 : call Ctqmc_triqs_run(rot_inv,leg_measure,paw_dmft%dmft_triqs_move_shift,paw_dmft%dmft_triqs_move_double, &
4193 : & density_matrix,paw_dmft%dmft_triqs_time_invariance,paw_dmft%dmft_triqs_use_norm_as_weight, &
4194 : & debug,merge(integral,0,ilam/=ntot),paw_dmft%dmft_triqs_loc_n_min,paw_dmft%dmft_triqs_loc_n_max, &
4195 : & paw_dmft%dmft_triqs_seed_a,paw_dmft%dmft_triqs_seed_b,nflavor,ntau,nleg, &
4196 : & paw_dmft%dmft_triqs_n_cycles,paw_dmft%dmftctqmc_meas,paw_dmft%dmftqmc_therm, &
4197 : & paw_dmft%dmft_triqs_therm_restart,paw_dmft%dmft_triqs_det_init_size, &
4198 : & paw_dmft%dmft_triqs_det_n_operations_before_check,myproc,nblocks(iatom),read_data,verbo, &
4199 : & paw_dmft%dmft_triqs_chiloc,paw_dmft%dmft_triqs_chiloc_ins,beta,paw_dmft%dmft_triqs_imag_threshold, &
4200 : & paw_dmft%dmft_triqs_det_precision_warning, &
4201 : & paw_dmft%dmft_triqs_det_precision_error,paw_dmft%dmft_triqs_det_singular_threshold,lam_list(ilam), &
4202 : & paw_dmft%dmft_triqs_pauli_prob,chiloc_ptr,magmom_ptr,block_ptr,flavor_ptr,inner_ptr,siz_ptr,ftau_ptr,gtau_ptr,gl_ptr, &
4203 : & udens_ptr,vee_ptr,levels_ptr,mself_1_ptr,mself_2_ptr,occ_ptr,eu_ptr,fname_data_ptr,fname_dataw_ptr, &
4204 : & fname_histo_ptr)
4205 : #endif
4206 :
4207 0 : call flush_unit(std_out)
4208 :
4209 0 : if (ilam == ntot .or. debug) then
4210 :
4211 0 : do isppol=1,nsppol
4212 0 : if (nsppol == 1 .and. nspinor == 1) then
4213 0 : green%oper_tau(1)%matlu(iatom)%mat(:,:,isppol) = (gtau(1,1:ndim,1:ndim)+gtau(1,ndim+1:2*ndim,ndim+1:2*ndim)) * half
4214 : else
4215 0 : green%oper_tau(1)%matlu(iatom)%mat(:,:,isppol) = gtau(1,1+(isppol-1)*ndim:tndim+(isppol-1)*ndim,1+(isppol-1)*ndim:tndim+(isppol-1)*ndim)
4216 : end if
4217 : end do ! isppol
4218 :
4219 0 : if ((.not. leg_measure) .and. density_matrix .and. ilam == ntot) then
4220 :
4221 : ! Constrain the occupations and high-frequency moments with the more accurate values sampled from the CTQMC
4222 :
4223 0 : do isppol=1,nsppol
4224 0 : do im=1,tndim
4225 0 : iflavor = im + (isppol-1)*ndim
4226 :
4227 0 : if (nsppol == 1 .and. nspinor == 1) then
4228 0 : mself_1 = (moments_self_1(iflavor)+moments_self_1(iflavor+ndim)) * half
4229 0 : mself_2 = (moments_self_2(iflavor)+moments_self_2(iflavor+ndim)) * half
4230 : else
4231 0 : mself_1 = moments_self_1(iflavor)
4232 0 : mself_2 = moments_self_2(iflavor)
4233 : end if
4234 :
4235 0 : green%moments(2)%matlu(iatom)%mat(im,im,isppol) = energy_level%matlu(iatom)%mat(im,im,isppol) + mself_1
4236 0 : green%moments(3)%matlu(iatom)%mat(im,im,isppol) = weiss%moments(2)%matlu(iatom)%mat(im,im,isppol) + mself_2
4237 :
4238 : end do ! im
4239 :
4240 : ! Use matmul in prevision of the day where the off-diagonal density matrix will be available
4241 : green%moments(3)%matlu(iatom)%mat(:,:,isppol) = green%moments(3)%matlu(iatom)%mat(:,:,isppol) + &
4242 0 : & matmul(green%moments(2)%matlu(iatom)%mat(:,:,isppol),green%moments(2)%matlu(iatom)%mat(:,:,isppol))
4243 :
4244 : end do ! isppol
4245 :
4246 : end if ! not leg and density_matrix
4247 :
4248 0 : if (density_matrix) then
4249 :
4250 0 : green%ecorr_qmc(iatom) = dble(eu)
4251 :
4252 0 : do isppol=1,nsppol
4253 0 : do im=1,tndim
4254 0 : iflavor = im + (isppol-1)*ndim
4255 :
4256 0 : if (nsppol == 1 .and. nspinor == 1) then
4257 0 : occ_tmp = (occ(iflavor)+occ(iflavor+ndim)) * half
4258 : else
4259 0 : occ_tmp = occ(iflavor)
4260 : end if
4261 :
4262 0 : green%oper_tau(1)%matlu(iatom)%mat(im,im,isppol) = occ_tmp - cone
4263 :
4264 : end do ! im
4265 : end do ! isppol
4266 :
4267 : end if ! density_matrix
4268 :
4269 0 : if (ilam < ntot) then
4270 0 : call occup_green_tau(green)
4271 :
4272 0 : write(message,'(a,3x,a)') ch10,"== Print Occupation matrix in CTQMC basis"
4273 0 : call wrtout(std_out,message,"COLL")
4274 0 : call print_matlu(green%occup_tau%matlu(:),natom,1)
4275 : end if
4276 :
4277 0 : if (leg_measure) then
4278 :
4279 0 : ABI_MALLOC(gl_tmp,(nleg,tndim,tndim,nsppol))
4280 0 : ABI_MALLOC(jbes,(nleg))
4281 :
4282 0 : gl_tmp(:,:,:,:) = czero
4283 :
4284 0 : do ifreq=1,nwlo
4285 0 : green%oper(ifreq)%matlu(iatom)%mat(:,:,:) = czero
4286 0 : xx = dble(2*ifreq-1) * pi / two
4287 0 : if (xx <= dble(100)) then
4288 0 : call sbf8(nleg,xx,jbes(:))
4289 : end if
4290 0 : do isppol=1,nsppol
4291 0 : do im1=1,tndim
4292 0 : iflavor1 = im1 + (isppol-1)*ndim
4293 0 : do im=1,tndim
4294 0 : iflavor = im + (isppol-1)*ndim
4295 0 : do ileg=1,nleg
4296 0 : if (xx >= dble(99)) then
4297 0 : call jbessel(jbes(ileg),besp,bespp,ileg-1,1,xx)
4298 : end if
4299 0 : u_nl = sqrt(dble(2*ileg-1))*(-1)**(ifreq-1)*(j_dpc**(ileg))*jbes(ileg)
4300 0 : if (nsppol == 1 .and. nspinor == 1) then
4301 : gl_tmp(ileg,im,im1,isppol) = &
4302 0 : & (gl(ileg,iflavor,iflavor1)+gl(ileg,iflavor+ndim,iflavor1+ndim))*half
4303 : else
4304 0 : gl_tmp(ileg,im,im1,isppol) = gl(ileg,iflavor,iflavor1)
4305 : end if
4306 : green%oper(ifreq)%matlu(iatom)%mat(im,im1,isppol) = &
4307 : & green%oper(ifreq)%matlu(iatom)%mat(im,im1,isppol) + &
4308 0 : & u_nl*gl_tmp(ileg,im,im1,isppol)
4309 : end do ! ileg
4310 : end do ! im
4311 : end do ! im1
4312 : end do ! isppol
4313 : end do ! ifreq
4314 :
4315 0 : ABI_FREE(jbes)
4316 :
4317 0 : ABI_MALLOC(gtau_leg,(ntau,nflavor,nflavor))
4318 0 : ABI_MALLOC(leg_array,(nleg,ntau))
4319 :
4320 0 : do itau=1,ntau
4321 0 : tau = dble(itau-1) * beta / (ntau-1)
4322 0 : xtau = two*tau/beta - one
4323 0 : leg_array(1,itau) = one
4324 0 : leg_array(2,itau) = xtau
4325 0 : do ileg=3,nleg
4326 : leg_array(ileg,itau) = (dble(2*(ileg-2)+1)*xtau*leg_array(ileg-1,itau)- &
4327 0 : & dble(ileg-2)*leg_array(ileg-2,itau)) / dble(ileg-1)
4328 : end do ! ileg
4329 : end do ! itau
4330 :
4331 0 : gtau_leg(:,:,:) = czero
4332 0 : do iflavor1=1,nflavor
4333 0 : do iflavor=1,nflavor
4334 0 : do itau=1,ntau
4335 0 : do ileg=1,nleg
4336 : gtau_leg(itau,iflavor,iflavor1) = gtau_leg(itau,iflavor,iflavor1) + &
4337 0 : & gl(ileg,iflavor,iflavor1)*leg_array(ileg,itau)*sqrt(dble(2*ileg-1))/beta
4338 : end do ! ileg
4339 : end do ! itau
4340 : end do ! iflavor
4341 : end do ! iflavor1
4342 :
4343 0 : if (myproc == 0 .and. off_diag) then
4344 :
4345 0 : if (open_file(trim(paw_dmft%filapp)//"_Gtau_offdiag_Leg_iatom"//tag_at//trim(adjustl(tag_lam2))//".dat",message,newunit=unt) /= 0) ABI_ERROR(message)
4346 0 : write(unt,'(6a)') "# Off-diagonal components of Legendre-sampled G(tau) in the CTQMC basis",ch10, &
4347 0 : & "# Columns are ordered this way:",ch10, &
4348 0 : & "# Imaginary Time ((Re(G_{ij}) Im(G_{ij}),i=1,2*(2*l+1)),j=1,2*(2*l+1)) where the", &
4349 0 : & " leftmost index varies first"
4350 0 : do itau=1,ntau
4351 0 : write(unt,'(2x,393(e18.10e3,2x))') beta*dble(itau-1)/dble(ntau-1), &
4352 0 : & ((dble(gtau_leg(itau,im,im1)),aimag(gtau_leg(itau,im,im1)),im=1,nflavor),im1=1,nflavor)
4353 : end do ! itau
4354 0 : close(unt)
4355 :
4356 : end if ! myproc=0
4357 :
4358 0 : if (myproc == 0) then
4359 :
4360 0 : if (open_file(trim(paw_dmft%filapp)//"_Gtau_diag_Leg_iatom"//tag_at//trim(adjustl(tag_lam2))//".dat",message,newunit=unt) /= 0) ABI_ERROR(message)
4361 0 : write(unt,'(5a)') "# Diagonal components of Legendre-sampled G(tau) in the CTQMC basis",ch10, &
4362 0 : & "# Columns are ordered this way:",ch10, &
4363 0 : & "# Imaginary Time (G_{ii},i=1,2*(2*l+1))"
4364 0 : do itau=1,ntau
4365 0 : write(unt,'(2x,393(e25.17e3,2x))') beta*dble(itau-1)/dble(ntau-1),(dble(gtau_leg(itau,im,im)),im=1,nflavor)
4366 : end do ! itau
4367 0 : close(unt)
4368 :
4369 : end if ! myproc=0
4370 :
4371 0 : ABI_FREE(gtau_leg)
4372 0 : ABI_FREE(leg_array)
4373 :
4374 0 : ABI_MALLOC(t_lp,(nleg,green%nmoments))
4375 :
4376 0 : fact = one ! this is equal to (p-1)!
4377 :
4378 : ! Compute analytical moments of Fourier transform of Legendre polynomial
4379 : ! (equation (E2) of PRB, 84(7), 2011, Boehnke et al)
4380 0 : do p=1,green%nmoments
4381 0 : if (p > 1) fact = fact * dble(p-1)
4382 0 : fact2 = fact
4383 0 : do l=0,nleg-1
4384 0 : if (l > 0) fact2 = fact2 * dble(l+p-1)
4385 0 : if (p > l+1) then
4386 0 : t_lp(l+1,p) = zero
4387 : else
4388 0 : if (l-p+1 > 0) fact2 = fact2 / dble(l-p+1) ! fact2 is now equal to (l+p-1)...(l-p+2)
4389 0 : if (mod(p+l,2) == 0) then
4390 0 : t_lp(l+1,p) = zero
4391 : else
4392 0 : t_lp(l+1,p) = (-1)**p * two * sqrt(dble(2*l+1)) * fact2 / fact
4393 : end if
4394 : end if ! p>l+1
4395 : end do ! l
4396 0 : do isppol=1,nsppol
4397 0 : do im1=1,tndim
4398 0 : do im=1,tndim
4399 : ! Do not use DOT_PRODUCT
4400 0 : green%moments(p)%matlu(iatom)%mat(im,im1,isppol) = sum(t_lp(:,p)*gl_tmp(:,im,im1,isppol)) / beta**p
4401 : end do ! im
4402 : end do ! im1
4403 : end do ! isppol
4404 : end do ! p
4405 :
4406 0 : ABI_FREE(gl_tmp)
4407 0 : ABI_FREE(t_lp)
4408 :
4409 0 : else if (ilam == ntot) then
4410 :
4411 0 : ABI_MALLOC(gl_dlr,(ndlr,tndim,tndim,nsppol))
4412 0 : ABI_MALLOC(gl_dlr_re,(ndlr))
4413 0 : ABI_MALLOC(gl_dlr_im,(ndlr))
4414 0 : ABI_MALLOC(bdlr,(ntau))
4415 0 : ABI_MALLOC(gtau_dlr,(ntau,nflavor,nflavor))
4416 0 : ABI_MALLOC(moment_fit,(green%nmoments))
4417 :
4418 0 : gtau_dlr(:,:,:) = czero
4419 :
4420 0 : call fit_dlr()
4421 :
4422 0 : if (myproc == 0 .and. off_diag) then
4423 :
4424 0 : if (open_file(trim(paw_dmft%filapp)//"_Gtau_offdiag_DLR_iatom"//tag_at//trim(adjustl(tag_lam2))//".dat",message,newunit=unt) /= 0) ABI_ERROR(message)
4425 0 : write(unt,'(6a)') "# Off-diagonal components of DLR fit of G(tau) in the CTQMC basis",ch10, &
4426 0 : & "# Columns are ordered this way:",ch10, &
4427 0 : & "# Imaginary Time ((Re(G_{ij}) Im(G_{ij}),i=1,2*(2*l+1)),j=1,2*(2*l+1)) where the", &
4428 0 : & " leftmost index varies first"
4429 :
4430 0 : do itau=1,ntau
4431 0 : write(unt,'(2x,393(e18.10e3,2x))') beta*dble(itau-1)/dble(ntau-1), &
4432 0 : & ((dble(gtau_dlr(itau,im,im1)),aimag(gtau_dlr(itau,im,im1)),im=1,nflavor),im1=1,nflavor)
4433 : end do ! itau
4434 0 : close(unt)
4435 :
4436 : end if ! myproc=0 and off_diag
4437 :
4438 0 : if (myproc == 0) then
4439 :
4440 0 : if (open_file(trim(paw_dmft%filapp)//"_Gtau_diag_DLR_iatom"//tag_at//trim(adjustl(tag_lam2))//".dat",message,newunit=unt) /= 0) ABI_ERROR(message)
4441 0 : write(unt,'(5a)') "# Diagonal components of DLR fit of G(tau) in the CTQMC basis",ch10, &
4442 0 : & "# Columns are ordered this way:",ch10, &
4443 0 : & "# Imaginary Time (G_{ii},i=1,2*(2*l+1))"
4444 0 : do itau=1,ntau
4445 0 : write(unt,'(2x,393(e25.17e3,2x))') beta*dble(itau-1)/dble(ntau-1),(dble(gtau_dlr(itau,im,im)),im=1,nflavor)
4446 : end do ! itau
4447 0 : close(unt)
4448 :
4449 : end if ! myproc
4450 :
4451 0 : ABI_FREE(gl_dlr)
4452 0 : ABI_FREE(gl_dlr_re)
4453 0 : ABI_FREE(gl_dlr_im)
4454 0 : ABI_FREE(bdlr)
4455 0 : ABI_FREE(gtau_dlr)
4456 0 : ABI_FREE(moment_fit)
4457 :
4458 : end if ! leg_measure
4459 :
4460 0 : if (myproc == 0 .and. paw_dmft%dmft_triqs_chiloc > 0) then
4461 0 : if (open_file(trim(paw_dmft%filapp)//"_LocalSusceptibility.dat",message,newunit=unt,status='unknown',form='formatted') /= 0) ABI_ERROR(message)
4462 0 : do itau=1,ntau
4463 0 : write(unt,*) beta * DBLE(itau-1) / DBLE(ntau), (chiloc_tmp(itau,1))
4464 : end do
4465 0 : close(unt)
4466 : end if
4467 :
4468 0 : if (myproc == 0 .and. off_diag) then
4469 :
4470 0 : if (open_file(trim(paw_dmft%filapp)//"_Gtau_offdiag_iatom"//tag_at//trim(adjustl(tag_lam2))//".dat",message,newunit=unt) /= 0) ABI_ERROR(message)
4471 0 : write(unt,'(6a)') "# Off-diagonal components of binned G(tau) in the CTQMC basis",ch10, &
4472 0 : & "# Columns are ordered this way:",ch10, &
4473 0 : & "# Imaginary Time ((Re(G_{ij}) Im(G_{ij}),i=1,2*(2*l+1)),j=1,2*(2*l+1)) where the", &
4474 0 : & " leftmost index varies first"
4475 :
4476 0 : do itau=1,ntau
4477 0 : write(unt,'(2x,393(e18.10e3,2x))') beta*dble(itau-1)/dble(ntau-1), &
4478 0 : & ((dble(gtau(itau,im,im1)),aimag(gtau(itau,im,im1)),im=1,nflavor),im1=1,nflavor)
4479 : end do ! itau
4480 0 : close(unt)
4481 :
4482 : end if ! myproc
4483 :
4484 0 : if (myproc == 0) then
4485 :
4486 0 : if (open_file(trim(paw_dmft%filapp)//"_Gtau_diag_iatom"//tag_at//trim(adjustl(tag_lam2))//".dat",message,newunit=unt) /= 0) ABI_ERROR(message)
4487 0 : write(unt,'(5a)') "# Diagonal components of binned G(tau) in the CTQMC basis",ch10, &
4488 0 : & "# Columns are ordered this way:",ch10, &
4489 0 : & "# Imaginary Time (G_{ii},i=1,2*(2*l+1))"
4490 0 : do itau=1,ntau
4491 0 : write(unt,'(2x,393(e25.17e3,2x))') beta*dble(itau-1)/dble(ntau-1),(dble(gtau(itau,im,im)),im=1,nflavor)
4492 : end do ! itau
4493 0 : close(unt)
4494 :
4495 : end if ! myproc
4496 :
4497 0 : if (entropy .and. ilam == ntot) then
4498 :
4499 0 : call compute_migdal_energy(emig(:),emig_tot,green,paw_dmft,hybmwdhyb,iatom=iatom)
4500 0 : green%ekin_imp = green%ekin_imp + two*emig_tot
4501 :
4502 : end if ! entropy
4503 :
4504 : end if ! ilam=ntot or debug
4505 :
4506 0 : if (integral > 0 .and. ilam < ntot .and. entropy) then
4507 :
4508 0 : elam = dble(eu)
4509 :
4510 0 : do isppol=1,nsppol
4511 0 : do im=1,tndim
4512 0 : iflavor = im + (isppol-1)*ndim
4513 :
4514 0 : if (nsppol == 1 .and. nspinor == 1) then
4515 0 : occ_tmp = occ(iflavor) + occ(iflavor+ndim)
4516 : else
4517 0 : occ_tmp = occ(iflavor)
4518 : end if
4519 0 : elam = elam + dble(shift_mu*occ_tmp)
4520 : end do ! im
4521 : end do ! isppol
4522 :
4523 0 : i = mod(ilam-1,ngauss) + 1
4524 0 : green%integral = green%integral + tweights(i)*elam*dx*half
4525 0 : elam_list(ilam) = elam
4526 :
4527 : end if ! integral and ilam<ntot and entropy
4528 :
4529 0 : if (integral > 0 .and. ilam == ntot-1 .and. entropy) then
4530 0 : write(message,'(a,3(3x,2a),a,12x,a,6x,2a,8x,a)') ch10,repeat("=",39),ch10,"== Summary of thermodynamic integration", &
4531 0 : & ch10,repeat("=",39),ch10,ch10,"Lambda","<dH/dlambda>",ch10,repeat("-",29)
4532 0 : call wrtout(std_out,message,'COLL')
4533 0 : do i=1,ntot-1
4534 0 : write(tag_lambda,'(f14.4)') lam_list(i)
4535 0 : write(tag_elam,'(f14.4)') elam_list(i)
4536 0 : tag_lambda = adjustl(tag_lambda)
4537 0 : tag_elam = adjustl(tag_elam)
4538 0 : pad_lambda = (14-len_trim(tag_lambda)) / 2
4539 0 : pad_elam = (14-len_trim(tag_elam)) / 2
4540 0 : write(message,'(8x,2(3a,1x),a,8x,a)') repeat(" ",pad_lambda),trim(tag_lambda),repeat(" ",14-pad_lambda-len_trim(tag_lambda)), &
4541 0 : & repeat(" ",pad_elam),trim(tag_elam),repeat(" ",14-pad_elam-len_trim(tag_elam)),ch10,repeat("-",29)
4542 0 : call wrtout(std_out,message,'COLL')
4543 : end do ! i
4544 0 : write(message,'(a,3x,a,f10.4,a)') ch10,"--> Integral is: ",green%integral,ch10
4545 0 : call wrtout(std_out,message,'COLL')
4546 : end if ! integral and ilam=ntot-1 and entropy
4547 :
4548 : end do ! ilam
4549 :
4550 0 : ABI_FREE(flavor_tmp)
4551 0 : ABI_FREE(gtau)
4552 0 : ABI_FREE(levels_ctqmc)
4553 0 : ABI_SFREE(gl)
4554 0 : ABI_SFREE(moments_self_1)
4555 0 : ABI_SFREE(moments_self_2)
4556 0 : ABI_SFREE(occ)
4557 :
4558 0 : if (paw_dmft%dmft_triqs_chiloc > 0) then
4559 0 : ABI_FREE(chiloc_tmp)
4560 :
4561 0 : if (basis .eq. 4) then
4562 : !do iatom=1,natom
4563 0 : lpawu = paw_dmft%lpawu(iatom)
4564 0 : if (lpawu == -1) cycle
4565 0 : ABI_FREE(magmom_tot(iatom)%value)
4566 : !end do
4567 0 : ABI_FREE(magmom_tot)
4568 0 : ABI_FREE(magmom_array)
4569 0 : ABI_FREE(matlumag_tot)
4570 0 : magmom_ptr = C_NULL_PTR
4571 : end if
4572 : end if
4573 :
4574 : end do ! iatom
4575 :
4576 0 : ABI_FREE(elam_list)
4577 0 : ABI_FREE(lam_list)
4578 :
4579 0 : ABI_SFREE(tweights)
4580 0 : ABI_SFREE(tpoints)
4581 :
4582 0 : call occup_green_tau(green)
4583 :
4584 0 : write(message,'(a,3x,a)') ch10,"== Print Occupation matrix in CTQMC basis"
4585 0 : call wrtout(std_out,message,"COLL")
4586 0 : call print_matlu(green%occup_tau%matlu(:),natom,1)
4587 :
4588 0 : if (basis > 0) then
4589 0 : write(message,'(a,3x,a)') ch10,"== Rotating back to cubic basis"
4590 0 : call wrtout(std_out,message,"COLL")
4591 : end if
4592 :
4593 : ! Build back Weiss field
4594 0 : do ifreq=1,nwlo
4595 0 : shift(:) = cmplx(zero,paw_dmft%omega_lo(ifreq),kind=dp)
4596 0 : call add_matlu(weiss%oper(ifreq)%matlu(:),energy_level%matlu(:),matlu_tmp(:),natom,1)
4597 0 : call copy_matlu(matlu_tmp(:),weiss%oper(ifreq)%matlu(:),natom)
4598 0 : call shift_matlu(weiss%oper(ifreq)%matlu(:),natom,shift(:))
4599 0 : call fac_matlu(weiss%oper(ifreq)%matlu(:),natom,-cone)
4600 : end do ! ifreq
4601 :
4602 0 : if (basis > 0) then
4603 0 : if (basis == 1 .or. basis == 2) then
4604 0 : call rotate_matlu(energy_level%matlu(:),eigvectmatlu(:),natom,0)
4605 0 : else if (basis == 4) then
4606 0 : call ylm2jmj_matlu(energy_level%matlu(:),natom,2,paw_dmft)
4607 : end if ! basis /= 3
4608 0 : call slm2ylm_matlu(energy_level%matlu(:),natom,paw_dmft,2,0)
4609 0 : do i=2,weiss%nmoments-1
4610 0 : if (basis == 1 .or. basis == 2) then
4611 0 : call rotate_matlu(weiss%moments(i)%matlu(:),eigvectmatlu(:),natom,0)
4612 0 : else if (basis == 4) then
4613 0 : call ylm2jmj_matlu(weiss%moments(i)%matlu(:),natom,2,paw_dmft)
4614 : end if
4615 0 : call slm2ylm_matlu(weiss%moments(i)%matlu(:),natom,paw_dmft,2,0)
4616 : end do ! i
4617 0 : do i=1,green%nmoments
4618 0 : if (basis == 1 .or. basis == 2) then
4619 0 : call rotate_matlu(green%moments(i)%matlu(:),eigvectmatlu(:),natom,0)
4620 0 : else if (basis == 4) then
4621 0 : call ylm2jmj_matlu(green%moments(i)%matlu(:),natom,2,paw_dmft)
4622 : end if
4623 0 : call slm2ylm_matlu(green%moments(i)%matlu(:),natom,paw_dmft,2,0)
4624 : end do ! i
4625 0 : do ifreq=1,nwlo
4626 0 : if (green%distrib%procf(ifreq) /= myproc) cycle
4627 0 : if (basis == 1 .or. basis == 2) then
4628 0 : call rotate_matlu(weiss%oper(ifreq)%matlu(:),eigvectmatlu(:),natom,0)
4629 0 : call rotate_matlu(green%oper(ifreq)%matlu(:),eigvectmatlu(:),natom,0)
4630 0 : else if (basis == 4) then
4631 0 : call ylm2jmj_matlu(weiss%oper(ifreq)%matlu(:),natom,2,paw_dmft)
4632 0 : call ylm2jmj_matlu(green%oper(ifreq)%matlu(:),natom,2,paw_dmft)
4633 : end if
4634 0 : call slm2ylm_matlu(weiss%oper(ifreq)%matlu(:),natom,paw_dmft,2,0)
4635 0 : call slm2ylm_matlu(green%oper(ifreq)%matlu(:),natom,paw_dmft,2,0)
4636 : end do ! ifreq
4637 0 : if (basis == 1 .or. basis == 2) then
4638 0 : call rotate_matlu(green%occup_tau%matlu(:),eigvectmatlu(:),natom,0)
4639 0 : else if (basis == 4) then
4640 0 : call ylm2jmj_matlu(green%occup_tau%matlu(:),natom,2,paw_dmft)
4641 : end if
4642 0 : call slm2ylm_matlu(green%occup_tau%matlu(:),natom,paw_dmft,2,0)
4643 : end if! basis > 0
4644 :
4645 : ! Since we possibly neglected some off-diagonal elements and imaginary part,
4646 : ! the levels and hybridization might not be symmetrized anymore
4647 0 : call sym_matlu(energy_level%matlu(:),paw_dmft)
4648 0 : do i=2,weiss%nmoments-1
4649 0 : call sym_matlu(weiss%moments(i)%matlu(:),paw_dmft)
4650 : end do ! i
4651 0 : do i=1,green%nmoments
4652 0 : call sym_matlu(green%moments(i)%matlu(:),paw_dmft)
4653 : end do ! i
4654 0 : do ifreq=1,nwlo
4655 0 : if (green%distrib%procf(ifreq) /= myproc) cycle
4656 0 : call sym_matlu(weiss%oper(ifreq)%matlu(:),paw_dmft)
4657 0 : call sym_matlu(green%oper(ifreq)%matlu(:),paw_dmft)
4658 : end do ! ifreq
4659 0 : call copy_matlu(green%occup_tau%matlu(:),dmat_ctqmc(:),natom)
4660 0 : call sym_matlu(green%occup_tau%matlu(:),paw_dmft)
4661 :
4662 0 : call diff_matlu("CTQMC occupations","Symmetrized CTQMC occupations",dmat_ctqmc(:),green%occup_tau%matlu(:),natom,0,tol4)
4663 :
4664 0 : call gather_oper(weiss%oper(:),weiss%distrib,paw_dmft,opt_ksloc=2)
4665 0 : call gather_oper(green%oper(:),green%distrib,paw_dmft,opt_ksloc=2)
4666 :
4667 0 : call compute_moments_loc(green,self_new,energy_level,weiss,1,opt_log=paw_dmft%dmft_triqs_entropy,shift_mu=shift_mu)
4668 :
4669 0 : if (entropy .and. integral > 0) then
4670 0 : call compute_trace_log_loc(weiss,paw_dmft,green%fband_weiss,opt_inv=1)
4671 : end if
4672 :
4673 0 : call destroy_matlu(dmat_ctqmc(:),natom)
4674 0 : call destroy_matlu(eigvectmatlu(:),natom)
4675 0 : call destroy_matlu(ftau(:),natom)
4676 0 : call destroy_matlu(matlu_tmp(:),natom)
4677 0 : call destroy_matlu(udens_rot(:),natom)
4678 :
4679 0 : call destroy_oper(energy_level)
4680 :
4681 0 : call destroy_vee(paw_dmft,vee_rot(:))
4682 :
4683 0 : ABI_FREE(block_list)
4684 0 : ABI_FREE(dmat_ctqmc)
4685 0 : ABI_FREE(eigvectmatlu)
4686 0 : ABI_FREE(flavor_list)
4687 0 : ABI_FREE(ftau)
4688 0 : ABI_FREE(inner_list)
4689 0 : ABI_FREE(matlu_tmp)
4690 0 : ABI_FREE(nblocks)
4691 0 : ABI_FREE(shift)
4692 0 : ABI_FREE(siz_block)
4693 0 : ABI_FREE(udens_rot)
4694 0 : ABI_FREE(vee_rot)
4695 :
4696 0 : ABI_SFREE(adlr)
4697 0 : ABI_SFREE(adlr_iw)
4698 0 : ABI_SFREE(emig)
4699 0 : ABI_SFREE(wdlr)
4700 0 : ABI_SFREE(wdlr_beta)
4701 :
4702 0 : if (entropy) then
4703 0 : call destroy_self(hybmwdhyb)
4704 : end if
4705 :
4706 : contains
4707 :
4708 0 : subroutine cubic_spline()
4709 :
4710 : !Arguments ------------------------------------
4711 : !Local variables ------------------------------
4712 0 : complex(dp), allocatable :: y(:),yp(:)
4713 : ! ************************************************************************
4714 :
4715 0 : ABI_MALLOC(y,(nwlo))
4716 0 : ABI_MALLOC(yp,(nwlo))
4717 :
4718 0 : do iatom=1,natom
4719 0 : lpawu = paw_dmft%lpawu(iatom)
4720 0 : if (lpawu == -1) cycle
4721 0 : tndim = nspinor * (2*lpawu+1)
4722 0 : do isppol=1,nsppol
4723 0 : do im1=1,tndim
4724 0 : do im=1,tndim
4725 0 : do ifreq=1,nwlo
4726 0 : y(ifreq) = weiss%oper(ifreq)%matlu(iatom)%mat(im,im1,isppol)
4727 : end do ! ifreq
4728 : ! Boundary condition not-a-knot seems to get the best results
4729 0 : call spline2_complex(paw_dmft%omega_lo(:),y(:),nwlo,yp(:),czero,czero,3,3)
4730 0 : do ifreq=1,nwlo
4731 : hybmwdhyb%oper(ifreq)%matlu(iatom)%mat(im,im1,isppol) = &
4732 : & energy_level%matlu(iatom)%mat(im,im1,isppol) + y(ifreq) - &
4733 0 : & paw_dmft%omega_lo(ifreq)*yp(ifreq)
4734 : end do ! ifreq
4735 : end do ! im
4736 : end do ! im1
4737 : end do ! isppol
4738 : end do ! iatom
4739 :
4740 0 : ABI_FREE(y)
4741 0 : ABI_FREE(yp)
4742 :
4743 0 : end subroutine cubic_spline
4744 :
4745 0 : subroutine fit_dlr()
4746 :
4747 : !Arguments ------------------------------------
4748 : !Local variables ------------------------------
4749 : ! ************************************************************************
4750 :
4751 0 : do isppol=1,nsppol
4752 0 : do im1=1,tndim
4753 0 : iflavor1 = im1 + (isppol-1)*ndim
4754 0 : do im=1,tndim
4755 0 : iflavor = im + (isppol-1)*ndim
4756 :
4757 0 : ncon = merge(merge(4,3,iflavor==iflavor1),1,density_matrix)
4758 0 : nmoments = merge(3,1,density_matrix)
4759 0 : if (nsppol == 1 .and. nspinor == 1) gtau(:,iflavor,iflavor1) = &
4760 0 : & (gtau(:,iflavor,iflavor1)+gtau(:,iflavor+ndim,iflavor1+ndim)) * half
4761 0 : occ_tmp = green%oper_tau(1)%matlu(iatom)%mat(im,im1,isppol)
4762 :
4763 0 : bdlr(:) = dble(gtau(:,iflavor,iflavor1))
4764 :
4765 0 : do i=1,nmoments
4766 0 : moment_fit(i) = dble(green%moments(i)%matlu(iatom)%mat(im,im1,isppol))
4767 : end do ! i
4768 :
4769 0 : call slsqp_wrapper(ncon,ndlr,lsq_g,con_moments,jac_lsq_g,jac_con_moments,gl_dlr_re(:))
4770 :
4771 0 : if (density_matrix) ncon = 3
4772 :
4773 0 : bdlr(:) = aimag(gtau(:,iflavor,iflavor1))
4774 0 : do i=1,nmoments
4775 0 : moment_fit(i) = aimag(green%moments(i)%matlu(iatom)%mat(im,im1,isppol))
4776 : end do ! i
4777 :
4778 0 : call slsqp_wrapper(ncon,ndlr,lsq_g,con_moments,jac_lsq_g,jac_con_moments,gl_dlr_im(:))
4779 :
4780 0 : gl_dlr(:,im,im1,isppol) = cmplx(gl_dlr_re(:),gl_dlr_im(:),kind=dp)
4781 :
4782 : ! Do not use DOT_PRODUCT
4783 0 : green%moments(1)%matlu(iatom)%mat(im,im1,isppol) = sum(gl_dlr(:,im,im1,isppol))
4784 0 : do i=2,green%nmoments
4785 0 : green%moments(i)%matlu(iatom)%mat(im,im1,isppol) = sum(gl_dlr(:,im,im1,isppol)*wdlr_beta(:,i-1))
4786 : end do ! i
4787 :
4788 0 : do itau=1,ntau
4789 : ! Do not use DOT_PRODUCT
4790 0 : gtau_dlr(itau,iflavor,iflavor1) = sum(gl_dlr(:,im,im1,isppol)*adlr(:,itau))
4791 : end do ! itau
4792 0 : if (nsppol == 1 .and. nspinor == 1) gtau_dlr(:,iflavor+ndim,iflavor1+ndim) = gtau_dlr(:,iflavor,iflavor1)
4793 :
4794 : end do ! im
4795 : end do ! im1
4796 : end do ! isppol
4797 :
4798 0 : do ifreq=1,nwlo
4799 0 : do isppol=1,nsppol
4800 0 : do im1=1,tndim
4801 0 : do im=1,tndim
4802 : ! Do not use DOT_PRODUCT
4803 0 : green%oper(ifreq)%matlu(iatom)%mat(im,im1,isppol) = sum(gl_dlr(:,im,im1,isppol)*adlr_iw(:,ifreq))
4804 : end do ! im
4805 : end do ! im1
4806 : end do ! isppol
4807 : end do ! ifreq
4808 :
4809 0 : end subroutine fit_dlr
4810 :
4811 0 : subroutine diag_block(matlu)
4812 :
4813 : !Arguments ------------------------------------
4814 : type(matlu_type), intent(inout) :: matlu(natom)
4815 : !Local variables ------------------------------
4816 : integer :: i,iatom,iblock,iflavor,iflavor1,im,im1
4817 : integer :: info,is,j,lpawu,lwork,ndim,sizb,tndim
4818 0 : real(dp), allocatable :: eig(:),rwork(:)
4819 0 : complex(dp), allocatable :: mat_tmp(:,:),work(:)
4820 : ! ************************************************************************
4821 :
4822 0 : is = 1
4823 0 : ABI_MALLOC(eig,(nflavor_max))
4824 0 : ABI_MALLOC(mat_tmp,(nflavor_max,nflavor_max))
4825 0 : ABI_MALLOC(rwork,(3*nflavor_max-2))
4826 0 : ABI_MALLOC(work,(2*nflavor_max-1))
4827 :
4828 0 : do iatom=1,natom
4829 0 : lpawu = paw_dmft%lpawu(iatom)
4830 0 : if (lpawu == -1) cycle
4831 0 : ndim = 2*lpawu + 1
4832 0 : tndim = nspinor * ndim
4833 0 : do iblock=1,nblocks(iatom)
4834 0 : sizb = siz_block(iblock,iatom)
4835 0 : lwork = 2*sizb - 1
4836 0 : do j=1,sizb
4837 0 : iflavor1 = flavor_list(j,iblock,iatom) + 1
4838 0 : im1 = mod(iflavor1-1,tndim) + 1
4839 0 : if (nspinor == 1) then
4840 0 : is = (iflavor1-1)/ndim + 1
4841 0 : if (is > nsppol) exit
4842 : end if
4843 0 : do i=1,sizb
4844 0 : iflavor = flavor_list(i,iblock,iatom) + 1
4845 0 : im = mod(iflavor-1,tndim) + 1
4846 0 : mat_tmp(i,j) = matlu(iatom)%mat(im,im1,is)
4847 0 : matlu(iatom)%mat(im,im1,is) = czero
4848 : end do ! i
4849 : end do ! j
4850 :
4851 0 : if (is > nsppol) cycle
4852 :
4853 : call zheev('v','u',sizb,mat_tmp(:,1:sizb),nflavor_max,eig(1:sizb), &
4854 0 : & work(1:lwork),lwork,rwork(1:3*sizb-2),info)
4855 :
4856 0 : do j=1,sizb
4857 0 : iflavor1 = flavor_list(j,iblock,iatom) + 1
4858 0 : im1 = mod(iflavor1-1,tndim) + 1
4859 0 : matlu(iatom)%mat(im1,im1,is) = cmplx(eig(j),zero,kind=dp)
4860 0 : do i=1,sizb
4861 0 : iflavor = flavor_list(i,iblock,iatom) + 1
4862 0 : im = mod(iflavor-1,tndim) + 1
4863 0 : eigvectmatlu(iatom)%mat(im,im1,is) = mat_tmp(i,j)
4864 : end do ! i
4865 : end do ! j
4866 : end do ! iblock
4867 :
4868 0 : if (pawprtvol >= 3) then
4869 0 : write(tag_at,'(i4)') iatom
4870 0 : do isppol=1,nsppol
4871 0 : write(message,'(4a,i1)') ch10," EIGENVECTORS for atom ",trim(adjustl(tag_at))
4872 0 : if (nspinor == 1) then
4873 0 : write(tag_block4,'(i1)') isppol
4874 0 : message = trim(message) // " and isppol " // tag_block4
4875 : end if
4876 0 : call wrtout(std_out,message,'COLL')
4877 0 : do im=1,tndim
4878 : write(message,'(12(1x,18(1x,"(",f9.3,",",f9.3,")")))') &
4879 0 : & (eigvectmatlu(iatom)%mat(im,im1,isppol),im1=1,tndim)
4880 0 : call wrtout(std_out,message,'COLL')
4881 : end do ! im1
4882 : end do ! isppol
4883 : end if ! pawprtvol>=3
4884 :
4885 : end do ! iatom
4886 :
4887 0 : ABI_FREE(eig)
4888 0 : ABI_FREE(mat_tmp)
4889 0 : ABI_FREE(rwork)
4890 0 : ABI_FREE(work)
4891 :
4892 0 : end subroutine diag_block
4893 :
4894 0 : subroutine lsq_g(gl,err)
4895 :
4896 : !Arguments ------------------------------------
4897 : real(dp), intent(in) :: gl(:)
4898 : real(dp), intent(out) :: err
4899 : !Local variables ------------------------------
4900 : ! ************************************************************************
4901 :
4902 0 : err = zero
4903 0 : do itau=1,ntau
4904 0 : err = err + (dot_product(gl(:),adlr(:,itau))-bdlr(itau))**2
4905 : end do
4906 :
4907 0 : end subroutine lsq_g
4908 :
4909 0 : subroutine jac_lsq_g(gl,jac)
4910 :
4911 : !Arguments ------------------------------------
4912 : real(dp), intent(in) :: gl(:)
4913 : real(dp), intent(inout) :: jac(:)
4914 : !Local variables ------------------------------
4915 : ! ************************************************************************
4916 :
4917 0 : jac(:) = zero
4918 0 : do itau=1,ntau
4919 0 : jac(1:ndlr) = jac(1:ndlr) + (dot_product(gl(:),adlr(:,itau))-bdlr(itau))*adlr(:,itau)
4920 : end do
4921 0 : jac = jac * two
4922 :
4923 0 : end subroutine jac_lsq_g
4924 :
4925 0 : subroutine con_moments(gl,con)
4926 :
4927 : !Arguments ------------------------------------
4928 : real(dp), intent(in) :: gl(:)
4929 : real(dp), intent(inout) :: con(:)
4930 : !Local variables ------------------------------
4931 : ! ************************************************************************
4932 :
4933 0 : con(1) = sum(gl(:)) - moment_fit(1)
4934 0 : if (ncon > 1) then
4935 0 : con(2) = dot_product(gl(:),wdlr_beta(:,1)) - moment_fit(2)
4936 0 : con(3) = dot_product(gl(:),wdlr_beta(:,2)) - moment_fit(3)
4937 0 : if (ncon == 4) con(4) = dot_product(gl(:),adlr(:,1)) - dble(occ_tmp)
4938 : end if ! ncon>1
4939 :
4940 0 : end subroutine con_moments
4941 :
4942 0 : subroutine jac_con_moments(gl,jac_con)
4943 :
4944 : !Arguments ------------------------------------
4945 : real(dp), intent(in) :: gl(:)
4946 : real(dp), intent(inout) :: jac_con(:,:)
4947 : !Local variables ------------------------------
4948 : ! ************************************************************************
4949 :
4950 : ABI_UNUSED(gl(:))
4951 :
4952 0 : jac_con(1,1:ndlr) = one
4953 0 : if (ncon > 1) then
4954 0 : jac_con(2,1:ndlr) = wdlr_beta(:,1)
4955 0 : jac_con(3,1:ndlr) = wdlr_beta(:,2)
4956 0 : if (ncon == 4) jac_con(4,1:ndlr) = adlr(:,1)
4957 : end if ! ncon>1
4958 0 : jac_con(:,ndlr+1) = zero ! not sure if this is necessary, but this is what they do in the SCIPY interface with SLSQP
4959 :
4960 0 : end subroutine jac_con_moments
4961 :
4962 : end subroutine ctqmc_calltriqs_c
4963 : !!***
4964 :
4965 : !!****f* m_forctqmc/k_it
4966 : !! NAME
4967 : !! k_it
4968 : !!
4969 : !! FUNCTION
4970 : !! Computes the imaginary time kernel K(tau,omega).
4971 : !!
4972 : !! INPUTS
4973 : !! tau = imaginary time divided by beta
4974 : !! omega = real frequency multiplied by beta
4975 : !!
4976 : !! OUTPUT
4977 : !!
4978 : !! SOURCE
4979 :
4980 0 : function k_it(tau,omega)
4981 :
4982 : !Arguments ------------------------------------
4983 : real(dp), intent(in) :: tau, omega
4984 : real(dp) :: k_it
4985 : ! *********************************************************************
4986 :
4987 0 : k_it = merge(-exp(-tau*omega)/(one+exp(-omega)),-exp((one-tau)*omega)/(one+exp(omega)),omega>=0)
4988 :
4989 0 : end function k_it
4990 : !!***
4991 :
4992 : !!****f* m_forctqmc/k_iw
4993 : !! NAME
4994 : !! k_iw
4995 : !!
4996 : !! FUNCTION
4997 : !! Computes the imaginary frequency kernel K(iom,omega)
4998 : !!
4999 : !! INPUTS
5000 : !! iom = imaginary part of the Matsubara frequency
5001 : !! omega = real frequency
5002 : !!
5003 : !! OUTPUT
5004 : !!
5005 : !! SOURCE
5006 :
5007 0 : function k_iw(iom,omega)
5008 :
5009 : !Arguments ------------------------------------
5010 : real(dp), intent(in) :: iom,omega
5011 : complex(dp) :: k_iw
5012 : ! *********************************************************************
5013 :
5014 0 : k_iw = cone / (cmplx(zero,iom,kind=dp)-omega)
5015 :
5016 : end function k_iw
5017 : !!***
5018 :
5019 : !!****f* m_forctqmc/slsqp_wrapper
5020 : !! NAME
5021 : !! slsqp_wrapper
5022 : !!
5023 : !! FUNCTION
5024 : !! Optimizes a function with several variables
5025 : !! under several constraints, using the SLSQP algorithm.
5026 : !!
5027 : !! INPUTS
5028 : !! m = number of constraints
5029 : !! n = number of variables
5030 : !! fun = function to optimize
5031 : !! con = constraints
5032 : !! jac = jacobian of the function
5033 : !! jac_con = jacobian of the constraints
5034 : !!
5035 : !! OUTPUT
5036 : !! x(n) = minimizer
5037 : !!
5038 : !! SOURCE
5039 :
5040 0 : subroutine slsqp_wrapper(m,n,fun,con,jac,jac_con,x)
5041 :
5042 : use m_slsqp, only : slsqp
5043 :
5044 : !Arguments ------------------------------------
5045 : integer, intent(in) :: m,n
5046 : real(dp), intent(inout) :: x(n)
5047 :
5048 : interface
5049 :
5050 : subroutine fun(x,f)
5051 : use defs_basis
5052 : real(dp), intent(in) :: x(:)
5053 : real(dp), intent(out) :: f
5054 : end subroutine fun
5055 :
5056 : subroutine con(x,c)
5057 : use defs_basis
5058 : real(dp), intent(in) :: x(:)
5059 : real(dp), intent(inout) :: c(:)
5060 : end subroutine con
5061 :
5062 : subroutine jac(x,g)
5063 : use defs_basis
5064 : real(dp), intent(in) :: x(:)
5065 : real(dp), intent(inout) :: g(:)
5066 : end subroutine jac
5067 :
5068 : subroutine jac_con(x,a)
5069 : use defs_basis
5070 : real(dp), intent(in) :: x(:)
5071 : real(dp), intent(inout) :: a(:,:)
5072 : end subroutine jac_con
5073 :
5074 : end interface
5075 : !Local variables ------------------------------
5076 : integer :: i,iexact,incons,ireset,iter,itermx,l_jw,l_w,la
5077 : integer :: line,maxiter,meq,mineq,mode,n1,n2,n3
5078 : real(dp) :: f,acc,alpha,f0,gs,h1,h2,h3,h4,t,t0,tol
5079 0 : real(dp) :: c(max(m,1)),g(n+1),xl(n),xu(n)
5080 0 : real(dp) :: a(max(m,1),n+1)
5081 0 : real(dp), allocatable :: w(:)
5082 0 : integer, allocatable :: jw(:)
5083 : ! ************************************************************************
5084 :
5085 0 : maxiter = 10000
5086 0 : meq = m ! all constraints are equality constraints here
5087 0 : la = max(m,1)
5088 0 : x(:) = zero ; xl(:) = zero ; xu(:) = zero
5089 0 : xl(:) = xl(:) / zero ! set lower and upper bounds to NaN (very important, this is how slsqp recognizes that no bounds should be applied)
5090 0 : xu(:) = xu(:) / zero
5091 :
5092 0 : call fun(x(:),f)
5093 0 : call con(x(:),c(:))
5094 0 : call jac(x(:),g(:))
5095 0 : call jac_con(x(:),a(:,:))
5096 0 : acc = tol8 ! best not to overconverge the result, in order to avoid overfitting
5097 0 : iter = maxiter
5098 0 : mode = 0
5099 : n1 = n + 1
5100 0 : mineq = m - meq + 2*n1
5101 : l_w = (3*n1+m)*(n1+1) + (n1-meq+1)*(mineq+2) + 2*mineq & ! as recommended
5102 0 : & +(n1+mineq)*(n1-meq) + 2*meq + n1 + n1*n/2 + 2*m + 3*n + 3*n1 + 1
5103 0 : ABI_MALLOC(w,(l_w))
5104 0 : w = zero
5105 0 : l_jw = mineq ! as recommended
5106 0 : ABI_MALLOC(jw,(l_jw))
5107 0 : jw = 0 ; alpha = zero ; f0 = zero
5108 0 : gs = zero ; h1 = zero ; h2 = zero
5109 0 : h3 = zero ; h4 = zero ; t = zero
5110 0 : t0 = zero ; tol = zero ; iexact = 0
5111 0 : incons = 0 ; ireset = 0 ; itermx = 0
5112 0 : line = 0 ; n1 = 0 ; n2 = 0 ; n3 = 0
5113 :
5114 0 : do i=1,maxiter
5115 :
5116 : call slsqp(m,meq,la,n,x(:),xl(:),xu(:),f,c(:),g(:),a(:,:),acc,iter,mode,w(:),l_w, &
5117 : & jw(:),l_jw,alpha,f0,gs,h1,h2,h3,h4,t,t0,tol,iexact,incons,ireset,itermx, &
5118 0 : & line,n1,n2,n3)
5119 :
5120 0 : if (abs(mode) /= 1) exit
5121 0 : if (mode == -1) then
5122 0 : call jac(x(:),g(:))
5123 0 : call jac_con(x(:),a(:,:))
5124 : end if
5125 0 : if (mode == 1) then
5126 0 : call fun(x(:),f)
5127 0 : call con(x(:),c(:))
5128 : end if
5129 : end do ! i
5130 :
5131 0 : if (mode /= 0) ABI_ERROR("Error in the optimization procedure during the DLR fit")
5132 :
5133 0 : ABI_FREE(w)
5134 0 : ABI_FREE(jw)
5135 :
5136 0 : end subroutine slsqp_wrapper
5137 : !!***
5138 :
5139 : !!****f* m_forctqmc/fourier_inv
5140 : !! NAME
5141 : !! fourier_inv
5142 : !!
5143 : !! FUNCTION
5144 : !! Computes the inverse Fourier transform of a frequency-dependent operator,
5145 : !! using analytical formulas for the asymptotic behavior. It is assumed the
5146 : !! asymptotic behavior is moments(1)/(iw_n) + moments(2)/(iwn)**2 + ...,
5147 : !! so if you want to use this routine for an operator with a 0th order moment,
5148 : !! you need to subtract it before calling this routine.
5149 : !!
5150 : !! INPUTS
5151 : !! paw_dmft <type(paw_dmft_type)>= DMFT data structure
5152 : !! nmoments = number of moments
5153 : !! ntau = number of (equidistant) imaginary time points on [0,beta]
5154 : !! oper_freq = operator for each Matsubara frequency
5155 : !! moments = high-frequency moments of the operator
5156 : !!
5157 : !! OUTPUT
5158 : !! matlu_tau(2*(2*lpawu+1),2*(2*lpawu+1),ntau) = operator for each tau point
5159 : !!
5160 : !! SIDE EFFECTS
5161 : !!
5162 : !! NOTES
5163 : !!
5164 : !! SOURCE
5165 :
5166 0 : subroutine fourier_inv(paw_dmft,nmoments,ntau,matlu_tau,oper_freq,moments)
5167 :
5168 : !Arguments ------------------------------------
5169 : integer, intent(in) :: nmoments,ntau
5170 : type(paw_dmft_type), intent(in) :: paw_dmft
5171 : type(oper_type), intent(in) :: oper_freq(paw_dmft%dmft_nwlo),moments(nmoments)
5172 : type(matlu_type), intent(inout) :: matlu_tau(paw_dmft%natom)
5173 : !Local variables ------------------------------
5174 : integer :: i,iatom,ibuf,ibuf_tau,ierr,ifreq,im1,isppol
5175 : integer :: itau,itaub,itauf,lpawu,myproc,natom,ndim,nproc
5176 : integer :: nspinor,nsppol,ntau_proc,nwlo,ratio,residu,siz_buf,tndim
5177 : real(dp) :: beta,omegatau,tau
5178 : complex(dp) :: fac
5179 0 : integer, allocatable :: displs(:),recvcounts(:)
5180 0 : complex(dp), allocatable :: buffer(:),buffer_tot(:),omega_fac(:)
5181 : ! ************************************************************************
5182 :
5183 0 : beta = one / paw_dmft%temp
5184 0 : myproc = paw_dmft%myproc
5185 0 : natom = paw_dmft%natom
5186 0 : nspinor = paw_dmft%nspinor
5187 0 : nsppol = paw_dmft%nsppol
5188 0 : nproc = paw_dmft%nproc
5189 0 : nwlo = paw_dmft%dmft_nwlo
5190 :
5191 0 : call zero_matlu(matlu_tau(:),natom)
5192 :
5193 0 : ABI_MALLOC(displs,(nproc))
5194 0 : ABI_MALLOC(recvcounts,(nproc))
5195 :
5196 0 : ratio = ntau / nproc
5197 0 : residu = ntau - ratio*nproc
5198 :
5199 0 : itau = 1
5200 0 : do i=0,nproc-1
5201 0 : ntau_proc = merge(ratio+1,ratio,i<residu)
5202 0 : recvcounts(i+1) = ntau_proc
5203 0 : if (myproc == i) itaub = itau
5204 0 : itau = itau + ntau_proc
5205 : end do ! i
5206 0 : itauf = itaub + recvcounts(myproc+1) - 1
5207 :
5208 0 : siz_buf = 0
5209 0 : do iatom=1,natom
5210 0 : lpawu = paw_dmft%lpawu(iatom)
5211 0 : if (lpawu == -1) cycle
5212 0 : siz_buf = siz_buf + (2*lpawu+1)**2
5213 : end do ! iatom
5214 :
5215 0 : siz_buf = siz_buf * (nspinor**2) * nsppol
5216 :
5217 0 : recvcounts(:) = recvcounts(:) * siz_buf
5218 :
5219 0 : displs(1) = 0
5220 0 : do i=2,nproc
5221 0 : displs(i) = displs(i-1) + recvcounts(i-1)
5222 : end do ! i
5223 :
5224 0 : ABI_MALLOC(buffer,(recvcounts(myproc+1)))
5225 0 : ABI_MALLOC(buffer_tot,(recvcounts(nproc)+displs(nproc)))
5226 0 : ABI_MALLOC(omega_fac,(nmoments))
5227 :
5228 0 : buffer(:) = czero
5229 :
5230 : ibuf_tau = 0
5231 0 : do itau=itaub,itauf
5232 :
5233 0 : tau = dble(itau-1) * beta / dble(ntau-1)
5234 0 : omega_fac(:) = czero
5235 :
5236 0 : do ifreq=nwlo,1,-1 ! NEVER change this summation order and DON'T replace by the intrinsic SUM
5237 0 : omegatau = mod(paw_dmft%omega_lo(ifreq)*tau,two_pi)
5238 0 : fac = two * paw_dmft%temp * exp(-j_dpc*omegatau)
5239 0 : do i=1,nmoments
5240 0 : omega_fac(i) = omega_fac(i) - fac/(j_dpc*paw_dmft%omega_lo(ifreq))**i
5241 : end do
5242 : ibuf = 0
5243 0 : do iatom=1,natom
5244 0 : lpawu = paw_dmft%lpawu(iatom)
5245 0 : if (lpawu == -1) cycle
5246 0 : tndim = nspinor * (2*lpawu+1)
5247 0 : do isppol=1,nsppol
5248 0 : do im1=1,tndim
5249 : buffer(ibuf_tau+ibuf+1:ibuf_tau+ibuf+tndim) = buffer(ibuf_tau+ibuf+1:ibuf_tau+ibuf+tndim) + &
5250 0 : fac*oper_freq(ifreq)%matlu(iatom)%mat(:,im1,isppol)
5251 0 : ibuf = ibuf + tndim
5252 : end do ! im
5253 : end do ! isppol
5254 : end do ! iatom
5255 : end do ! ifreq
5256 :
5257 0 : omega_fac(1) = omega_fac(1) - half
5258 0 : omega_fac(2) = omega_fac(2) + tau/two - beta/four
5259 0 : omega_fac(3) = omega_fac(3) - (tau**2)/four + tau*beta/four
5260 :
5261 0 : do i=1,nmoments
5262 : ibuf = 0
5263 0 : do iatom=1,natom
5264 0 : lpawu = paw_dmft%lpawu(iatom)
5265 0 : if (lpawu == -1) cycle
5266 0 : tndim = nspinor * (2*lpawu+1)
5267 0 : do isppol=1,nsppol
5268 0 : do im1=1,tndim
5269 : buffer(ibuf_tau+ibuf+1:ibuf_tau+ibuf+tndim) = buffer(ibuf_tau+ibuf+1:ibuf_tau+ibuf+tndim) + &
5270 0 : & moments(i)%matlu(iatom)%mat(:,im1,isppol)*omega_fac(i)
5271 0 : ibuf = ibuf + tndim
5272 : end do ! im1
5273 : end do ! isppol
5274 : end do ! iatom
5275 : end do ! i
5276 :
5277 0 : ibuf_tau = ibuf_tau + siz_buf
5278 :
5279 : end do ! itau
5280 :
5281 0 : ABI_FREE(omega_fac)
5282 :
5283 0 : call xmpi_allgatherv(buffer(:),recvcounts(myproc+1),buffer_tot(:),recvcounts(:),displs(:),paw_dmft%spacecomm,ierr)
5284 :
5285 0 : ABI_FREE(displs)
5286 0 : ABI_FREE(recvcounts)
5287 :
5288 0 : ibuf = 0
5289 0 : do itau=1,ntau
5290 0 : do iatom=1,natom
5291 0 : lpawu = paw_dmft%lpawu(iatom)
5292 0 : if (lpawu == -1) cycle
5293 0 : ndim = 2*lpawu + 1
5294 0 : tndim = ndim * nspinor
5295 0 : do isppol=1,nsppol
5296 0 : do im1=1,tndim
5297 0 : matlu_tau(iatom)%mat(1+(isppol-1)*ndim:tndim+(isppol-1)*ndim,im1+(isppol-1)*ndim,itau) = buffer_tot(ibuf+1:ibuf+tndim)
5298 0 : ibuf = ibuf + tndim
5299 : end do ! im1
5300 : end do ! isppol
5301 0 : if (nsppol == 1 .and. nspinor == 1) matlu_tau(iatom)%mat(ndim+1:2*ndim,ndim+1:2*ndim,itau) = &
5302 0 : & matlu_tau(iatom)%mat(1:ndim,1:ndim,itau)
5303 0 : ndim = 2 * ndim
5304 : matlu_tau(iatom)%mat(1:ndim,1:ndim,itau) = (matlu_tau(iatom)%mat(1:ndim,1:ndim,itau)+ &
5305 0 : & conjg(transpose(matlu_tau(iatom)%mat(1:ndim,1:ndim,itau)))) * half
5306 : end do ! iatom
5307 : end do ! itau
5308 :
5309 0 : ABI_FREE(buffer)
5310 0 : ABI_FREE(buffer_tot)
5311 :
5312 0 : end subroutine fourier_inv
5313 : !!***
5314 :
5315 : !!****f* m_forctqmc/find_block_structure
5316 : !! NAME
5317 : !! find_block_structure
5318 : !!
5319 : !! FUNCTION
5320 : !! Find the most optimal block structure of a matlu
5321 : !!
5322 : !! INPUTS
5323 : !! paw_dmft <type(paw_dmft_type)>= DMFT data structure
5324 : !! matlu <type(oper_type)>= matrix for which the block structure is to be found
5325 : !! natom = number of atoms
5326 : !! nflavor_max = max number of orbitals
5327 : !! hyb <type(green_type)>= hybridization ; if present, the block structure will
5328 : !! match both matlu and hyb
5329 : !!
5330 : !! OUTPUT
5331 : !! block_list(nflavor,natom) = block index for each flavor and atom
5332 : !! inner_list(nflavor,natom) = inner block index for each flavor and atom
5333 : !! flavor_list(nflavor,nflavor,natom) = flavor for each block and inner indexes
5334 : !! siz_block(nflavor,natom) = block size for each block and atom
5335 : !! nblocks = number of blocks for each atom
5336 : !!
5337 : !! SIDE EFFECTS
5338 : !!
5339 : !! NOTES
5340 : !!
5341 : !! SOURCE
5342 :
5343 0 : subroutine find_block_structure(paw_dmft,block_list,inner_list,flavor_list, &
5344 0 : & siz_block,nblocks,matlu,natom,nflavor_max,hyb)
5345 :
5346 : !Arguments ------------------------------------
5347 : integer, intent(in) :: natom,nflavor_max
5348 : integer, intent(inout) :: block_list(nflavor_max,natom),inner_list(nflavor_max,natom)
5349 : integer, intent(inout) :: flavor_list(nflavor_max,nflavor_max,natom)
5350 : integer, intent(inout) :: siz_block(nflavor_max,natom),nblocks(natom)
5351 : type(paw_dmft_type), intent(in) :: paw_dmft
5352 : type(green_type), optional, intent(inout) :: hyb
5353 : type(matlu_type), intent(inout) :: matlu(natom)
5354 : !Local variables ------------------------------
5355 : integer :: i,iatom,iblock,iblock1,iblock2,iflavor,ifreq,lpawu
5356 : integer :: nflavor,nspinor,nsppol,nwlo
5357 0 : integer, allocatable :: found_block(:),label_block(:)
5358 : ! ************************************************************************
5359 :
5360 0 : nspinor = paw_dmft%nspinor
5361 0 : nsppol = paw_dmft%nsppol
5362 0 : nwlo = paw_dmft%dmft_nwlo
5363 :
5364 0 : do iflavor=1,nflavor_max
5365 0 : block_list(iflavor,:) = iflavor - 1
5366 : end do ! iflavor
5367 :
5368 0 : ABI_MALLOC(found_block,(nflavor_max))
5369 0 : ABI_MALLOC(label_block,(nflavor_max))
5370 :
5371 0 : call find_block_structure_mat(matlu(:))
5372 :
5373 0 : if (present(hyb)) then
5374 0 : do i=2,hyb%nmoments-1
5375 0 : call find_block_structure_mat(hyb%moments(i)%matlu(:))
5376 : end do ! i
5377 :
5378 0 : do ifreq=1,nwlo
5379 0 : call find_block_structure_mat(hyb%oper(ifreq)%matlu(:))
5380 : end do ! ifreq
5381 : end if ! present(hyb)
5382 :
5383 0 : siz_block(:,:) = 0
5384 :
5385 : ! Rename the blocks from 0 to nblocks-1 and build lists
5386 0 : do iatom=1,natom
5387 0 : lpawu = paw_dmft%lpawu(iatom)
5388 0 : if (lpawu == -1) cycle
5389 0 : nflavor = 2 * (2*lpawu+1)
5390 :
5391 0 : found_block(:) = 0
5392 :
5393 0 : iblock1 = 0 ! number of blocks
5394 0 : do iflavor=1,nflavor
5395 0 : iblock = block_list(iflavor,iatom)
5396 0 : if (found_block(iblock+1) == 0) then
5397 0 : label_block(iblock+1) = iblock1
5398 0 : iblock1 = iblock1 + 1 ! next block index
5399 : end if
5400 0 : iblock2 = label_block(iblock+1) ! new block index
5401 0 : block_list(iflavor,iatom) = iblock2
5402 0 : inner_list(iflavor,iatom) = found_block(iblock+1)
5403 0 : found_block(iblock+1) = found_block(iblock+1) + 1
5404 0 : siz_block(iblock2+1,iatom) = siz_block(iblock2+1,iatom) + 1
5405 0 : flavor_list(found_block(iblock+1),iblock2+1,iatom) = iflavor - 1
5406 : end do ! iflavor
5407 0 : nblocks(iatom) = iblock1
5408 : end do ! iatom
5409 :
5410 0 : ABI_FREE(found_block)
5411 0 : ABI_FREE(label_block)
5412 :
5413 : ! Set to 0 the off-diagonal elements that are not kept in a block
5414 0 : call apply_block_structure_mat(matlu(:))
5415 :
5416 0 : if (present(hyb)) then
5417 :
5418 0 : do i=2,hyb%nmoments-1
5419 0 : call apply_block_structure_mat(hyb%moments(i)%matlu(:))
5420 : end do ! i
5421 :
5422 0 : do ifreq=1,nwlo
5423 0 : call apply_block_structure_mat(hyb%oper(ifreq)%matlu(:))
5424 : end do ! ifreq
5425 :
5426 : end if ! present(hyb)
5427 :
5428 : contains
5429 :
5430 0 : subroutine find_block_structure_mat(mat)
5431 :
5432 : !Arguments ------------------------------------
5433 : type(matlu_type), intent(inout) :: mat(natom)
5434 : !Local variables ------------------------------
5435 : integer :: i,iflavor1,im,im1,isppol,ndim,tndim
5436 : ! ************************************************************************
5437 :
5438 0 : do iatom=1,natom
5439 0 : lpawu = paw_dmft%lpawu(iatom)
5440 0 : if (lpawu == -1) cycle
5441 0 : ndim = 2*lpawu + 1
5442 0 : tndim = ndim * nspinor
5443 0 : nflavor = 2 * ndim
5444 0 : do isppol=1,nsppol
5445 0 : do im1=1,tndim
5446 0 : iflavor1 = im1 + (isppol-1)*ndim
5447 0 : iblock1 = block_list(iflavor1,iatom)
5448 0 : do im=1,tndim
5449 0 : iflavor = im + (isppol-1)*ndim
5450 0 : iblock = block_list(iflavor,iatom)
5451 0 : if (iblock == iblock1) cycle
5452 0 : if (abs(mat(iatom)%mat(im,im1,isppol)) > paw_dmft%dmft_triqs_tol_block) then ! Merge the two blocks
5453 0 : do i=1,nflavor
5454 0 : if (block_list(i,iatom) == iblock) block_list(i,iatom) = iblock1
5455 : end do ! i
5456 : end if
5457 : end do ! im
5458 : end do ! im1
5459 : end do ! isppol
5460 0 : if (nsppol == 1 .and. nspinor == 1) block_list(ndim+1:nflavor,iatom) = block_list(1:ndim,iatom) + ndim
5461 : end do ! iatom
5462 :
5463 0 : end subroutine find_block_structure_mat
5464 :
5465 0 : subroutine apply_block_structure_mat(mat)
5466 :
5467 : !Arguments ------------------------------------
5468 : type(matlu_type), intent(inout) :: mat(natom)
5469 : !Local variables ------------------------------
5470 : integer :: iflavor1,im,im1,isppol,ndim,tndim
5471 : ! ************************************************************************
5472 :
5473 0 : do iatom=1,natom
5474 0 : lpawu = paw_dmft%lpawu(iatom)
5475 0 : if (lpawu == -1) cycle
5476 0 : ndim = 2*lpawu + 1
5477 0 : tndim = nspinor * ndim
5478 0 : do isppol=1,nsppol
5479 0 : do im1=1,tndim
5480 0 : iflavor1 = im1 + (isppol-1)*ndim
5481 0 : iblock1 = block_list(iflavor1,iatom)
5482 0 : do im=1,tndim
5483 0 : iflavor = im + (isppol-1)*ndim
5484 0 : iblock = block_list(iflavor,iatom)
5485 0 : if (iblock == iblock1) cycle
5486 0 : mat(iatom)%mat(im,im1,isppol) = czero
5487 : end do ! im
5488 : end do ! im1
5489 : end do ! isppol
5490 : end do ! iatom
5491 :
5492 0 : end subroutine apply_block_structure_mat
5493 :
5494 : end subroutine find_block_structure
5495 : !!***
5496 :
5497 0 : END MODULE m_forctqmc
5498 : !!***
|
