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