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 : : ! Only implemented for dmft_solv = 10 and opt_diag = 1
1809 : : !
1810 : : ! =================================================================
1811 [ + + + - ]: 46 : if (reuse_atom .and. paw_dmft%dmft_solv == 10) then
1812 : 8 : write(message,'(a,2x,a,1x,i3,2x,a,1x,i3,2x,a)') ch10, &
1813 : 8 : &" Correlated atom",iatom,"is symmetry equivalent to atom",iref_atom,&
1814 : 16 : &"and therefore the CTQMC is skipped"
1815 : 8 : call wrtout(std_out,message,'COLL')
1816 [ - + + - : 32 : ABI_MALLOC(ref_rot,(nflavor,nflavor))
- + + - +
- + - - +
- + ]
1817 [ - + + - : 24 : ABI_MALLOC(tmp_mat1,(nflavor,nflavor))
- + + - -
+ - + ]
1818 [ - + + - : 24 : ABI_MALLOC(tmp_mat2,(nflavor,nflavor))
- + + - -
+ - + ]
1819 [ + + + + ]: 1688 : ref_rot(:,:) = czero
1820 [ + + + + ]: 1688 : tmp_mat1(:,:) = czero
1821 [ + + + + ]: 1688 : tmp_mat2(:,:) = czero
1822 : :
1823 : : ! Rotate Matsubara Green's function
1824 [ + + ]: 5600 : do ifreq=1,paw_dmft%dmft_nwlo
1825 : : ! first rotate back from iref_diag basis to slm
1826 : : call abi_xgemm('N','N',nflavor,nflavor,nflavor,cone, &
1827 : : & eigvectmatlu(iref_atom)%mat(:,:,1),nflavor, &
1828 [ + - + - : 1179912 : & gw_tmp_nd_ref(iref_atom,ifreq,1:nflavor,1:nflavor),nflavor,czero,tmp_mat1,nflavor)
+ + + + +
- ]
1829 : : call abi_xgemm('N','C',nflavor,nflavor,nflavor,cone, &
1830 : : & tmp_mat1,nflavor, &
1831 : 5592 : & eigvectmatlu(iref_atom)%mat(:,:,1),nflavor,czero,ref_rot,nflavor)
1832 : : ! then rotate to iatom diag_basis
1833 : : call abi_xgemm('C','N',nflavor,nflavor,nflavor,cone, &
1834 : : & eigvectmatlu(iatom)%mat(:,:,1),nflavor, &
1835 : 5592 : & ref_rot,nflavor,czero,tmp_mat2,nflavor)
1836 : : call abi_xgemm('N','N',nflavor,nflavor,nflavor,cone, &
1837 : : & tmp_mat2,nflavor, &
1838 [ + - + - : 2354240 : & eigvectmatlu(iatom)%mat(:,:,1),nflavor,czero,gw_tmp_nd(ifreq,1:nflavor,1:nflavor),nflavor)
+ + + + +
- + + +
+ ]
1839 : : end do
1840 : :
1841 : : ! Rotate imaginary-time Green's function for complex solver
1842 [ + + ]: 2408 : do itau=1,paw_dmft%dmftqmc_l
1843 : : ! first rotate back from iref_diag basis to slm
1844 : : call abi_xgemm('N','N',nflavor,nflavor,nflavor,cone, &
1845 : : & eigvectmatlu(iref_atom)%mat(:,:,1),nflavor, &
1846 [ + - + - : 506400 : & gtmp_ndc_ref(iref_atom,itau,1:nflavor,1:nflavor),nflavor,czero,tmp_mat1,nflavor)
+ + + + +
- ]
1847 : : call abi_xgemm('N','C',nflavor,nflavor,nflavor,cone, &
1848 : : & tmp_mat1,nflavor, &
1849 : 2400 : & eigvectmatlu(iref_atom)%mat(:,:,1),nflavor,czero,ref_rot,nflavor)
1850 : : ! then rotate to iatom diag_basis
1851 : : call abi_xgemm('C','N',nflavor,nflavor,nflavor,cone, &
1852 : : & eigvectmatlu(iatom)%mat(:,:,1),nflavor, &
1853 : 2400 : & ref_rot,nflavor,czero,tmp_mat2,nflavor)
1854 : : call abi_xgemm('N','N',nflavor,nflavor,nflavor,cone, &
1855 : : & tmp_mat2,nflavor, &
1856 [ + - + - : 1010408 : & eigvectmatlu(iatom)%mat(:,:,1),nflavor,czero,gtmp_ndc(itau,1:nflavor,1:nflavor),nflavor)
+ + + + +
- + + +
+ ]
1857 : : end do
1858 : : ! Interaction energy is a scalar invariant under the orbital rotation
1859 : 8 : green%ecorr_qmc(iatom) = green%ecorr_qmc(iref_atom)
1860 : :
1861 [ - + ]: 8 : ABI_FREE(ref_rot)
1862 [ - + ]: 8 : ABI_FREE(tmp_mat1)
1863 [ - + ]: 8 : ABI_FREE(tmp_mat2)
1864 : : end if
1865 : :
1866 : 46 : call timab(704,2,tsec(:))
1867 : : ! =================================================================
1868 : : ! END CALL TO CTQMC SOLVERS
1869 : : ! =================================================================
1870 : :
1871 : :
1872 : : ! Print green function is files directly from CTQMC
1873 : : ! --------------------------------------------------
1874 : 46 : call ctqmcoutput_printgreen(paw_dmft,gtmp_nd,gtmp_ndc,gw_tmp_nd,gtmp,gw_tmp,iatom)
1875 : :
1876 : : ! Store the reference (representative) impurity solution for later reuse
1877 : : ! by symmetry-equivalent atoms (only needed when the group reuse is active).
1878 : : ! -------------------------------------------------------------------------
1879 [ + + + - : 46 : if (paw_dmft%dmftctqmc_sym == 1 .and. testcode == 0 .and. .not. reuse_atom) then
+ + ]
1880 [ + + + + : 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)
+ + ]
1881 [ + - ]: 4 : if (paw_dmft%dmft_solv == 10) then
1882 : : gtmp_ndc_ref(iatom,1:paw_dmft%dmftqmc_l,1:nflavor,1:nflavor) = &
1883 [ + + + + : 236044 : & gtmp_ndc(1:paw_dmft%dmftqmc_l,1:nflavor,1:nflavor)
+ + ]
1884 : : end if
1885 : : end if
1886 : :
1887 : :
1888 : : ! Only destroy the CTQMC solver if it was actually initialized for this atom (i.e.
1889 : : ! the reference/representative atom). For a reused atom, no solver was initialized,
1890 : : ! so we only skip the destroy (not the subsequent deallocation of the shared buffers).
1891 [ + - ]: 38 : if (.not. reuse_atom) then
1892 : : ! If the CTQMC code in ABINIT was used, then destroy it and deallocate arrays
1893 : : ! ----------------------------------------------------------------------------
1894 : : ! if(paw_dmft%dmft_solv<6.and.paw_dmft%dmft_solv>7) then
1895 : : ! Nothing just hybrid var problem
1896 : : ! else
1897 : 38 : write(message,'(a,2x,a)') ch10," == Destroy CTQMC"
1898 : 38 : call wrtout(std_out,message,'COLL')
1899 [ + + ]: 38 : if (paw_dmft%dmft_solv == 5) then
1900 : 34 : call CtqmcInterface_finalize(hybrid)
1901 : : end if
1902 [ - + ]: 38 : if (paw_dmft%dmft_solv == 8) then
1903 : 0 : call CtqmcoffdiagInterface_finalize(hybridoffdiag)
1904 : : end if
1905 [ + + ]: 38 : if (paw_dmft%dmft_solv == 10) then
1906 : 4 : call CtqmcoffdiagInterfaceComplex_finalize(hybridoffdiagComplex)
1907 : : end if
1908 : 38 : write(message,'(a,2x,a)') ch10," == Destroy CTQMC done"
1909 : 38 : call wrtout(std_out,message,'COLL')
1910 : : end if ! (.not. reuse_atom)
1911 [ - + ]: 46 : ABI_FREE(hybri_limit)
1912 [ - + ]: 46 : ABI_FREE(levels_ctqmc_nd)
1913 [ - + ]: 46 : ABI_FREE(levels_ctqmc)
1914 [ - + ]: 46 : ABI_FREE(levels_ctqmc_complex)
1915 [ - + ]: 46 : ABI_FREE(fw1)
1916 [ - + ]: 46 : ABI_FREE(fw1_nd)
1917 : :
1918 : : ! ____________________________________________________________
1919 : : !
1920 : : ! FOURTH PART : USE OUTPUT OF CTQMC AND THEN DO BACK ROTATION
1921 : : ! ____________________________________________________________
1922 : : !
1923 : :
1924 : : ! Put green's function values from CTQMC into green structure
1925 : : !------------------------------------------------------------
1926 : 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)
1927 : :
1928 : : ! Deallocate arrays for CTQMC
1929 : : !----------------------------
1930 [ + + ]: 46 : if (paw_dmft%dmft_solv < 6) then
1931 [ - + ]: 34 : ABI_FREE(gw_tmp)
1932 : : end if
1933 [ - + ]: 46 : ABI_FREE(gw_tmp_nd)
1934 [ - + ]: 46 : ABI_FREE(gtmp)
1935 [ - + ]: 46 : ABI_FREE(gtmp_nd)
1936 [ + + ]: 84 : if(paw_dmft%dmft_solv .eq. 10) then
1937 [ - + ]: 12 : ABI_FREE(gtmp_ndc)
1938 : : endif
1939 : :
1940 : : ! Do Fourier transform if it was not done (ie if TRIQS is used without legendre measurement)
1941 : : !-------------------------------------------------------------------------------------------
1942 : : ! if(opt_nondiag==1) then ! (As leg_measure is activated by defautl, this fourier is never done).
1943 : : ! if(paw_dmft%dmft_solv>=6.and..not.leg_measure.and.paw_dmft%dmft_solv<=7) then
1944 : : ! write(message,'(2a,i3,13x,a)') ch10,' === Direct Fourier Transform t->w of Weiss Field'
1945 : : ! call wrtout(std_out,message,'COLL')
1946 : : ! call fourier_green(cryst_struc,green,paw_dmft,&
1947 : : ! & pawang,opt_ksloc=2,opt_tw=1)
1948 : : ! end if
1949 : : ! endif
1950 : :
1951 : : ! end if
1952 : :
1953 : : end do ! iatom
1954 : 38 : call timab(703,2,tsec(:))
1955 : : ! ==================================================================
1956 : : ! End big loop over atoms to compute hybridization and do the CTQMC
1957 : : ! ==================================================================
1958 : :
1959 : 38 : call timab(705,1,tsec(:))
1960 [ - + ]: 38 : if (paw_dmft%dmft_prgn == 1) then
1961 : 0 : call print_green('QMC_diag_notsym',green,1,paw_dmft,opt_wt=2)
1962 : 0 : call print_green('QMC_diag_notsym',green,1,paw_dmft,opt_wt=1)
1963 : : end if
1964 : : ! write(message,'(i3,4x,2e21.14)') 6,weiss_for_rot%oper(1)%matlu(1)%mat(1,1,1,1,1)
1965 : : ! call wrtout(std_out,message,'COLL') ! debug
1966 : : ! =================================================================
1967 : : ! Inverse Weiss, then
1968 : : ! Copy Weiss_for_rot into weiss and rotate back weiss to the original basis
1969 : : ! =================================================================
1970 : :
1971 : : ! ABI_MALLOC(shift,(natom))
1972 : : ! do ifreq=1,paw_dmft%dmft_nwlo
1973 : : ! ! First weiss_for_rot contains -G_0^-1+iw_n
1974 : : ! ! -------------------------------------------
1975 : : ! ! Compute G_0^-1-iw_n
1976 : : ! ! --------------------
1977 : : ! write(6,*) "1"
1978 : : ! if(opt_fk==1) call fac_matlu(weiss_for_rot%oper(ifreq)%matlu,natom,-cone)
1979 : : !
1980 : : !
1981 : : ! write(6,*) "2"
1982 : : ! ! Compute G_0^-1
1983 : : ! ! --------------------
1984 : : ! shift(:)=cmplx(zero,paw_dmft%omega_lo(ifreq),kind=dp)
1985 : : ! if(opt_fk==1) call shift_matlu(weiss_for_rot%oper(ifreq)%matlu,natom,shift,signe=1)
1986 : : !
1987 : : ! write(6,*) "3"
1988 : : ! ! Compute G_0
1989 : : ! ! --------------------
1990 : : ! call inverse_oper(weiss_for_rot%oper(ifreq),option=1,prtopt=1)
1991 : : ! ! No need to copy if weiss_for_rot is a pointer to weiss ...
1992 : : !! if(useylm==1) call slm2ylm_matlu(weiss%oper(ifreq)%matlu,natom,2,0)
1993 : : !! if(opt_diag/=0) call rotate_matlu(weiss%oper(ifreq)%matlu,eigvectmatlu,natom,3,0)
1994 : : !
1995 : : ! ! Compute G_0 in the original basis
1996 : : ! ! --------------------
1997 : : ! call rotate_matlu(weiss_for_rot%oper(ifreq)%matlu,eigvectmatlu,natom,3,0)
1998 : : ! end do
1999 : : ! ABI_FREE(shift)
2000 : :
2001 : : ! =================================================================
2002 : : ! Here compute Self energy from Dyson and print it
2003 : : ! Warning : Weiss_for_rot is inversed inside dyson
2004 : : ! =================================================================
2005 : : ! call initialize_self(self,paw_dmft)
2006 : : ! call dyson(green,paw_dmft,self,weiss_for_rot,opt_weissself=2)
2007 : : ! call rw_self(self,mpi_enreg,paw_dmft,prtopt=2,opt_rw=2,opt_char="diag")
2008 : : ! call destroy_self(self)
2009 : : !write(message,'(i3,4x,2e21.14)') 7,weiss%oper(1)%matlu(1)%mat(1,1,1,1,1)
2010 : : !call wrtout(std_out,message,'COLL') ! debug
2011 : :
2012 : : ! =================================================================
2013 : : ! Rotate back green function to original basis (non-diagonal)
2014 : : ! (and Weiss for further use: might be useful if an back Fourier
2015 : : ! transformation is done).
2016 : : ! =================================================================
2017 [ + + ]: 38 : if (pawprtvol >= 3) then
2018 : 32 : write(message,'(a,2x,a)') ch10, & ! debug
2019 : 64 : & " == Print Green's function for tau=0+ in the CTQMC basis" ! debug
2020 : 32 : call wrtout(std_out,message,'COLL') ! debug
2021 : 32 : call print_matlu(green%oper_tau(1)%matlu(:),natom,1,compl=1) ! debug
2022 : 32 : write(message,'(a,2x,a)') ch10,& ! debug
2023 : 64 : & " == Print Green's function for smallest freq in the CTQMC basis" ! debug
2024 : 32 : call wrtout(std_out,message,'COLL') ! debug
2025 : 32 : call print_matlu(green%oper(1)%matlu(:),natom,1) ! debug
2026 : : end if ! pawprtvol>=3
2027 : :
2028 : : ! === Compute rotated Occupations in green%occup_tau
2029 : 38 : call occup_green_tau(green)
2030 : :
2031 [ + + ]: 38 : if (pawprtvol >= 3) then
2032 : : ! === Compute non rotated Occupations in green%occup_tau
2033 : 32 : write(message,'(a,2x,a)') ch10," == Occupations from G(tau=0-) in the CTQMC basis"
2034 : 32 : call wrtout(std_out,message,'COLL')
2035 : 32 : call print_matlu(green%occup_tau%matlu(:),natom,1)
2036 : : end if ! pawprtvol>=3
2037 : :
2038 : : ! =================================================================
2039 : : !
2040 : : ! === Compute magnetic moments from CT-QMC occupations for
2041 : : ! the x,y and z axes when SOC is activated
2042 : : !
2043 : : ! =================================================================
2044 [ + + ]: 38 : if (paw_dmft%nspinor .eq. 2) then
2045 [ - + + - : 28 : ABI_MALLOC(matlumag,(natom))
+ - + - -
+ - + +
+ ]
2046 [ - + + - : 12 : ABI_MALLOC(muzeem,(natom))
+ - + - -
+ - + -
+ ]
2047 [ - + + - : 8 : ABI_MALLOC(muspin,(natom))
- + - + -
+ ]
2048 [ - + + - : 8 : ABI_MALLOC(muorb,(natom))
- + - + -
+ ]
2049 : 4 : write(message,'(a,2x,a)') ch10,"== Magnetic moments from CT-QMC occupation matrix "
2050 : 4 : call wrtout(std_out,message,'COLL')
2051 : :
2052 [ + + ]: 20 : do iatom=1,cryst_struc%natom
2053 : 16 : lpawu=paw_dmft%lpawu(iatom)
2054 [ + + ]: 20 : if(lpawu .ne. -1) then
2055 : 12 : write(message,'(a,3x,a,i4)') ch10,"-------> For Correlated Atom",iatom
2056 : 12 : call wrtout(std_out,message,'COLL')
2057 : :
2058 : : ! == orbital angular momentum
2059 [ + + ]: 48 : do icomp=1,3 !x,y,z components
2060 : 36 : muorb(iatom)=czero
2061 : 36 : call init_matlu(natom=natom,nspinor=paw_dmft%nspinor,nsppol=paw_dmft%nsppol,lpawu_natom=paw_dmft%lpawu,matlu=matlumag)
2062 : 36 : call copy_matlu(green%occup_tau%matlu,matlumag,natom)
2063 [ - + ]: 36 : if (usejmj == 1) then
2064 : 0 : call ylm2jmj_matlu(matlumag,natom,2,paw_dmft)
2065 : : else
2066 : 36 : call rotate_matlu(matlumag,eigvectmatlu,natom=natom,inverse=0)
2067 : : endif
2068 : 36 : call magmomforb_matlu(matlumag,muorb,natom=natom,option=icomp,optprt=0)
2069 : 36 : write(message,'(a,2x,a,i4,a,f8.4)') ch10," Orbital angular momentum for axis ", icomp, " is ", REAL(muorb(iatom))
2070 : 36 : call wrtout(std_out,message,'COLL')
2071 : 48 : call destroy_matlu(matlumag,(natom))
2072 : : end do
2073 : :
2074 : : ! == spin angular momentum
2075 [ + + ]: 48 : do icomp=1,3 !x,y,z components
2076 : 36 : muspin(iatom)=czero
2077 : 36 : call init_matlu(natom=natom,nspinor=paw_dmft%nspinor,nsppol=paw_dmft%nsppol,lpawu_natom=paw_dmft%lpawu,matlu=matlumag)
2078 : 36 : call copy_matlu(green%occup_tau%matlu,matlumag,natom=natom)
2079 [ - + ]: 36 : if (usejmj == 1) then
2080 : 0 : call ylm2jmj_matlu(matlumag,natom,2,paw_dmft)
2081 : : else
2082 : 36 : call rotate_matlu(matlumag,eigvectmatlu,natom=natom,inverse=0)
2083 : : endif
2084 : 36 : call magmomfspin_matlu(matlumag,muspin,natom=natom,option=icomp,optprt=0)
2085 : 36 : write(message,'(a,2x,a,i4,a,f8.4)') ch10," Spin angular momentum for axis ", icomp, " is ", REAL(muspin(iatom))
2086 : 36 : call wrtout(std_out,message,'COLL')
2087 : 48 : call destroy_matlu(matlumag,(natom))
2088 : : end do
2089 : :
2090 : : ! == total angular momentum (L_u + 2*S_u)
2091 [ + + ]: 48 : do icomp=1,3 !x,y,z components
2092 : 36 : muzeem(iatom)=czero
2093 : 36 : call init_matlu(natom=natom,nspinor=paw_dmft%nspinor,nsppol=paw_dmft%nsppol,lpawu_natom=paw_dmft%lpawu,matlu=matlumag)
2094 : 36 : call copy_matlu(green%occup_tau%matlu,matlumag,natom=natom)
2095 [ - + ]: 36 : if (usejmj == 1) then
2096 : 0 : call ylm2jmj_matlu(matlumag,natom,2,paw_dmft)
2097 : : else
2098 : 36 : call rotate_matlu(matlumag,eigvectmatlu,natom=natom,inverse=0)
2099 : : endif
2100 : 36 : call magmomfzeeman_matlu(matlumag,muzeem,natom=natom,option=icomp,optprt=0)
2101 : 36 : write(message,'(a,2x,a,i4,a,f8.4)') ch10," Zeeman angular momentum for axis ", icomp, " is ", REAL(muzeem(iatom))
2102 : 36 : call wrtout(std_out,message,'COLL')
2103 : 48 : call destroy_matlu(matlumag,(natom))
2104 : : end do
2105 : : endif !lpawu
2106 : : end do !iatom
2107 [ + - + + : 20 : ABI_FREE(matlumag)
- + - + ]
2108 [ - + ]: 4 : ABI_FREE(muzeem)
2109 [ - + ]: 4 : ABI_FREE(muspin)
2110 [ - + ]: 4 : ABI_FREE(muorb)
2111 : : end if !nspinor
2112 : : ! =================================================================
2113 : :
2114 [ + + ]: 38 : if (opt_diag /= 0) then
2115 : 18 : write(message,'(a,2x,a)') ch10," == Rotate Green's function back to original basis "
2116 : 18 : call wrtout(std_out,message,'COLL')
2117 : : end if
2118 : : ! write(message,'(i3,4x,2e21.14)') 8,weiss%oper(1)%matlu(1)%mat(1,1,1,1,1)
2119 : : ! call wrtout(std_out,message,'COLL') ! debug
2120 : :
2121 : : ! Rotate oper_tau into Ylm basis and then Slm basis
2122 : : ! -------------------------------------------------------------
2123 : : ! do itau=1,paw_dmft%dmftqmc_l
2124 : : ! if (opt_diag /= 0) call rotate_matlu(green%oper_tau(itau)%matlu(:),eigvectmatlu(:),natom,3,0)
2125 : : ! if (useylm == 1) call slm2ylm_matlu(green%oper_tau(itau)%matlu(:),natom,2,0)
2126 : : ! end do
2127 [ + + ]: 8788 : do itau=1,paw_dmft%dmftqmc_l
2128 [ + + ]: 8750 : if (opt_diag /= 0) then
2129 : 1900 : call rotate_matlu(green%oper_tau(itau)%matlu(:),eigvectmatlu(:),natom,0)
2130 : : end if
2131 [ - + ]: 8750 : if (usejmj == 1) then
2132 : 0 : call ylm2jmj_matlu(green%oper_tau(itau)%matlu(:),natom,2,paw_dmft)
2133 : : endif
2134 [ + + ]: 8788 : if (useylm == 1) then
2135 : 1200 : call slm2ylm_matlu(green%oper_tau(itau)%matlu(:),natom,paw_dmft,2,0)
2136 : : end if
2137 : : end do ! itau
2138 : :
2139 : : ! Rotate occup_tau into Ylm basis and then Slm basis
2140 : : !-------------------------------------------------------------
2141 [ + + ]: 38 : if (opt_diag /= 0) then
2142 : 18 : call rotate_matlu(green%occup_tau%matlu(:),eigvectmatlu(:),natom,0)
2143 : : end if
2144 [ - + ]: 38 : if (usejmj == 1) then
2145 : 0 : write(message,'(a,2x,a)') ch10," == Occupations from G(tau=0-) in the jmj basis"
2146 : 0 : call wrtout(std_out,message,'COLL')
2147 : 0 : call ylm2jmj_matlu(green%occup_tau%matlu(:),natom,2,paw_dmft)
2148 : 0 : call print_matlu(green%occup_tau%matlu(:),natom,1)
2149 : : endif
2150 [ + + ]: 38 : if (useylm == 1) then
2151 : 4 : write(message,'(a,2x,a)') ch10," == Occupations from G(tau=0-) in the Ylm basis"
2152 : 4 : call wrtout(std_out,message,'COLL')
2153 : 4 : call print_matlu(green%occup_tau%matlu(:),natom,1)
2154 : 4 : call slm2ylm_matlu(green%occup_tau%matlu(:),natom,paw_dmft,2,0)
2155 : : end if
2156 : : ! write(message,'(a,2x,a)') ch10," == Occupations from G(tau=0-) in the Slm basis"
2157 : : ! call wrtout(std_out,message,'COLL')
2158 : : ! call print_matlu(green%occup_tau%matlu(:),natom,1)
2159 : :
2160 : : ! Put Weiss off diagonal terms to zero because Green function will not have any offdiag terms
2161 : : ! ------------------------------------------------------------------------------
2162 : : ! (if opt_nondiag=0 ie dmft_solv=5)
2163 [ + + ]: 38 : if (opt_nondiag == 0) then
2164 [ + + ]: 17963 : do ifreq=1,nwlo
2165 : 17963 : call zero_matlu(weiss%oper(ifreq)%matlu(:),natom,onlynondiag=1)
2166 : : end do ! ifreq
2167 : : end if ! opt_nondiag=0
2168 : : ! ( if opt_nondiag=0, then:
2169 : : ! As Green's function is diagonal, one suppress off diag terms in Weiss, if any.
2170 : : ! (If off diag are non zero in the density matrix and thus in the Green's function,
2171 : : ! there is a warning in checkreal_matlu above).)
2172 : :
2173 : : ! Rotate Green's and Weiss functions into Ylm basis and then Slm basis
2174 : : !-------------------------------------------------------------
2175 : :
2176 [ + + ]: 20763 : do ifreq=1,nwlo
2177 [ + + ]: 20725 : if (opt_diag /= 0) then
2178 : 4056 : call rotate_matlu(green%oper(ifreq)%matlu(:),eigvectmatlu(:),natom,0)
2179 : 4056 : call rotate_matlu(weiss%oper(ifreq)%matlu(:),eigvectmatlu(:),natom,0)
2180 : : end if
2181 [ - + ]: 20725 : if (usejmj == 1) then
2182 : 0 : call ylm2jmj_matlu(green%oper(ifreq)%matlu(:),natom,2,paw_dmft)
2183 : 0 : call ylm2jmj_matlu(weiss%oper(ifreq)%matlu(:),natom,2,paw_dmft)
2184 : : endif
2185 [ + + ]: 20763 : if (useylm == 1) then
2186 : 2796 : call slm2ylm_matlu(green%oper(ifreq)%matlu(:),natom,paw_dmft,2,0)
2187 : 2796 : call slm2ylm_matlu(weiss%oper(ifreq)%matlu(:),natom,paw_dmft,2,0)
2188 : : end if
2189 : : end do ! ifreq
2190 : :
2191 : : !write(message,'(i3,4x,2e21.14)') 10,weiss%oper(1)%matlu(1)%mat(1,1,1,1,1)
2192 : : !call wrtout(std_out,message,'COLL') ! debug
2193 : :
2194 [ + + ]: 38 : if (pawprtvol >= 3) then
2195 : : !< HACK >
2196 : 32 : write(message,'(a,2x,a)') ch10,& ! debug
2197 : 64 : & " == Print diagonalized weiss_for_rot function after rotation for small freq in the ctqmc basis" ! debug
2198 : 32 : call wrtout(std_out,message,'COLL') ! debug
2199 : 32 : call print_matlu(weiss_for_rot%oper(1)%matlu(:),natom,1) ! debug
2200 : :
2201 : : !</ HACK >
2202 : 32 : write(message,'(a,2x,a)') ch10,& ! debug
2203 : 64 : & " == Print Weiss function for smallest freq in the Slm basis" ! debug
2204 : 32 : call wrtout(std_out,message,'COLL') ! debug
2205 : 32 : call print_matlu(weiss%oper(1)%matlu(:),natom,1) ! debug
2206 : :
2207 [ + + ]: 20253 : do ifreq=1,nwlo
2208 : 20253 : call sym_matlu(weiss%oper(ifreq)%matlu(:),paw_dmft)
2209 : : end do
2210 : 32 : write(message,'(a,2x,a)') ch10,& ! debug
2211 : 64 : & " == Print symmetrized Weiss function for smallest freq in the Slm basis" ! debug
2212 : 32 : call wrtout(std_out,message,'COLL') ! debug
2213 : 32 : call print_matlu(weiss%oper(1)%matlu(:),natom,1) ! debug
2214 : 32 : write(message,'(a,2x,a)') ch10, & ! debug
2215 : 64 : & " == Print Green's function for tau=0+ in the Slm basis" ! debug
2216 : 32 : call wrtout(std_out,message,'COLL') ! debug
2217 : 32 : call print_matlu(green%oper_tau(1)%matlu(:),natom,1) ! debug
2218 : 32 : write(message,'(a,2x,a)') ch10,& ! debug
2219 : 64 : & " == Print Green's function for smallest freq in the Slm basis" ! debug
2220 : 32 : call wrtout(std_out,message,'COLL') ! debug
2221 : 32 : call print_matlu(green%oper(1)%matlu(:),natom,1) ! debug
2222 : : end if ! pawprtvol>=3
2223 : :
2224 [ - + + - : 192 : ABI_MALLOC(matlu1,(natom))
+ - + - -
+ - + +
+ ]
2225 : 38 : call init_matlu(natom,nspinor,nsppol,paw_dmft%lpawu(:),matlu1(:))
2226 : 38 : call copy_matlu(green%occup_tau%matlu(:),matlu1(:),natom)
2227 : 38 : call sym_matlu(matlu1(:),paw_dmft)
2228 : :
2229 : 38 : write(message,'(a,2x,a)') ch10," == Occupations from G(tau=0-) in the Slm basis"
2230 : 38 : call wrtout(std_out,message,'COLL')
2231 : 38 : call print_matlu(green%occup_tau%matlu(:),natom,1)
2232 : :
2233 : 38 : write(message,'(a,2x,a)') ch10," == Symmetrized occupations"
2234 : 38 : call wrtout(std_out,message,'COLL')
2235 : 38 : call print_matlu(matlu1(:),natom,1)
2236 : :
2237 : 38 : call diff_matlu("CTQMC occupations","Symmetrized CTQMC occupations",green%occup_tau%matlu(:),matlu1(:),natom,0,tol4,ierr=ierr)
2238 : 38 : call destroy_matlu(matlu1(:),natom)
2239 [ + - + + : 116 : ABI_FREE(matlu1)
- + - + ]
2240 : :
2241 : : ! =================================================================
2242 : : ! Symmetrize green function G(tau) and G(ifreq) to recover symmetry
2243 : : ! artificially broken by QMC
2244 : : ! =================================================================
2245 : 38 : write(message,'(a,2x,a)') ch10," == Symmetrize Green's function after CTQMC "
2246 : 38 : call wrtout(std_out,message,'COLL')
2247 : :
2248 [ + + ]: 76 : do itau=1,1 !paw_dmft%dmftqmc_l
2249 : 76 : call sym_matlu(green%oper_tau(itau)%matlu(:),paw_dmft)
2250 : : end do ! itau
2251 : :
2252 : : ! Perform symetry on GPU if requested
2253 [ + - ]: 38 : if (paw_dmft%gpu_option == ABI_GPU_OPENMP) then
2254 : : #ifdef HAVE_OPENMP_OFFLOAD
2255 : : ! 1) Init green_oper_ndat
2256 : : call init_oper_ndat(paw_dmft,green_oper_ndat,nwlo,nkpt=green%oper(1)%nkpt,opt_ksloc=2,gpu_option=paw_dmft%gpu_option)
2257 : : if (green%oper(1)%has_operks == 0) then
2258 : : green_oper_ndat%paral = 1
2259 : : green_oper_ndat%shiftk = green%distrib%shiftk
2260 : : end if
2261 : : ! 2) Copy green%oper(:)%matlu into green_oper_ndat (CPU->GPU transfer)
2262 : : call copy_oper_to_ndat(green%oper,green_oper_ndat,nwlo,green%nw,green%distrib%proct,green%distrib%me_freq,.false.)
2263 : :
2264 : : ! 3) Perform sym_matlu on green_oper_ndat (GPU enabled)
2265 : : call sym_matlu(green_oper_ndat%matlu(:),paw_dmft)
2266 : :
2267 : : ! 4) Copy back green%oper(:)%matlu from green_oper_ndat (GPU->CPU transfer)
2268 : : call copy_oper_from_ndat(green_oper_ndat,green%oper,nwlo,green%nw,green%distrib%proct,&
2269 : : & green%distrib%me_freq,.false.)
2270 : : ! 5) Destroy green_oper_ndat
2271 : : call destroy_oper(green_oper_ndat)
2272 : : #endif
2273 : : else
2274 [ + + ]: 20763 : do ifreq=1,paw_dmft%dmft_nwlo
2275 : 20763 : call sym_matlu(green%oper(ifreq)%matlu(:),paw_dmft)
2276 : : end do ! ifreq
2277 : : end if
2278 : :
2279 : :
2280 [ + + ]: 38 : if (pawprtvol >= 3) then
2281 : 32 : write(message,'(a,2x,a)') ch10, & ! debug
2282 : 64 : & " == Print Green's function for tau=0+ after symmetrization" ! debug
2283 : 32 : call wrtout(std_out,message,'COLL') ! debug
2284 : 32 : call print_matlu(green%oper_tau(1)%matlu(:),natom,1) ! debug
2285 : 32 : write(message,'(a,2x,a)') ch10, & ! debug
2286 : 64 : & " == Print Green's function for smallest freq after symmetrization" ! debug
2287 : 32 : call wrtout(std_out,message,'COLL') ! debug
2288 : 32 : call print_matlu(green%oper(1)%matlu(:),natom,1) ! debug
2289 : : end if ! pawprtvol>=3
2290 [ - + ]: 38 : if (paw_dmft%dmft_prgn == 1) then
2291 : 0 : call print_green('QMC_sym',green,1,paw_dmft,opt_wt=2)
2292 : 0 : call print_green('QMC_sym',green,1,paw_dmft,opt_wt=1)
2293 : : end if
2294 : :
2295 : : ! === Compute Occupations (Symmetrized from oper_tau)
2296 : 38 : call occup_green_tau(green)
2297 : :
2298 : : ! === Print occupations
2299 : : ! call printocc_green(green,6,paw_dmft,3)
2300 : :
2301 : 38 : call destroy_oper(energy_level)
2302 : 38 : call destroy_matlu(dmat_diag(:),natom)
2303 : 38 : call destroy_matlu(eigvectmatlu(:),natom)
2304 : 38 : call destroy_matlu(udens_atoms(:),natom)
2305 [ + - + + : 116 : ABI_FREE(dmat_diag)
- + - + ]
2306 [ + + ]: 116 : do iatom=1,natom
2307 : 78 : lpawu = paw_dmft%lpawu(iatom)
2308 [ + + ]: 78 : if (lpawu == -1) cycle
2309 [ - + ]: 46 : ABI_FREE(magmom_orb(iatom)%value)
2310 [ - + ]: 46 : ABI_FREE(magmom_spin(iatom)%value)
2311 [ - + ]: 116 : ABI_FREE(magmom_tot(iatom)%value)
2312 : : end do
2313 [ + - + + : 116 : ABI_FREE(udens_atoms)
- + - + ]
2314 [ + - + + : 116 : ABI_FREE(eigvectmatlu)
- + - + ]
2315 [ + - + + : 116 : ABI_FREE(magmom_orb)
- + - + ]
2316 [ + - + + : 116 : ABI_FREE(magmom_spin)
- + - + ]
2317 [ + - + + : 116 : ABI_FREE(magmom_tot)
- + - + ]
2318 [ + - + + : 116 : ABI_FREE(matlumag_orb)
- + - + ]
2319 [ + - + + : 116 : ABI_FREE(matlumag_spin)
- + - + ]
2320 [ + - + + : 116 : ABI_FREE(matlumag_tot)
- + - + ]
2321 : 38 : call destroy_green(weiss_for_rot)
2322 : : ! call destroy_green(gw_loc)
2323 : : ! call destroy_green(greendft)
2324 : :
2325 : : ! destroy limit of hybridization
2326 : 38 : call destroy_matlu(hybri_coeff(:),paw_dmft%natom)
2327 [ + - + + : 116 : ABI_FREE(hybri_coeff)
- + - + ]
2328 : :
2329 : 38 : call destroy_vee(paw_dmft,vee_rotated(:))
2330 [ + - + + : 116 : ABI_FREE(vee_rotated)
- + - + ]
2331 [ - + ]: 38 : ABI_FREE(iat_ref)
2332 [ - + ]: 38 : ABI_FREE(isym_ref)
2333 [ - + ]: 38 : ABI_FREE(gw_tmp_nd_ref)
2334 [ - + ]: 38 : ABI_FREE(gtmp_ndc_ref)
2335 : 38 : call timab(705,2,tsec(:))
2336 : 38 : call timab(701,2,tsec(:))
2337 : :
2338 [ - + - - : 304 : end subroutine qmc_prep_ctqmc
- - - + -
+ - - - -
- + - + -
+ - + - +
- + - + -
+ - + - -
- - - - -
- - - - +
- - - - -
- - - - -
- + - - -
- - - - -
- - - + -
- - - - +
- + - + -
+ - + - -
- - - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
- - - - -
- + - + -
+ + + - +
- + - - -
- - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- - - - -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - - -
- - - - +
- + - + +
+ - + - +
- - - - -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - -
- - - + -
+ - + - +
- + - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - + - +
- + - + -
+ - + - +
- - - - -
+ ]
2339 : : !!***
2340 : :
2341 : : !!****f* m_forctqmc/testcode_ctqmc_b
2342 : : !! NAME
2343 : : !! testcode_ctqmc_b
2344 : : !!
2345 : : !! FUNCTION
2346 : : !! Setup ultra simple hybridization to test CTQMC in simple situations.
2347 : : !!
2348 : : !! INPUTS
2349 : : !! temp = temperature
2350 : : !! dmftqmc_l = number of times slices
2351 : : !! levels_ctqmc_nd=level matrix
2352 : : !!
2353 : : !! OUTPUT
2354 : : !! fw1_nd=hybridization matrix
2355 : : !! umod = value of U
2356 : : !! hybri_limit= limit of F
2357 : : !! weiss_for_rot= weiss function
2358 : : !! hybri_coeff
2359 : : !!
2360 : : !! SIDE EFFECTS
2361 : : !!
2362 : : !! NOTES
2363 : : !!
2364 : : !! SOURCE
2365 : :
2366 : 0 : subroutine testcode_ctqmc_b(energy_level,hybri_coeff,weiss_for_rot,dmftqmc_l,fw1_nd,levels_ctqmc,&
2367 [ # # # # : 0 : & levels_ctqmc_nd,hybri_limit,temp,umod,opt_diag,opt_fk)
# # # # ]
2368 : :
2369 : : !Arguments ------------------------------------
2370 : : !scalars
2371 : : integer, intent(in) :: dmftqmc_l,opt_diag,opt_fk
2372 : : real(dp), intent(in) :: temp
2373 : : real(dp), intent(out) :: umod(2,2)
2374 : : real(dp), intent(inout) :: levels_ctqmc(:)
2375 : : complex(dp), intent(out) :: fw1_nd(:,:,:)
2376 : : complex(dp), intent(inout) :: levels_ctqmc_nd(:,:)
2377 : : complex(dp), intent(inout) :: hybri_limit(:,:)
2378 : : type(oper_type) :: energy_level
2379 : : type(matlu_type), allocatable :: hybri_coeff(:)
2380 : : type(green_type) :: weiss_for_rot
2381 : :
2382 : : !Local variables ------------------------------
2383 : : integer :: ifreq,iatom,ima,imb,ispa,ispb,ndim
2384 : : real(dp) :: omega
2385 : : real(dp) :: facnd, facd
2386 : : character(len=30) :: tmpfil
2387 : : ! ************************************************************************
2388 : 0 : facnd=0.8d0
2389 : 0 : facd=1.0d0
2390 : 0 : ndim=2*energy_level%matlu(iatom)%lpawu+1
2391 : : !write(6,*) "fac",facnd,facd
2392 : 0 : levels_ctqmc_nd(2,2) = energy_level%matlu(iatom)%mat(imb+(ispb-1)*ndim,imb+(ispb-1)*ndim,1)
2393 : 0 : levels_ctqmc_nd(1,1) = energy_level%matlu(iatom)%mat(ima+(ispa-1)*ndim,ima+(ispa-1)*ndim,1)
2394 : 0 : levels_ctqmc(2) = real(energy_level%matlu(iatom)%mat(imb+(ispb-1)*ndim,imb+(ispb-1)*ndim,1),kind=dp)
2395 : 0 : levels_ctqmc(1) = real(energy_level%matlu(iatom)%mat(ima+(ispa-1)*ndim,ima+(ispa-1)*ndim,1),kind=dp)
2396 [ # # ]: 0 : if(opt_diag/=1) then
2397 : 0 : levels_ctqmc_nd(1,2) = energy_level%matlu(iatom)%mat(ima+(ispa-1)*ndim,imb+(ispb-1)*ndim,1)
2398 : 0 : levels_ctqmc_nd(2,1) = energy_level%matlu(iatom)%mat(imb+(ispb-1)*ndim,ima+(ispa-1)*ndim,1)
2399 : : end if
2400 : 0 : hybri_limit(1,1) = facd*hybri_coeff(iatom)%mat(ima+(ispa-1)*ndim,ima+(ispa-1)*ndim,1)
2401 : 0 : hybri_limit(2,2) = facd*hybri_coeff(iatom)%mat(imb+(ispb-1)*ndim,imb+(ispb-1)*ndim,1)
2402 : 0 : hybri_limit(1,2) = facnd*hybri_coeff(iatom)%mat(ima+(ispa-1)*ndim,imb+(ispb-1)*ndim,1)
2403 : 0 : hybri_limit(2,1) = facnd*hybri_coeff(iatom)%mat(imb+(ispb-1)*ndim,ima+(ispa-1)*ndim,1)
2404 : : !write(6,*) "hybri_limit",hybri_limit
2405 : : !write(6,*) "levels_ctqmc",levels_ctqmc
2406 : 0 : umod=zero
2407 : :
2408 : : tmpfil = 'fw1_nd_re'
2409 : : !if (open_file(newunit=unt,message,file=trim(tmpfil),status='unknown',form='formatted')/=0) then
2410 : : ! ABI_ERROR(message)
2411 : : !end if
2412 : 0 : tmpfil = 'fw1_nd_im'
2413 : : !if (open_file(newunit=unt2,message,file=trim(tmpfil),status='unknown',form='formatted')/=0) then
2414 : : ! ABI_ERROR(message)
2415 : : !end if
2416 : 0 : write(std_out,*) "testcode==2",ispa,ispb,ima,imb
2417 : 0 : write(std_out,*) "opt_fk==",opt_fk
2418 [ # # ]: 0 : do ifreq=1,dmftqmc_l
2419 [ # # ]: 0 : if (opt_fk==1) then
2420 : 0 : fw1_nd(ifreq,1,1) = facd*weiss_for_rot%oper(ifreq)%matlu(iatom)%mat(ima+(ispa-1)*ndim,ima+(ispa-1)*ndim,1)
2421 : 0 : fw1_nd(ifreq,2,2) = facd*weiss_for_rot%oper(ifreq)%matlu(iatom)%mat(imb+(ispb-1)*ndim,imb+(ispb-1)*ndim,1)
2422 : : !fw1_nd(ifreq,1,2) = weiss_for_rot%oper(ifreq)%matlu(iatom)%mat(ima,imb,1,ispa,ispb)
2423 : : !fw1_nd(ifreq,2,1) = weiss_for_rot%oper(ifreq)%matlu(iatom)%mat(imb,ima,1,ispb,ispa)
2424 : 0 : fw1_nd(ifreq,1,2) = facnd*weiss_for_rot%oper(ifreq)%matlu(iatom)%mat(ima+(ispa-1)*ndim,imb+(ispb-1)*ndim,1)
2425 : 0 : fw1_nd(ifreq,2,1) = facnd*weiss_for_rot%oper(ifreq)%matlu(iatom)%mat(imb+(ispb-1)*ndim,ima+(ispa-1)*ndim,1)
2426 : 0 : omega=pi*temp*(two*float(ifreq)-1)
2427 [ # # ]: 0 : else if (opt_fk==0) then
2428 : 0 : fw1_nd(ifreq,1,1) = facd*weiss_for_rot%oper(ifreq)%matlu(iatom)%mat(ima+(ispa-1)*ndim,ima+(ispa-1)*ndim,1)
2429 : 0 : fw1_nd(ifreq,2,2) = facd*weiss_for_rot%oper(ifreq)%matlu(iatom)%mat(imb+(ispb-1)*ndim,imb+(ispb-1)*ndim,1)
2430 : 0 : fw1_nd(ifreq,1,2) = facnd*weiss_for_rot%oper(ifreq)%matlu(iatom)%mat(ima+(ispa-1)*ndim,imb+(ispb-1)*ndim,1)
2431 : 0 : fw1_nd(ifreq,2,1) = facnd*weiss_for_rot%oper(ifreq)%matlu(iatom)%mat(imb+(ispb-1)*ndim,ima+(ispa-1)*ndim,1)
2432 [ # # # # : 0 : call xginv(fw1_nd(ifreq,:,:),2)
# # # # #
# # # #
# ]
2433 : : end if
2434 : : end do
2435 : 0 : end subroutine testcode_ctqmc_b
2436 : : !!***
2437 : :
2438 : :
2439 : : !!****f* m_forctqmc/testcode_ctqmc
2440 : : !! NAME
2441 : : !! testcode_ctqmc
2442 : : !!
2443 : : !! FUNCTION
2444 : : !! Setup ultra simple hybridization to test CTQMC in simple situations.
2445 : : !!
2446 : : !! INPUTS
2447 : : !! gtmp_nd
2448 : : !! gw_tmp_nd
2449 : : !! temp = temperature
2450 : : !! dmftqmc_l = number of times slices
2451 : : !! nflavor = number of flavor
2452 : : !! testrot = 0/1 if rotation of hybridization is tested or not
2453 : : !! testcode = 1 if tests are activated.
2454 : : !! opt = 1/2 if pre or postprocessing of CTQMC data.
2455 : : !!
2456 : : !! OUTPUT
2457 : : !! fw1_nd = non diagonal hybridization
2458 : : !! fw1 = hybridization
2459 : : !! umod = value of U
2460 : : !!
2461 : : !!
2462 : : !! SIDE EFFECTS
2463 : : !! gtmp_nd
2464 : : !! gw_tmp_nd
2465 : : !!
2466 : : !! NOTES
2467 : : !!
2468 : : !! SOURCE
2469 : :
2470 [ # # # # : 0 : subroutine testcode_ctqmc(dmftqmc_l,fw1_nd,fw1,gtmp_nd,gw_tmp_nd,levels_ctqmc,hybri_limit,&
# # # # #
# # # ]
2471 : : & nflavor,opt,temp,testrot,testcode,umod)
2472 : :
2473 : :
2474 : : !Arguments ------------------------------------
2475 : : !scalars
2476 : : integer, intent(in) :: dmftqmc_l,nflavor,testrot,testcode,opt
2477 : : real(dp), intent(in) :: temp
2478 : : real(dp), intent(out) :: umod(2,2)
2479 : : complex(dp), intent(inout) :: gw_tmp_nd(:,:,:)
2480 : : real(dp), intent(inout) :: gtmp_nd(:,:,:)
2481 : : complex(dp), intent(out) :: fw1(:,:)
2482 : : complex(dp), intent(out) :: fw1_nd(:,:,:)
2483 : : real(dp), intent(inout) :: levels_ctqmc(:)
2484 : : complex(dp), intent(inout) :: hybri_limit(:,:)
2485 : :
2486 : : !Local variables ------------------------------
2487 : : character(len=500) :: message
2488 : : integer :: ifreq, itau,realrot,simplehyb
2489 : : real(dp) :: omega
2490 : : real(dp) :: tbi1,tbi2,e2,tbi3,tbi4,e3,e4,tbi21,tbi12,e3b,e4b,tbi21b,tbi12b
2491 : : complex(dp) :: e1
2492 : : ! arrays
2493 : : complex(dp) :: RR(2,2)
2494 : : complex(dp) :: RR1(2,2)
2495 : : complex(dp) :: RRi(2,2)
2496 : : complex(dp) :: RRt(2,2)
2497 : : ! ************************************************************************
2498 [ # # ]: 0 : if (testcode==0) return
2499 [ # # ]: 0 : if (nflavor/=2) then
2500 : 0 : write(message,'(2a)') ch10,' testcode nflavor.ne.2'
2501 : 0 : ABI_ERROR(message)
2502 : : end if
2503 : :
2504 : : simplehyb=2
2505 : : simplehyb=1
2506 : 0 : simplehyb=3
2507 : : !=========================
2508 : : ! Built rotation matrix
2509 : : !=========================
2510 : : realrot=0
2511 : 0 : realrot=2
2512 : : if (realrot==1) then
2513 : : ! Real rotation
2514 : : !=========================
2515 : : RR(1,1) = SQRT(3.d0)/2.d0
2516 : : RR(1,2) = -1.d0/2.d0
2517 : : RR(2,1) = 1.d0/2.d0
2518 : : RR(2,2) = SQRT(3.d0)/2.d0
2519 : : else if (realrot==2) then
2520 : : ! Real rotation
2521 : : !=========================
2522 : 0 : RR(1,1) = SQRT(1.d0/2.d0)
2523 : 0 : RR(1,2) = -SQRT(1.d0/2.d0)
2524 : 0 : RR(2,1) = SQRT(1.d0/2.d0)
2525 : 0 : RR(2,2) = SQRT(1.d0/2.d0)
2526 : : else
2527 : : ! Complex rotation
2528 : : !=========================
2529 : : RR(1,1) = CMPLX(one,two)
2530 : : RR(1,2) = CMPLX(one,one)
2531 : : RR(2,1) = CMPLX(one,-one)
2532 : : RR(2,2) = CMPLX(-one,two)
2533 : : RR=RR/sqrt(seven)
2534 : : end if
2535 : : ! Check rotation is unitary
2536 : : !==========================
2537 : 0 : RRi(1,1) = conjg(RR(1,1))
2538 : 0 : RRi(1,2) = conjg(RR(2,1))
2539 : 0 : RRi(2,1) = conjg(RR(1,2))
2540 : 0 : RRi(2,2) = conjg(RR(2,2))
2541 [ # # # # : 0 : RR1(:,:) = MATMUL ( RR(:,:) , RRi(:,:) )
# # ]
2542 : : !write(6,*) "RR1",RR1
2543 [ # # # # : 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
# # # # ]
2544 : 0 : write(message,'(2a)') ch10,' testcode error in rotation matrix'
2545 : 0 : ABI_ERROR(message)
2546 : : end if
2547 : :
2548 : :
2549 : : !=================================
2550 : : ! Built hybridization for CTQMC
2551 : : !=================================
2552 [ # # ]: 0 : if (opt==1) then
2553 : :
2554 : : ! Parameters: tight-binding + U
2555 : : ! firt test of the code try umod=0, and (tbi1,tbi2,e1,e2)=(2,1,0.5,0.0) testrot=1
2556 : : ! second test of the code try umod=four, and (tbi1,tbi2,e1,e2)=(2,1,0.0,0.0) testrot=1
2557 : : !=======================================================================================
2558 [ # # # # : 0 : fw1_nd(:,:,:)= czero
# # ]
2559 : 0 : tbi1=2.0_dp
2560 : 0 : tbi2=1.0_dp
2561 : 0 : tbi3=1.0_dp
2562 : 0 : tbi4=1.0_dp
2563 : 0 : tbi12=2.5_dp
2564 : 0 : tbi12b=2.5_dp
2565 : 0 : tbi21=2.5_dp
2566 : 0 : tbi21b=2.5_dp
2567 : 0 : e1=cmplx(0.0,0.0,8)
2568 : 0 : e2=zero
2569 : 0 : e3=0.2
2570 : 0 : e4=0.3
2571 : 0 : e3b=0.3
2572 : 0 : e4b=-0.2
2573 : 0 : umod(:,:)=0.d0
2574 : :
2575 : : if(testrot==1.and.(abs(tbi1-tbi2)<tol6)) then
2576 : : write(message,'(3a)') ch10,' testrot=1 with tbi1=tbi2 is equivalent' &
2577 : : ,'to testrot=0: change testrot'
2578 : : ABI_WARNING(message)
2579 : : end if
2580 : : ! Built fw1_nd
2581 : : !==============
2582 [ # # ]: 0 : do ifreq=1,dmftqmc_l
2583 : :
2584 : 0 : omega=pi*temp*(two*float(ifreq)-1)
2585 : :
2586 : : if(simplehyb==1) then
2587 : : fw1_nd(ifreq,1,1) = -umod(1,1)/two+tbi1**2/(dcmplx(0.d0,omega)-e1)
2588 : : fw1_nd(ifreq,2,2) = -umod(1,1)/two+tbi2**2/(dcmplx(0.d0,omega)-e2)
2589 : : fw1(ifreq,1) = -umod(1,1)/two+tbi1**2/(dcmplx(0.d0,omega)-e1)
2590 : : fw1(ifreq,2) = -umod(1,1)/two+tbi2**2/(dcmplx(0.d0,omega)-e2)
2591 : : hybri_limit(1,1)=tbi1**2
2592 : : hybri_limit(2,2)=tbi2**2
2593 : : hybri_limit(1,2)=0.d0
2594 : : hybri_limit(2,1)=0.d0
2595 : : else if(simplehyb==2) then
2596 : : fw1_nd(ifreq,1,1) = -umod(1,1)/two+tbi1**2/(dcmplx(0.d0,omega)-e1)+tbi3**2/(dcmplx(0.d0,omega)-e3)
2597 : : fw1_nd(ifreq,2,2) = -umod(1,1)/two+tbi2**2/(dcmplx(0.d0,omega)-e2)+tbi4**2/(dcmplx(0.d0,omega)-e4)
2598 : : fw1(ifreq,1) = -umod(1,1)/two+tbi1**2/(dcmplx(0.d0,omega)-e1)
2599 : : fw1(ifreq,2) = -umod(1,1)/two+tbi2**2/(dcmplx(0.d0,omega)-e2)
2600 : : else if(simplehyb==3) then
2601 : 0 : fw1_nd(ifreq,1,1) = -umod(1,1)/two+tbi1**2/(dcmplx(0.d0,omega)-e1)
2602 : 0 : fw1_nd(ifreq,2,2) = -umod(1,1)/two+tbi2**2/(dcmplx(0.d0,omega)-e2)
2603 : 0 : fw1_nd(ifreq,1,2) = tbi12**2/(dcmplx(0.d0,omega)-e3)+tbi12b**2/(dcmplx(0.d0,omega)-e3b)
2604 : 0 : fw1_nd(ifreq,2,1) = tbi21**2/(dcmplx(0.d0,omega)-e4)+tbi21b**2/(dcmplx(0.d0,omega)-e4b)
2605 : 0 : fw1(ifreq,1) = -umod(1,1)/two+tbi1**2/(dcmplx(0.d0,omega)-e1)
2606 : 0 : fw1(ifreq,2) = -umod(1,1)/two+tbi2**2/(dcmplx(0.d0,omega)-e2)
2607 : 0 : hybri_limit(1,1)=tbi1**2
2608 : 0 : hybri_limit(2,2)=tbi2**2
2609 : 0 : hybri_limit(1,2)=tbi12**2+tbi12b**2
2610 : 0 : hybri_limit(2,1)=tbi21**2+tbi21b**2
2611 : : end if
2612 : 0 : write(132,*) omega,real(fw1_nd(ifreq,1,1)),aimag(fw1_nd(ifreq,1,1))
2613 : 0 : write(133,*) omega,real(fw1_nd(ifreq,1,2)),aimag(fw1_nd(ifreq,1,2))
2614 : 0 : write(134,*) omega,real(fw1_nd(ifreq,2,1)),aimag(fw1_nd(ifreq,2,1))
2615 : 0 : write(135,*) omega,real(fw1_nd(ifreq,2,2)),aimag(fw1_nd(ifreq,2,2))
2616 : 0 : write(1234,*) omega, real(fw1(ifreq,1)),aimag(fw1(ifreq,1))
2617 : : end do
2618 : : ! Built level and limit of hybridization
2619 : : !=======================================
2620 [ # # ]: 0 : levels_ctqmc(1:nflavor)=-umod(1,1)/two
2621 : :
2622 : 0 : write(std_out,*) "fw1_nd"
2623 : 0 : write(std_out,*) fw1_nd(1,1,1), fw1_nd(1,1,2)
2624 : 0 : write(std_out,*) fw1_nd(1,2,1), fw1_nd(1,2,2)
2625 : 0 : write(std_out,*) "fw1"
2626 : 0 : write(std_out,*) fw1(1,1), fw1(1,2)
2627 : 0 : write(std_out,*) fw1(2,1), fw1(2,2)
2628 : :
2629 : : ! Rotate hybridization if testrot=1
2630 : : !==================================
2631 [ # # ]: 0 : if(testrot==1) then
2632 : :
2633 [ # # ]: 0 : do ifreq=1,dmftqmc_l
2634 [ # # # # : 0 : RRt(:,:) = MATMUL ( RR(:,:) , fw1_nd(ifreq,:,:) )
# # # # ]
2635 : : !write(6,*) "RRt"
2636 : : !write(6,*) RRt(1,1), RRt(1,2)
2637 : : !write(6,*) RRt(2,1), RRt(2,2)
2638 [ # # # # : 0 : RR1(:,:) = MATMUL ( RRt(:,:) , RRi(:,:) )
# # ]
2639 : : !write(6,*) "RR1"
2640 : : !write(6,*) RR1(1,1), RR1(1,2)
2641 : : !write(6,*) RR1(2,1), RR1(2,2)
2642 [ # # # # ]: 0 : fw1_nd(ifreq,:,:)=RR1(:,:)
2643 : 0 : omega=pi*temp*(two*float(ifreq)+1)
2644 : 0 : write(3322,*) omega,real(fw1_nd(ifreq,1,1)),aimag(fw1_nd(ifreq,1,1))
2645 : 0 : write(232,*) omega,real(fw1_nd(ifreq,1,1)),aimag(fw1_nd(ifreq,1,1))
2646 : 0 : write(233,*) omega,real(fw1_nd(ifreq,1,2)),aimag(fw1_nd(ifreq,1,2))
2647 : 0 : write(234,*) omega,real(fw1_nd(ifreq,2,1)),aimag(fw1_nd(ifreq,2,1))
2648 : 0 : write(235,*) omega,real(fw1_nd(ifreq,2,2)),aimag(fw1_nd(ifreq,2,2))
2649 : : end do
2650 : :
2651 : : ! Rotate limit of hybridization
2652 : : !=======================================
2653 [ # # # # : 0 : RRt(:,:) = MATMUL ( RR(:,:) , hybri_limit(:,:) )
# # # # ]
2654 [ # # # # : 0 : RR1(:,:) = MATMUL ( RRt(:,:) , RRi(:,:) )
# # ]
2655 [ # # # # ]: 0 : hybri_limit(:,:)=RR1(:,:)
2656 : :
2657 : : end if
2658 : : ! rajouter test real(fw1_nd(1,:,:)) doit etre diagonale
2659 : :
2660 : : !======================================
2661 : : ! Rotate Green's function from CTQMC
2662 : : !======================================
2663 [ # # ]: 0 : else if(opt==2) then
2664 : :
2665 : 0 : write(std_out,*) "gw_tmp_nd"
2666 : 0 : write(std_out,*) gw_tmp_nd(1,1,1), gw_tmp_nd(1,1,2)
2667 : 0 : write(std_out,*) gw_tmp_nd(1,2,1), gw_tmp_nd(1,2,2)
2668 : : ! Rotate Green's function back
2669 : : !==============================
2670 [ # # ]: 0 : if(testrot==1) then
2671 [ # # ]: 0 : do ifreq=1,dmftqmc_l
2672 [ # # # # : 0 : RRt(1:nflavor,1:nflavor) = MATMUL ( RRi(1:nflavor,1:nflavor),gw_tmp_nd(ifreq,1:nflavor,1:nflavor) )
# # # # #
# # # # #
# # ]
2673 [ # # # # : 0 : RR1(1:nflavor,1:nflavor) = MATMUL ( RRt(1:nflavor,1:nflavor),RR(1:nflavor,1:nflavor) )
# # # # #
# # # # #
# # ]
2674 [ # # # # ]: 0 : gw_tmp_nd(ifreq,1:nflavor,1:nflavor)=RR1(1:nflavor,1:nflavor)
2675 : : end do
2676 : :
2677 : 0 : write(std_out,*) "gw_tmp_nd after rotation"
2678 : 0 : write(std_out,*) gw_tmp_nd(1,1,1), gw_tmp_nd(1,1,2)
2679 : 0 : write(std_out,*) gw_tmp_nd(1,2,1), gw_tmp_nd(1,2,2)
2680 : :
2681 [ # # ]: 0 : do itau=1,dmftqmc_l
2682 [ # # # # : 0 : RRt(1:nflavor,1:nflavor) = MATMUL ( RRi(1:nflavor,1:nflavor),gtmp_nd(itau,1:nflavor,1:nflavor) )
# # # # #
# # # # #
# # # # #
# # # ]
2683 [ # # # # : 0 : RR1(1:nflavor,1:nflavor) = MATMUL ( RRt(1:nflavor,1:nflavor),RR(1:nflavor,1:nflavor) )
# # # # #
# # # # #
# # ]
2684 [ # # # # ]: 0 : gtmp_nd(itau,1:nflavor,1:nflavor)=real(RR1(1:nflavor,1:nflavor))
2685 : : end do
2686 : :
2687 : : ! Rotate Green's function for comparison with testrot=1
2688 : : !======================================================
2689 [ # # ]: 0 : else if (testrot==0) then ! produce rotated green's function to compare to testrot=1 case
2690 : :
2691 [ # # ]: 0 : do itau=1,dmftqmc_l
2692 [ # # # # : 0 : RRt(1:nflavor,1:nflavor) = MATMUL ( RR(1:nflavor,1:nflavor),gtmp_nd(itau,1:nflavor,1:nflavor) )
# # # # #
# # # # #
# # # # #
# # # ]
2693 [ # # # # : 0 : RR1(1:nflavor,1:nflavor) = MATMUL ( RRt(1:nflavor,1:nflavor),RRi(1:nflavor,1:nflavor) )
# # # # #
# # # # #
# # ]
2694 : 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))
2695 : : end do
2696 : :
2697 : : end if
2698 : :
2699 : : ! Print out rotated Green's function
2700 : : !=====================================
2701 [ # # ]: 0 : do itau=1,dmftqmc_l
2702 : 0 : write(555,'(e14.5,4(2e14.5,3x))') real(itau-1)/(temp*real(dmftqmc_l)),gtmp_nd(itau,1,1),&
2703 : 0 : & gtmp_nd(itau,2,2),gtmp_nd(itau,1,2),gtmp_nd(itau,2,1)
2704 : : end do
2705 : :
2706 : 0 : write(message,'(2a)') ch10,' testcode end of test calculation'
2707 : 0 : ABI_ERROR(message)
2708 : :
2709 : : end if
2710 : 0 : close(444)
2711 : 0 : close(555)
2712 : :
2713 : : end subroutine testcode_ctqmc
2714 : : !!***
2715 : :
2716 : : !!****f* m_forctqmc/ctqmcoutput_to_green
2717 : : !! NAME
2718 : : !! ctqmcoutput_to_green
2719 : : !!
2720 : : !! FUNCTION
2721 : : !! Put values of green function from ctqmc into green datatype
2722 : : !! Symetrize over spin if calculation is non magnetic
2723 : : !!
2724 : : !! INPUTS
2725 : : !! paw_dmft <type(paw_dmft_type)>= DMFT data structure
2726 : : !! gtmp_nd(dmftqmc_l,nflavor,nflavor) = Green's fct in imag time (with off diag terms)
2727 : : !! gtmp_ndc(dmftqmc_l,nflavor,nflavor) = Complex Green's fct in imag time (with off diag terms)
2728 : : !! gw_tmp_nd(nb_of_frequency,nflavor,nflavor) = Green's fct in imag freq (with off diag terms)
2729 : : !! gtmp(dmftqmc_l,nflavor) = Green's fct in imag time (diag)
2730 : : !! gw_tmp(nb_of_frequency,nflavor+1) =Green's fct in imag freq (diag)
2731 : : !! iatom = atoms on which the calculation has been done
2732 : : !! leg_measure = logical, to Legendre Measurement or not (if done Green function is frequency is computed)
2733 : : !! opt_nondiag = integer, it activated, then
2734 : : !! opt_complex = integer, 1 activate complex Gtau
2735 : : !!
2736 : : !! OUTPUT
2737 : : !! green <type(green_type)>= green's function
2738 : : !!
2739 : : !!
2740 : : !! SIDE EFFECTS
2741 : : !!
2742 : : !! NOTES
2743 : : !!
2744 : : !! SOURCE
2745 : :
2746 : 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)
2747 : :
2748 : : !Arguments ------------------------------------
2749 : : !scalars
2750 : : type(paw_dmft_type), intent(in) :: paw_dmft
2751 : : type(green_type), intent(inout) :: green
2752 : : real(dp), allocatable, intent(in) :: gtmp_nd(:,:,:)
2753 : : complex(dpc), allocatable, intent(in) :: gtmp_ndc(:,:,:)
2754 : : complex(dpc), allocatable, intent(in) :: gw_tmp(:,:)
2755 : : complex(dpc), allocatable, intent(in) :: gw_tmp_nd(:,:,:)
2756 : : real(dp), allocatable, intent(in) :: gtmp(:,:)
2757 : : integer, intent(in) :: iatom,opt_nondiag,opt_complex
2758 : : logical(kind=1), intent(in) :: leg_measure
2759 : : character(len=500) :: message
2760 : :
2761 : : !Local variables ------------------------------
2762 : : integer :: ifreq, itau,im1,im2,isppol,ispinor1,ispinor2,iflavor1
2763 : : integer :: iflavor2,tndim,ispinor,iflavor,im,nflavor
2764 : : ! ************************************************************************
2765 : 46 : tndim=2*paw_dmft%lpawu(iatom)+1
2766 : 46 : nflavor=2*(tndim)
2767 : :
2768 [ + + ]: 11196 : do itau=1,paw_dmft%dmftqmc_l
2769 [ + + + + : 1222796 : green%oper_tau(itau)%matlu(iatom)%mat(:,:,:)=czero
+ + ]
2770 : : end do
2771 [ + + + + : 718 : green%occup_tau%matlu(iatom)%mat(nflavor:,:,:)=czero
+ + ]
2772 : :
2773 [ + + ]: 26363 : do ifreq=1,paw_dmft%dmft_nwlo
2774 [ + + + + : 2880361 : green%oper(ifreq)%matlu(iatom)%mat(:,:,:)=czero
+ + ]
2775 : : end do
2776 [ + + + + : 4364 : green%occup%matlu(iatom)%mat(:,:,:)=czero
+ + ]
2777 : :
2778 : : ! built time and frequency green's function from output of CTQMC
2779 : : ! =================================================================
2780 [ + + - + ]: 46 : if(opt_nondiag==1 .and. opt_complex==0) then
2781 [ # # ]: 0 : do isppol=1,paw_dmft%nsppol
2782 [ # # ]: 0 : do ispinor1=1,paw_dmft%nspinor
2783 [ # # ]: 0 : do im1=1,tndim
2784 : 0 : iflavor1=im1+tndim*(ispinor1-1)+tndim*(isppol-1)
2785 [ # # ]: 0 : do ispinor2=1,paw_dmft%nspinor
2786 [ # # ]: 0 : do im2=1,tndim
2787 : 0 : iflavor2=im2+tndim*(ispinor2-1)+tndim*(isppol-1)
2788 [ # # ]: 0 : do itau=1,paw_dmft%dmftqmc_l
2789 : : green%oper_tau(itau)%matlu(iatom)%mat(im1+(ispinor1-1)*tndim,im2+(ispinor2-1)*tndim,isppol)=&
2790 : 0 : & gtmp_nd(itau,iflavor1,iflavor2)
2791 : : ! symetrize over spin if nsppol=nspinor=1
2792 [ # # # # ]: 0 : if(paw_dmft%nsppol==1.and.paw_dmft%nspinor==1) then
2793 : : green%oper_tau(itau)%matlu(iatom)%mat(im1+(ispinor1-1)*tndim,im2+(ispinor2-1)*tndim,isppol)=&
2794 : 0 : & (gtmp_nd(itau,iflavor1,iflavor2)+gtmp_nd(itau,iflavor1+tndim,iflavor2+tndim))/two
2795 : : end if
2796 : : end do !itau
2797 [ # # # # ]: 0 : if(paw_dmft%dmft_solv<6.or.leg_measure) then
2798 [ # # ]: 0 : do ifreq=1,paw_dmft%dmft_nwlo
2799 : : green%oper(ifreq)%matlu(iatom)%mat(im1+(ispinor1-1)*tndim,im2+(ispinor2-1)*tndim,isppol)=&
2800 : 0 : & gw_tmp_nd(ifreq,iflavor1,iflavor2)
2801 : : ! symetrize over spin if nsppol=nspinor=1
2802 [ # # # # ]: 0 : if(paw_dmft%nsppol==1.and.paw_dmft%nspinor==1) then
2803 : : green%oper(ifreq)%matlu(iatom)%mat(im1+(ispinor1-1)*tndim,im2+(ispinor2-1)*tndim,isppol)=&
2804 : : & (gw_tmp_nd(ifreq,iflavor1,iflavor2)+&
2805 : 0 : & gw_tmp_nd(ifreq,iflavor1+tndim,iflavor2+tndim))/two
2806 : : end if
2807 : : end do ! ifreq
2808 : : end if
2809 : : end do ! im2
2810 : : end do ! ispinor2
2811 : : end do ! im1
2812 : : end do ! ispinor
2813 : : end do ! isppol
2814 : : != Complex case
2815 [ + + + - ]: 46 : elseif(opt_nondiag==1 .and. opt_complex==1) then
2816 [ + + ]: 24 : do isppol=1,paw_dmft%nsppol
2817 [ + + ]: 48 : do ispinor1=1,paw_dmft%nspinor
2818 [ + + ]: 204 : do im1=1,tndim
2819 : 168 : iflavor1=im1+tndim*(ispinor1-1)+tndim*(isppol-1)
2820 [ + + ]: 528 : do ispinor2=1,paw_dmft%nspinor
2821 [ + + ]: 2856 : do im2=1,tndim
2822 : 2352 : iflavor2=im2+tndim*(ispinor2-1)+tndim*(isppol-1)
2823 [ + + ]: 707952 : do itau=1,paw_dmft%dmftqmc_l
2824 : : green%oper_tau(itau)%matlu(iatom)%mat(im1+(ispinor1-1)*tndim,im2+(ispinor2-1)*tndim,isppol)=&
2825 : 705600 : & gtmp_ndc(itau,iflavor1,iflavor2)
2826 : : ! symetrize over spin if nsppol=nspinor=1
2827 [ + - - + ]: 707952 : if(paw_dmft%nsppol==1.and.paw_dmft%nspinor==1) then
2828 : : green%oper_tau(itau)%matlu(iatom)%mat(im1+(ispinor1-1)*tndim,im2+(ispinor2-1)*tndim,isppol)=&
2829 : 0 : & (gtmp_ndc(itau,iflavor1,iflavor2)+gtmp_ndc(itau,iflavor1+tndim,iflavor2+tndim))/two
2830 : : end if
2831 : : end do !itau
2832 [ + + ]: 1646736 : do ifreq=1,paw_dmft%dmft_nwlo
2833 : : green%oper(ifreq)%matlu(iatom)%mat(im1+(ispinor1-1)*tndim,im2+(ispinor2-1)*tndim,isppol)=&
2834 : 1644048 : & gw_tmp_nd(ifreq,iflavor1,iflavor2)
2835 : : ! symetrize over spin if nsppol=nspinor=1
2836 [ + - - + ]: 1646400 : if(paw_dmft%nsppol==1.and.paw_dmft%nspinor==1) then
2837 : : green%oper(ifreq)%matlu(iatom)%mat(im1+(ispinor1-1)*tndim,im2+(ispinor2-1)*tndim,isppol)=&
2838 : : & (gw_tmp_nd(ifreq,iflavor1,iflavor2)+&
2839 : 0 : & gw_tmp_nd(ifreq,iflavor1+tndim,iflavor2+tndim))/two
2840 : : end if
2841 : : end do ! ifreq
2842 : : end do ! im2
2843 : : end do ! ispinor2
2844 : : end do ! im1
2845 : : end do ! ispinor
2846 : : end do ! isppol
2847 : : else
2848 : 34 : iflavor=0
2849 [ + + ]: 88 : do isppol=1,paw_dmft%nsppol
2850 [ + + ]: 142 : do ispinor=1,paw_dmft%nspinor
2851 [ + + ]: 378 : do im=1,tndim
2852 : 270 : iflavor=iflavor+1
2853 [ + + ]: 72270 : do itau=1,paw_dmft%dmftqmc_l
2854 : 72000 : green%oper_tau(itau)%matlu(iatom)%mat(im+(ispinor-1)*tndim,im+(ispinor-1)*tndim,isppol)=gtmp(itau,iflavor)
2855 : : ! symetrize over spin if nsppol=paw_dmft%nspinor=1
2856 [ + + + - ]: 72270 : if(paw_dmft%nsppol==1.and.paw_dmft%nspinor==1) then
2857 : : green%oper_tau(itau)%matlu(iatom)%mat(im+(ispinor-1)*tndim,im+(ispinor-1)*tndim,isppol)=&
2858 : 4900 : & (gtmp(itau,iflavor)+gtmp(itau,iflavor+tndim))/two
2859 : : end if
2860 : : end do
2861 : : ! ifreq2=0
2862 [ + + ]: 173482 : do ifreq=1,paw_dmft%dmft_nwlo
2863 : : ! if(paw_dmft%select_log(ifreq)==1) then
2864 : : ! ifreq2=ifreq2+1
2865 : 173158 : green%oper(ifreq)%matlu(iatom)%mat(im+(ispinor-1)*tndim,im+(ispinor-1)*tndim,isppol)=gw_tmp(ifreq,iflavor)
2866 : : ! symetrize over spin if nsppol=paw_dmft%nspinor=1
2867 [ + + + - ]: 173428 : if(paw_dmft%nsppol==1.and.paw_dmft%nspinor==1) then
2868 : : green%oper(ifreq)%matlu(iatom)%mat(im+(ispinor-1)*tndim,im+(ispinor-1)*tndim,isppol)=&
2869 : 8820 : & (gw_tmp(ifreq,iflavor)+gw_tmp(ifreq,iflavor+tndim))/two
2870 : : end if
2871 : : end do
2872 : : end do
2873 : : end do
2874 : : end do
2875 : : end if
2876 [ + + + + ]: 46 : if(paw_dmft%nsppol==1.and.paw_dmft%nspinor==1) then
2877 : 14 : write(message,'(a,2x,a,f13.5)') ch10,&
2878 : 28 : & " == nsppol==1 and nspden==1: Green functions from CTQMC have been symetrized over spin"
2879 : 14 : call wrtout(std_out,message,'COLL')
2880 : : end if
2881 : :
2882 : 46 : end subroutine ctqmcoutput_to_green
2883 : : !!***
2884 : :
2885 : : !!****f* m_forctqmc/ctqmcoutput_printgreen
2886 : : !! NAME
2887 : : !! ctqmcoutput_printgreen
2888 : : !!
2889 : : !! FUNCTION
2890 : : !! Print values of green function in files.
2891 : : !! Symetrize imaginary time Green's function in a peculiar case
2892 : : !! (dmft_solv=8 and natom=1). Should be moved later.
2893 : : !!
2894 : : !! INPUTS
2895 : : !! paw_dmft <type(paw_dmft_type)>= DMFT data structure
2896 : : !! gtmp_nd(dmftqmc_l,nflavor,nflavor) = Green's fct in imag time (with off diag terms)
2897 : : !! gtmp_ndc(dmftqmc_l,nflavor,nflavor) = Complex Green's fct in imag time (with off diag terms)
2898 : : !! gw_tmp_nd(nb_of_frequency,nflavor,nflavor) = Green's fct in imag freq (with off diag terms)
2899 : : !! gtmp(dmftqmc_l,nflavor) = Green's fct in imag time (diag)
2900 : : !! gw_tmp(nb_of_frequency,nflavor+1) =Green's fct in imag freq (diag)
2901 : : !! iatom = atoms on which the calculation has been done
2902 : : !!
2903 : : !! OUTPUT
2904 : : !!
2905 : : !!
2906 : : !! SIDE EFFECTS
2907 : : !!
2908 : : !! NOTES
2909 : : !!
2910 : : !! SOURCE
2911 : :
2912 : 46 : subroutine ctqmcoutput_printgreen(paw_dmft,gtmp_nd,gtmp_ndc,gw_tmp_nd,gtmp,gw_tmp,iatom)
2913 : :
2914 : : !Arguments ------------------------------------
2915 : : !scalars
2916 : : type(paw_dmft_type), intent(in) :: paw_dmft
2917 : : real(dp), allocatable, intent(inout) :: gtmp_nd(:,:,:)
2918 : : complex(dpc), allocatable, intent(in) :: gtmp_ndc(:,:,:)
2919 : : complex(dpc), allocatable, intent(in) :: gw_tmp(:,:)
2920 : : complex(dpc), allocatable, intent(in) :: gw_tmp_nd(:,:,:)
2921 : : real(dp), allocatable, intent(in) :: gtmp(:,:)
2922 : : integer, intent(in) :: iatom
2923 : :
2924 : : !Local variables ------------------------------
2925 : : character(len=500) :: message
2926 : : integer :: ifreq, itau,iflavor1
2927 : : integer :: tndim,iflavor,nflavor
2928 : : character(len=2) :: gtau_iter,iatomnb
2929 : : integer :: unt
2930 : : ! ************************************************************************
2931 : 46 : tndim=2*paw_dmft%lpawu(iatom)+1
2932 : 46 : nflavor=2*(tndim)
2933 : : !----------------------------------------
2934 : : ! <DEBUG>
2935 : : !----------------------------------------
2936 : : ! Construct UNIT
2937 [ + - ]: 46 : if(paw_dmft%idmftloop < 10) then
2938 : 46 : write(gtau_iter,'("0",i1)') paw_dmft%idmftloop
2939 [ # # ]: 0 : elseif(paw_dmft%idmftloop >= 10 .and. paw_dmft%idmftloop < 100) then
2940 : 0 : write(gtau_iter,'(i2)') paw_dmft%idmftloop
2941 : : else
2942 : 0 : gtau_iter="xx"
2943 : : end if
2944 [ + - ]: 46 : if(iatom < 10) then
2945 : 46 : write(iatomnb,'("0",i1)') iatom
2946 [ # # ]: 0 : elseif(iatom >= 10 .and. iatom < 100) then
2947 : 0 : write(iatomnb,'(i2)') iatom
2948 : : else
2949 : 0 : iatomnb='xx'
2950 : : end if
2951 : :
2952 [ + + ]: 46 : if(paw_dmft%myproc .eq. mod(paw_dmft%nproc+1,paw_dmft%nproc)) then
2953 : : ! < HACK >
2954 [ - + ]: 22 : if(paw_dmft%dmft_solv==6.or.paw_dmft%dmft_solv==7) then
2955 [ # # ]: 0 : if (open_file(trim(paw_dmft%filapp)//"_atom_"//iatomnb//"_Gw_"//gtau_iter//".dat", message, newunit=unt) /=0) then
2956 : 0 : ABI_ERROR(message)
2957 : : end if
2958 [ # # ]: 0 : do ifreq=1,paw_dmft%dmft_nwli
2959 [ # # # # ]: 0 : write(unt,'(29f21.14)') paw_dmft%omega_lo(ifreq),((gw_tmp_nd(ifreq,iflavor,iflavor)), iflavor=1, nflavor)
2960 : : end do
2961 : 0 : close(unt)
2962 : : else
2963 [ + + ]: 22 : if(paw_dmft%dmft_solv==5) then
2964 [ - + ]: 19 : if (open_file(trim(paw_dmft%filapp)//"_atom_"//iatomnb//"_Gtau_"//gtau_iter//".dat", message, newunit=unt) /= 0) then
2965 : 0 : ABI_ERROR(message)
2966 : : end if
2967 [ + + ]: 2769 : do itau=1,paw_dmft%dmftqmc_l
2968 : 2750 : write(unt,'(29f21.14)') float(itau-1)/float(paw_dmft%dmftqmc_l)/paw_dmft%temp,&
2969 : 5519 : (gtmp(itau,iflavor), iflavor=1, nflavor)
2970 : : end do
2971 [ + - + + ]: 213 : write(unt,'(29f21.14)') 1/paw_dmft%temp, (-1_dp-gtmp(1,iflavor), iflavor=1, nflavor)
2972 : 19 : close(unt)
2973 : : endif
2974 : : ! if(paw_dmft%dmft_solv==8 ) then
2975 : : ! if (open_file(trim(paw_dmft%filapp)//"_atom_"//iatomnb//"_Gtau_offdiag_unsym_"//gtau_iter//".dat",&
2976 : : !& message, newunit=unt) /= 0) then
2977 : : ! ABI_ERROR(message)
2978 : : ! end if
2979 : : ! do itau=1,paw_dmft%dmftqmc_l
2980 : : ! write(unt,'(196f21.14)') float(itau-1)/float(paw_dmft%dmftqmc_l)/paw_dmft%temp,&
2981 : : ! ((gtmp_nd(itau,iflavor,iflavor1), iflavor=1, nflavor),iflavor1=1, nflavor)
2982 : : ! end do
2983 : : ! close(unt)
2984 : : ! endif
2985 [ - + ]: 22 : if(paw_dmft%dmft_solv .eq. 8) then
2986 [ # # ]: 0 : if (open_file(trim(paw_dmft%filapp)//"_atom_"//iatomnb//"_Gtau_diag_CTQMC_"//gtau_iter//".dat",&
2987 : : & message, newunit=unt) /= 0) then
2988 : 0 : ABI_ERROR(message)
2989 : : end if
2990 [ # # ]: 0 : do itau=1,paw_dmft%dmftqmc_l
2991 : 0 : write(unt,'(196f21.14)') float(itau-1)/float(paw_dmft%dmftqmc_l)/paw_dmft%temp,&
2992 [ # # # # ]: 0 : & (gtmp_nd(itau,iflavor,iflavor), iflavor=1,nflavor)
2993 : : end do
2994 : 0 : close(unt)
2995 [ # # ]: 0 : if (open_file(trim(paw_dmft%filapp)//"_atom_"//iatomnb//"_Gtau_full_CTQMC_"//gtau_iter//".dat",&
2996 : : & message, newunit=unt) /= 0) then
2997 : 0 : ABI_ERROR(message)
2998 : : end if
2999 [ # # ]: 0 : do itau=1, paw_dmft%dmftqmc_l
3000 : 0 : write(unt,'(392f21.14)') float(itau-1)/float(paw_dmft%dmftqmc_l)/paw_dmft%temp,&
3001 : 0 : & ((gtmp_nd(itau,iflavor,iflavor1),iflavor=1,nflavor), iflavor1=1, nflavor)
3002 : : end do
3003 : 0 : close(unt)
3004 : : endif
3005 : : !complex solver
3006 [ + + ]: 22 : if(paw_dmft%dmft_solv .eq. 10) then
3007 [ - + ]: 3 : if (open_file(trim(paw_dmft%filapp)//"_atom_"//iatomnb//"_Gtau_diag_CTQMC_"//gtau_iter//".dat",&
3008 : : & message, newunit=unt) /= 0) then
3009 : 0 : ABI_ERROR(message)
3010 : : end if
3011 [ + + ]: 903 : do itau=1,paw_dmft%dmftqmc_l
3012 : 900 : write(unt,'(196f21.14)') float(itau-1)/float(paw_dmft%dmftqmc_l)/paw_dmft%temp,&
3013 [ + - + + ]: 14403 : & (gtmp_ndc(itau,iflavor,iflavor), iflavor=1,nflavor)
3014 : : end do
3015 : 3 : close(unt)
3016 [ - + ]: 3 : if (open_file(trim(paw_dmft%filapp)//"_atom_"//iatomnb//"_Gtau_full_CTQMC_"//gtau_iter//".dat",&
3017 : : & message, newunit=unt) /= 0) then
3018 : 0 : ABI_ERROR(message)
3019 : : end if
3020 [ + + ]: 903 : do itau=1, paw_dmft%dmftqmc_l
3021 : 900 : write(unt,'(2x,393(e18.10e3,2x))') float(itau-1)/float(paw_dmft%dmftqmc_l)/paw_dmft%temp,&
3022 [ + - + + : 190803 : & ((dble(gtmp_ndc(itau,iflavor,iflavor1)),aimag(gtmp_ndc(itau,iflavor,iflavor1)),iflavor=1,nflavor), iflavor1=1, nflavor)
+ - + + ]
3023 : : end do
3024 : 3 : close(unt)
3025 : : endif
3026 : : ! if(paw_dmft%natom==1) then ! If natom>1, it should be moved outside the loop over atoms
3027 : : ! ABI_MALLOC(matlu1,(paw_dmft%natom))
3028 : : ! call init_matlu(paw_dmft%natom,paw_dmft%nspinor,paw_dmft%nsppol,paw_dmft%lpawu,matlu1)
3029 : : ! do itau=1,paw_dmft%dmftqmc_l
3030 : : ! do isppol=1,paw_dmft%nsppol
3031 : : ! do ispinor1=1,paw_dmft%nspinor
3032 : : ! do im1=1,tndim
3033 : : ! iflavor1=im1+tndim*(ispinor1-1)+tndim*(isppol-1)
3034 : : ! do ispinor2=1,paw_dmft%nspinor
3035 : : ! do im2=1,tndim
3036 : : ! iflavor2=im2+tndim*(ispinor2-1)+tndim*(isppol-1)
3037 : : ! matlu1(iatom)%mat(im1,im2,isppol,ispinor1,ispinor2)=&
3038 : : !& gtmp_nd(itau,iflavor1,iflavor2)
3039 : : ! end do ! im2
3040 : : ! end do ! ispinor2
3041 : : ! end do ! im1
3042 : : ! end do ! ispinor
3043 : : ! end do ! isppol
3044 : : ! call rotate_matlu(matlu1,eigvectmatlu,paw_dmft%natom,3,0)
3045 : : ! call slm2ylm_matlu(matlu1,paw_dmft%natom,2,0)
3046 : : ! call sym_matlu(cryst_struc,matlu1,pawang,paw_dmft)
3047 : : ! call slm2ylm_matlu(matlu1,paw_dmft%natom,1,0)
3048 : : ! call rotate_matlu(matlu1,eigvectmatlu,paw_dmft%natom,3,1)
3049 : : ! do isppol=1,paw_dmft%nsppol
3050 : : ! do ispinor1=1,paw_dmft%nspinor
3051 : : ! do im1=1,tndim
3052 : : ! iflavor1=im1+tndim*(ispinor1-1)+tndim*(isppol-1)
3053 : : ! do ispinor2=1,paw_dmft%nspinor
3054 : : ! do im2=1,tndim
3055 : : ! iflavor2=im2+tndim*(ispinor2-1)+tndim*(isppol-1)
3056 : : ! gtmp_nd(itau,iflavor1,iflavor2)=&
3057 : : ! matlu1(iatom)%mat(im1,im2,isppol,ispinor1,ispinor2)
3058 : : ! end do ! im2
3059 : : ! end do ! ispinor2
3060 : : ! end do ! im1
3061 : : ! end do ! ispinor
3062 : : ! end do ! isppol
3063 : : ! end do !itau
3064 : : ! call destroy_matlu(matlu1,paw_dmft%natom)
3065 : : ! ABI_FREE(matlu1)
3066 : : ! endif ! if natom=1
3067 : : ! if (open_file(trim(paw_dmft%filapp)//"_atom_"//iatomnb//"_Gtau_offdiag_"//gtau_iter//".dat",&
3068 : : !& message, newunit=unt) /= 0) then
3069 : : ! ABI_ERROR(message)
3070 : : ! end if
3071 : : ! do itau=1,paw_dmft%dmftqmc_l
3072 : : ! write(unt,'(196f21.14)') float(itau-1)/float(paw_dmft%dmftqmc_l)/paw_dmft%temp,&
3073 : : ! ((gtmp_nd(itau,iflavor,iflavor1), iflavor=1, nflavor),iflavor1=1, nflavor)
3074 : : ! end do
3075 : : ! close(unt)
3076 : : ! endif
3077 : : !open(unit=4243, file=trim(paw_dmft%filapp)//"_atom_"//iatomnb//"_F_"//gtau_iter//".dat")
3078 : : !call BathOperator_printF(paw_dmft%hybrid(iatom)%hybrid%bath,4243) !Already comment here
3079 : : !close(4243)
3080 [ + + ]: 22 : if(paw_dmft%dmft_solv==5) then
3081 [ - + ]: 19 : if (open_file(trim(paw_dmft%filapp)//"_atom_"//iatomnb//"_Gw_"//gtau_iter//".dat", message, newunit=unt) /= 0) then
3082 : 0 : ABI_ERROR(message)
3083 : : end if
3084 [ + + ]: 6275 : do ifreq=1,paw_dmft%dmft_nwlo
3085 : 6256 : write(unt,'(29f21.14)') paw_dmft%omega_lo(ifreq), &
3086 : 12531 : & (gw_tmp(ifreq,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_diag_"//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,'(29f21.14)') paw_dmft%omega_lo(ifreq), &
3097 [ + - + + ]: 31458 : & (gw_tmp_nd(ifreq,iflavor,iflavor), iflavor=1, nflavor)
3098 : : end do
3099 : : endif
3100 : 22 : close(unt)
3101 : :
3102 [ + + ]: 22 : if(paw_dmft%dmft_solv==8 .or. paw_dmft%dmft_solv==10) then
3103 [ - + ]: 3 : if (open_file(trim(paw_dmft%filapp)//"_atom_"//iatomnb//"_Gw_Offdiag_"//gtau_iter//".dat", message, newunit=unt) /= 0) then
3104 : 0 : ABI_ERROR(message)
3105 : : end if
3106 [ + + ]: 2100 : do ifreq=1,paw_dmft%dmft_nwlo
3107 : 2097 : write(unt,'(296f21.14)') paw_dmft%omega_lo(ifreq), &
3108 [ + - + + : 251643 : & ((gw_tmp_nd(ifreq,iflavor,iflavor1), iflavor=iflavor1, nflavor),iflavor1=1, nflavor)
+ - + + ]
3109 : : end do
3110 : : endif
3111 : 22 : close(unt)
3112 : :
3113 : : end if
3114 : : ! </ HACK >
3115 : : end if
3116 : :
3117 : :
3118 : 46 : end subroutine ctqmcoutput_printgreen
3119 : : !!***
3120 : :
3121 : : !!****f* m_forctqmc/ctqmc_calltriqs
3122 : : !! NAME
3123 : : !! ctqmc_calltriqs
3124 : : !!
3125 : : !! FUNCTION
3126 : : !! Call TRIQS solver and perform calculation of Green's function using
3127 : : !! Legendre coefficients.
3128 : : !!
3129 : : !! INPUTS
3130 : : !! paw_dmft <type(paw_dmft_type)>= DMFT data structure
3131 : : !! cryst_struc <type(crystal_t)>=crystal structure data
3132 : : !! hu <type(hu_type)>= U interaction
3133 : : !! levels_ctqmc(nflavor) = atomic levels
3134 : : !! gw_tmp_nd(nb_of_frequency,nflavor,nflavor) = Green's fct in imag freq (with off diag terms)
3135 : : !! gtmp_nd(dmftqmc_l,nflavor,nflavor) = Green's fct in imag time (with off diag terms)
3136 : : !! fw1_nd(dmft_nwlo,nflavor,nflavor) = Hybridization fct in imag time (with off diag terms)
3137 : : !! leg_measure = logical, true is legendre measurement is activated
3138 : : !! iatom= index of atom
3139 : : !!
3140 : : !! OUTPUT
3141 : : !!
3142 : : !!
3143 : : !! SIDE EFFECTS
3144 : : !!
3145 : : !! NOTES
3146 : : !!
3147 : : !! SOURCE
3148 : :
3149 : 0 : subroutine ctqmc_calltriqs(paw_dmft,cryst_struc,hu,levels_ctqmc,gtmp_nd,gw_tmp_nd,fw1_nd,leg_measure,iatom)
3150 : :
3151 : : #if defined HAVE_TRIQS_v3_2 || defined HAVE_TRIQS_v2_0 || defined HAVE_TRIQS_v1_4
3152 : : use TRIQS_CTQMC !Triqs module
3153 : : #endif
3154 : : #if defined HAVE_PYTHON_INVOCATION
3155 : : use m_invoke_python
3156 : : #endif
3157 : : use, intrinsic :: iso_c_binding
3158 : :
3159 : : !Arguments ------------------------------------
3160 : : !scalars
3161 : : type(paw_dmft_type), intent(in) :: paw_dmft
3162 : : type(crystal_t),intent(in) :: cryst_struc
3163 : : type(hu_type), intent(in) :: hu(cryst_struc%ntypat)
3164 : : real(dp), allocatable, target, intent(inout) :: gtmp_nd(:,:,:)
3165 : : complex(dp), allocatable, target, intent(inout) :: gw_tmp_nd(:,:,:)
3166 : : complex(dp), allocatable, target, intent(in) :: fw1_nd(:,:,:)
3167 : : real(dp), allocatable, target, intent(inout) :: levels_ctqmc(:)
3168 : : logical(kind=1), intent(in) :: leg_measure
3169 : : integer, intent(in) :: iatom
3170 : :
3171 : : !Local variables ------------------------------
3172 : 0 : complex(dp), allocatable, target ::fw1_nd_tmp(:,:,:)
3173 : 0 : complex(dp), allocatable, target :: g_iw(:,:,:)
3174 : 0 : real(dp), allocatable, target :: u_mat_ij(:,:)
3175 : 0 : real(dp), allocatable, target :: u_mat_ijkl(:,:,:,:)
3176 : 0 : real(dp), allocatable, target :: u_mat_ijkl_tmp(:,:,:,:)
3177 : 0 : real(dp), allocatable, target :: gl_nd(:,:,:)
3178 : : type(c_ptr) :: levels_ptr, fw1_nd_ptr, u_mat_ij_ptr, u_mat_ijkl_ptr, g_iw_ptr, gtau_ptr, gl_ptr
3179 : 0 : real(dp), allocatable :: jbes(:)
3180 : : character(len=500) :: message
3181 : : integer :: ifreq, iflavor1
3182 : : integer :: iflavor2,iflavor,nflavor,iflavor3,itypat
3183 : : integer :: nfreq,ntau,nleg,ileg
3184 : : integer :: verbosity_solver ! min 0 -> max 3
3185 : : logical(kind=1) :: rot_inv = .false.
3186 : : #if defined HAVE_TRIQS_v2_0 || defined HAVE_TRIQS_v1_4 || defined HAVE_PYTHON_INVOCATION
3187 : : logical(kind=1) :: hist = .false.
3188 : : logical(kind=1) :: wrt_files = .true.
3189 : : logical(kind=1) :: tot_not = .true.
3190 : : #endif
3191 : : real(dp) :: beta,besp,bespp,xx
3192 : : complex(dp) :: u_nl
3193 : :
3194 : : #if defined HAVE_PYTHON_INVOCATION
3195 : : !----------
3196 : : !Variables for writing out the NETCDF file when calling PYTHON_INVOCATION
3197 : : !----------
3198 : : integer(kind=4) :: ncid
3199 : : integer(kind=4) :: dim_one_id, dim_nflavor_id, dim_nwlo_id, dim_nwli_id
3200 : : integer(kind=4) :: dim_qmc_l_id, dim_nleg_id
3201 : : integer(kind=4), dimension(2) :: dim_u_mat_ij_id
3202 : : integer(kind=4), dimension(3) :: dim_fw1_id, dim_g_iw_id, dim_gl_id, dim_gtau_id
3203 : : integer(kind=4), dimension(4) :: dim_u_mat_ijkl_id
3204 : : integer(kind=4) :: var_rot_inv_id, var_leg_measure_id, var_hist_id, var_wrt_files_id
3205 : : 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
3206 : : integer(kind=4) :: var_cycle_length_id, var_ntherm_id, var_verbo_id, var_seed_id, var_beta_id
3207 : : 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
3208 : : integer(kind=4) :: var_real_g_iw_id, var_imag_g_iw_id, var_gtau_id, var_gl_id, var_spacecomm_id
3209 : :
3210 : : integer :: itau
3211 : :
3212 : : integer(kind=4) :: varid
3213 : : logical :: file_exists
3214 : : complex :: i
3215 : : character(len=100) :: filename
3216 : :
3217 : : real(dp), allocatable, target :: new_re_g_iw(:,:,:), new_im_g_iw(:,:,:)
3218 : : real(dp), allocatable, target :: new_g_tau(:,:,:), new_gl(:,:,:)
3219 : : !----------
3220 : : #endif
3221 : : ! ************************************************************************
3222 : :
3223 : : ! fw1_nd: Hybridation
3224 : : ! levels_ctqmc: niveaux
3225 : : ! hu(itypat)%udens(:,:) : U_ij
3226 : : ! hu(itypat)%u(:,:,:,:) : uijkl
3227 : : ! temperature : paw_dmft%temp
3228 : : ! paw_dmft%dmftqmc_l: nombre de points en temps -1
3229 : : ! paw_dmft%dmftqmc_n: nombre de cycles
3230 : : ! ?? Quelles sorties: Les fonctions de Green
3231 : : ! frequence/temps/Legendre.
3232 : : ! Double occupations ?? <n_i n_j>
3233 : : ! test n_tau > 2*nfreq => ntau = 2*nfreq + 1
3234 : : ! for non diagonal code:
3235 : : ! call CtqmcInterface_run(hybrid,fw1_nd(1:paw_dmft%dmftqmc_l,:,:),Gtau=gtmp_nd,&
3236 : : !& Gw=gw_tmp_nd,D=Doccsum,E=green%ecorr_qmc(iatom),&
3237 : : !& Noise=Noise,matU=hu(itypat)%udens,opt_levels=levels_ctqmc,hybri_limit=hybri_limit)
3238 : : !Check choice of user to fix model bool var for the solver
3239 [ # # ]: 0 : if (paw_dmft%dmft_solv==6) then
3240 : 0 : rot_inv = .false.
3241 : : else !obviously paw_dmft%dmft_solv==7 with rot invariant terms
3242 : 0 : rot_inv = .true.
3243 : : end if
3244 : :
3245 : 0 : nfreq = paw_dmft%dmft_nwli
3246 : : !paw_dmft%dmft_nwlo = paw_dmft%dmft_nwli !transparent for user
3247 : 0 : ntau = paw_dmft%dmftqmc_l !(2*paw_dmft%dmftqmc_l)+1 !nfreq=paw_dmft%dmft_nwli
3248 : 0 : nleg = paw_dmft%dmft_triqs_nleg
3249 : 0 : nflavor=2*(2*paw_dmft%lpawu(iatom)+1)
3250 : 0 : itypat=cryst_struc%typat(iatom)
3251 : :
3252 : :
3253 : 0 : verbosity_solver = paw_dmft%prtvol
3254 : 0 : beta = 1.0/(paw_dmft%temp*Ha_eV)
3255 : :
3256 : : !Allocation in/output array phase:
3257 [ # # # # : 0 : ABI_MALLOC(fw1_nd_tmp,(1:nflavor,1:nflavor,1:nfreq)) !column major
# # # # #
# # # # #
# # # # #
# ]
3258 [ # # # # : 0 : ABI_MALLOC(g_iw,(1:nflavor,1:nflavor,1:nfreq)) !column major
# # # # #
# # # # #
# # ]
3259 [ # # # # : 0 : ABI_MALLOC(u_mat_ij,(1:nflavor,1:nflavor)) !column major
# # # # #
# # # # #
# # ]
3260 [ # # # # : 0 : ABI_MALLOC(u_mat_ijkl,(1:nflavor,1:nflavor,1:nflavor,1:nflavor)) !column major
# # # # #
# # # # #
# # # # #
# # # #
# ]
3261 [ # # # # : 0 : ABI_MALLOC(u_mat_ijkl_tmp,(1:nflavor,1:nflavor,1:nflavor,1:nflavor)) !column major
# # # # #
# # # # #
# # # # #
# ]
3262 : :
3263 [ # # ]: 0 : if ( leg_measure ) then !only if functionality is enabled
3264 [ # # # # : 0 : ABI_MALLOC(gl_nd,(1:nleg,1:nflavor,1:nflavor)) !column major !nl = 30 by default
# # # # #
# # # # #
# # # # #
# ]
3265 : : end if
3266 : :
3267 : : !Conversion datas Ha -> eV (some duplications for test...)
3268 : : !fw1_nd_tmp = fw1_nd(1:paw_dmft%dmftqmc_l,:,:) * Ha_eV !fw1_nd = fw1_nd * Ha_eV !Ok?
3269 : :
3270 [ # # ]: 0 : do iflavor=1,nflavor
3271 [ # # ]: 0 : do iflavor1=1,nflavor
3272 [ # # ]: 0 : do ifreq=1,nfreq
3273 : 0 : fw1_nd_tmp(iflavor,iflavor1,ifreq) = fw1_nd(ifreq,iflavor,iflavor1) * Ha_eV
3274 : : ! WRITE(500,*) "[IN Fortran] F[ w= ",ifreq," l= ",iflavor," l_= ",iflavor1,"] = ",fw1_nd(ifreq,iflavor,iflavor1)
3275 : : end do
3276 : : end do
3277 : : end do
3278 : :
3279 : : !Report test
3280 : : ! WRITE(502,*) hu(itypat)%udens
3281 : : ! do ifreq=1,paw_dmft%dmftqmc_l
3282 : : ! write(501,*) ((fw1_nd(ifreq,iflavor,iflavor1),iflavor=1,nflavor),iflavor1=1,nflavor)
3283 : : ! enddo
3284 : : !write(866,*)paw_dmft%dmft_nwlo,paw_dmft%dmftqmc_l
3285 : : !write(866,*) u_mat_ij
3286 : : ! do iflavor=1,nflavor+1
3287 : : ! do iflavor1=1,nflavor+1
3288 : : ! WRITE(502,*) "[OUT Fortran] U(i,j)[ l= ",iflavor," l_= ",iflavor1,"] = ",hu(itypat)%udens(iflavor,iflavor1)
3289 : : ! enddo
3290 : : ! enddo
3291 : :
3292 : : ! if(paw_dmft%myproc==0) then
3293 : : ! do iflavor=1,nflavor
3294 : : ! do iflavor1=1,nflavor
3295 : : ! do iflavor2=1,nflavor
3296 : : ! do iflavor3=1,nflavor
3297 : : ! write(490,*), hu(itypat)%vee(iflavor,iflavor1,iflavor2,iflavor3)
3298 : : ! enddo
3299 : : ! enddo
3300 : : ! enddo
3301 : : ! enddo
3302 : : ! endif
3303 : :
3304 : : ! if(paw_dmft%myproc==0) then
3305 : : ! do iflavor=1,nflavor
3306 : : ! do iflavor1=1,nflavor
3307 : : ! write(491,*), hu(itypat)%udens(iflavor,iflavor1) !(1,1,1,1)
3308 : : ! enddo
3309 : : ! enddo
3310 : : ! endif
3311 : :
3312 : : ! do iflavor=1,nflavor
3313 : : ! do iflavor1=1,nflavor
3314 : : ! do iflavor2=1,nflavor
3315 : : ! do iflavor3=1,nflavor
3316 : : ! WRITE(552,*), hu(itypat)%vee!(iflavor,iflavor1,iflavor2,iflavor3)
3317 : : ! enddo
3318 : : ! enddo
3319 : : ! enddo
3320 : : ! enddo
3321 : :
3322 [ # # # # : 0 : call vee_ndim2tndim_hu_r(paw_dmft%lpawu(iatom),dble(hu(itypat)%vee),u_mat_ijkl_tmp,1)
# # # # #
# ]
3323 [ # # ]: 0 : do iflavor=1,nflavor
3324 [ # # ]: 0 : do iflavor1=1,nflavor
3325 [ # # ]: 0 : do iflavor2=1,nflavor
3326 [ # # ]: 0 : do iflavor3=1,nflavor
3327 : 0 : u_mat_ijkl(iflavor,iflavor1,iflavor2,iflavor3) = Ha_eV * u_mat_ijkl_tmp(iflavor,iflavor1,iflavor2,iflavor3)
3328 : : end do
3329 : : end do
3330 : : end do
3331 : : end do
3332 : :
3333 : : !u_mat_ijkl = Ha_eV * reshape( u_mat_ijkl , [nflavor,nflavor,nflavor,nflavor] ) !column -> row major + conversion
3334 [ # # # # : 0 : u_mat_ij = transpose( dble(hu(itypat)%udens) ) * Ha_eV !column -> row major + conversion
# # # # #
# # # ]
3335 [ # # ]: 0 : levels_ctqmc = levels_ctqmc * Ha_eV
3336 : :
3337 : : !Location array in memory for C++ pointer args to pass
3338 : : !----------------------------------------------------
3339 : 0 : g_iw_ptr = C_LOC( gw_tmp_nd ) !C_LOC( g_iw )
3340 : 0 : gtau_ptr = C_LOC( gtmp_nd ) !C_LOC( gtau )
3341 : 0 : gl_ptr = C_LOC( gl_nd )
3342 : 0 : fw1_nd_ptr = C_LOC( fw1_nd_tmp )
3343 : 0 : u_mat_ij_ptr = C_LOC( u_mat_ij )
3344 : 0 : u_mat_ijkl_ptr = C_LOC( u_mat_ijkl )
3345 : 0 : levels_ptr = C_LOC( levels_ctqmc )
3346 : :
3347 : : !Calling interfaced TRIQS solver subroutine from src/67_triqs_ext package
3348 [ # # ]: 0 : if (paw_dmft%dmft_solv==9) then
3349 : : #ifndef HAVE_PYTHON_INVOCATION
3350 : 0 : write(message,'(23a)') ch10,' Python invocation flag requiered! You need to install ABINIT with ',&
3351 : 0 : 'enable_python_invocation = yes" in your "configure.ac" file.'
3352 : 0 : call wrtout(std_out,message,'COLL')
3353 : 0 : ABI_ERROR(message)
3354 : : #else
3355 : : ! Creating the NETCDF file
3356 : : ! write(std_out, "(a)") trim(paw_dmft%filapp)
3357 : : write(filename, '(a, a)') trim(paw_dmft%filnamei), "_abinit_output_for_py.nc"
3358 : : write(std_out, '(3a)') ch10, " Creating NETCDF file: ", trim(filename)
3359 : : NCF_CHECK(nf90_create(filename, NF90_CLOBBER, ncid))
3360 : :
3361 : : ! Defining the dimensions of the variables to write in the NETCDF file
3362 : : NCF_CHECK(nf90_def_dim(ncid, "one", 1, dim_one_id))
3363 : : NCF_CHECK(nf90_def_dim(ncid, "nflavor", nflavor, dim_nflavor_id))
3364 : : NCF_CHECK(nf90_def_dim(ncid, "nwlo", paw_dmft%dmft_nwlo, dim_nwlo_id))
3365 : : NCF_CHECK(nf90_def_dim(ncid, "nwli", paw_dmft%dmft_nwli, dim_nwli_id))
3366 : : NCF_CHECK(nf90_def_dim(ncid, "qmc_l", paw_dmft%dmftqmc_l, dim_qmc_l_id))
3367 : : NCF_CHECK(nf90_def_dim(ncid, "nleg", nleg, dim_nleg_id))
3368 : :
3369 : : dim_u_mat_ij_id = (/ dim_nflavor_id, dim_nflavor_id /)
3370 : : dim_u_mat_ijkl_id = (/ dim_nflavor_id, dim_nflavor_id, dim_nflavor_id, dim_nflavor_id /)
3371 : : dim_fw1_id = (/ dim_nflavor_id, dim_nflavor_id, dim_nwli_id /)
3372 : : dim_g_iw_id = (/ dim_nwli_id, dim_nflavor_id, dim_nflavor_id /)
3373 : : dim_gtau_id = (/ dim_qmc_l_id, dim_nflavor_id, dim_nflavor_id /)
3374 : : dim_gl_id = (/ dim_nleg_id, dim_nflavor_id, dim_nflavor_id /)
3375 : :
3376 : : ! Defining the variables
3377 : : NCF_CHECK(nf90_def_var(ncid, "rot_inv", NF90_INT, dim_one_id, var_rot_inv_id))
3378 : : NCF_CHECK(nf90_def_var(ncid, "leg_measure", NF90_INT, dim_one_id, var_leg_measure_id))
3379 : : NCF_CHECK(nf90_def_var(ncid, "hist", NF90_INT, dim_one_id, var_hist_id))
3380 : : NCF_CHECK(nf90_def_var(ncid, "wrt_files", NF90_INT, dim_one_id, var_wrt_files_id))
3381 : : NCF_CHECK(nf90_def_var(ncid, "tot_not", NF90_INT, dim_one_id, var_tot_not_id))
3382 : : NCF_CHECK(nf90_def_var(ncid, "n_orbitals", NF90_INT, dim_one_id, var_n_orbitals_id))
3383 : : NCF_CHECK(nf90_def_var(ncid, "n_freq", NF90_INT, dim_one_id, var_n_freq_id))
3384 : : NCF_CHECK(nf90_def_var(ncid, "n_tau", NF90_INT, dim_one_id, var_n_tau_id))
3385 : : NCF_CHECK(nf90_def_var(ncid, "n_l", NF90_INT, dim_one_id, var_n_l_id))
3386 : : NCF_CHECK(nf90_def_var(ncid, "n_cycles", NF90_INT, dim_one_id, var_n_cycles_id))
3387 : : NCF_CHECK(nf90_def_var(ncid, "cycle_length", NF90_INT, dim_one_id, var_cycle_length_id))
3388 : : NCF_CHECK(nf90_def_var(ncid, "ntherm", NF90_INT, dim_one_id, var_ntherm_id))
3389 : : NCF_CHECK(nf90_def_var(ncid, "verbo", NF90_INT, dim_one_id, var_verbo_id))
3390 : : NCF_CHECK(nf90_def_var(ncid, "seed", NF90_INT, dim_one_id, var_seed_id))
3391 : : NCF_CHECK(nf90_def_var(ncid, "beta", NF90_FLOAT, dim_one_id, var_beta_id))
3392 : : NCF_CHECK(nf90_def_var(ncid, "levels", NF90_DOUBLE, dim_nflavor_id, var_levels_id))
3393 : : NCF_CHECK(nf90_def_var(ncid, "u_mat_ij", NF90_DOUBLE, dim_u_mat_ij_id, var_u_mat_ij_id))
3394 : : NCF_CHECK(nf90_def_var(ncid, "u_mat_ijkl", NF90_DOUBLE, dim_u_mat_ijkl_id, var_u_mat_ijkl_id))
3395 : : NCF_CHECK(nf90_def_var(ncid, "real_fw1_nd", NF90_DOUBLE, dim_fw1_id, var_real_fw1_nd_id))
3396 : : NCF_CHECK(nf90_def_var(ncid, "imag_fw1_nd", NF90_DOUBLE, dim_fw1_id, var_imag_fw1_nd_id))
3397 : : NCF_CHECK(nf90_def_var(ncid, "real_g_iw", NF90_DOUBLE, dim_g_iw_id, var_real_g_iw_id))
3398 : : NCF_CHECK(nf90_def_var(ncid, "imag_g_iw", NF90_DOUBLE, dim_g_iw_id, var_imag_g_iw_id))
3399 : : NCF_CHECK(nf90_def_var(ncid, "gtau", NF90_DOUBLE, dim_gtau_id, var_gtau_id))
3400 : : NCF_CHECK(nf90_def_var(ncid, "gl", NF90_DOUBLE, dim_gl_id, var_gl_id))
3401 : : NCF_CHECK(nf90_def_var(ncid, "spacecomm", NF90_INT, dim_one_id, var_spacecomm_id))
3402 : : NCF_CHECK(nf90_enddef(ncid))
3403 : :
3404 : : ! Filling the variables with actual data
3405 : : if (rot_inv) then
3406 : : NCF_CHECK(nf90_put_var(ncid, var_rot_inv_id, 1))
3407 : : else
3408 : : NCF_CHECK(nf90_put_var(ncid, var_rot_inv_id, 0))
3409 : : end if
3410 : : if (leg_measure) then
3411 : : NCF_CHECK(nf90_put_var(ncid, var_leg_measure_id, 1))
3412 : : else
3413 : : NCF_CHECK(nf90_put_var(ncid, var_leg_measure_id, 0))
3414 : : end if
3415 : : if (hist) then
3416 : : NCF_CHECK(nf90_put_var(ncid, var_hist_id, 1))
3417 : : else
3418 : : NCF_CHECK(nf90_put_var(ncid, var_hist_id, 0))
3419 : : end if
3420 : : if (wrt_files) then
3421 : : NCF_CHECK(nf90_put_var(ncid, var_wrt_files_id, 1))
3422 : : else
3423 : : NCF_CHECK(nf90_put_var(ncid, var_wrt_files_id, 0))
3424 : : end if
3425 : : if (tot_not) then
3426 : : NCF_CHECK(nf90_put_var(ncid, var_tot_not_id, 1))
3427 : : else
3428 : : NCF_CHECK(nf90_put_var(ncid, var_tot_not_id, 0))
3429 : : end if
3430 : : NCF_CHECK(nf90_put_var(ncid, var_n_orbitals_id, nflavor))
3431 : : NCF_CHECK(nf90_put_var(ncid, var_n_freq_id, nfreq))
3432 : : NCF_CHECK(nf90_put_var(ncid, var_n_tau_id, ntau))
3433 : : NCF_CHECK(nf90_put_var(ncid, var_n_l_id, nleg))
3434 : : NCF_CHECK(nf90_put_var(ncid, var_n_cycles_id, int(paw_dmft%dmftqmc_n/paw_dmft%nproc)))
3435 : : NCF_CHECK(nf90_put_var(ncid, var_cycle_length_id, paw_dmft%dmftctqmc_meas*2*2*nflavor))
3436 : : NCF_CHECK(nf90_put_var(ncid, var_ntherm_id, paw_dmft%dmftqmc_therm))
3437 : : NCF_CHECK(nf90_put_var(ncid, var_verbo_id, verbosity_solver))
3438 : : NCF_CHECK(nf90_put_var(ncid, var_seed_id, paw_dmft%dmftqmc_seed))
3439 : : NCF_CHECK(nf90_put_var(ncid, var_beta_id, beta))
3440 : : NCF_CHECK(nf90_put_var(ncid, var_levels_id, levels_ctqmc))
3441 : : NCF_CHECK(nf90_put_var(ncid, var_u_mat_ij_id, u_mat_ij))
3442 : : NCF_CHECK(nf90_put_var(ncid, var_u_mat_ijkl_id, u_mat_ijkl))
3443 : : NCF_CHECK(nf90_put_var(ncid, var_real_fw1_nd_id, real(fw1_nd_tmp)))
3444 : : NCF_CHECK(nf90_put_var(ncid, var_imag_fw1_nd_id, aimag(fw1_nd_tmp)))
3445 : : NCF_CHECK(nf90_put_var(ncid, var_real_g_iw_id, real(gw_tmp_nd)))
3446 : : NCF_CHECK(nf90_put_var(ncid, var_imag_g_iw_id, aimag(gw_tmp_nd)))
3447 : : NCF_CHECK(nf90_put_var(ncid, var_gtau_id, gtmp_nd))
3448 : : NCF_CHECK(nf90_put_var(ncid, var_gl_id, gl_nd))
3449 : : NCF_CHECK(nf90_put_var(ncid, var_spacecomm_id, paw_dmft%spacecomm))
3450 : : NCF_CHECK(nf90_close(ncid))
3451 : :
3452 : : write(std_out, '(4a)') ch10, " NETCDF file ", trim(filename), " written; Launching python invocation"
3453 : :
3454 : : ! Invoking python to execute the script
3455 : : call invoke_python_run_script (0, paw_dmft%myproc, trim(paw_dmft%filnamei), paw_dmft%spacecomm)
3456 : : ! call Invoke_python_triqs (paw_dmft%myproc, trim(paw_dmft%filnamei)//c_null_char)
3457 : : call xmpi_barrier(paw_dmft%spacecomm)
3458 : : call flush_unit(std_out)
3459 : :
3460 : : ! Allocating the fortran variables for the results
3461 : : ABI_MALLOC(new_re_g_iw,(nflavor,nflavor, paw_dmft%dmft_nwli))
3462 : : ABI_MALLOC(new_im_g_iw,(nflavor,nflavor, paw_dmft%dmft_nwli))
3463 : : ABI_MALLOC(new_g_tau,(nflavor,nflavor, paw_dmft%dmftqmc_l))
3464 : : ABI_MALLOC(new_gl,(nflavor,nflavor, nleg))
3465 : : i = (0, 1)
3466 : :
3467 : : ! Check if file exists
3468 : : write(filename, '(a, a)') trim(paw_dmft%filnamei), "_py_output_for_abinit.nc"
3469 : :
3470 : : INQUIRE(FILE=filename, EXIST=file_exists)
3471 : : if(.not. file_exists) then
3472 : : 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!'
3473 : : call wrtout(std_out,message,'COLL')
3474 : : ABI_ERROR(message)
3475 : : endif
3476 : :
3477 : : write(std_out, '(3a)') ch10, " Reading NETCDF file ", trim(filename)
3478 : :
3479 : : ! Opening the NETCDF file
3480 : : NCF_CHECK(nf90_open(filename, nf90_nowrite, ncid))
3481 : :
3482 : : ! Read from the file
3483 : : ! Re{G_iw}
3484 : : write(std_out, '(2a)') ch10, " -- Re[G(iw_n)]"
3485 : : NCF_CHECK(nf90_inq_varid(ncid, "re_g_iw", varid))
3486 : : NCF_CHECK(nf90_get_var(ncid, varid, new_re_g_iw))
3487 : : ! Im{G_iw}
3488 : : write(std_out, '(2a)') ch10, " -- Im[G(iw_n)]"
3489 : : NCF_CHECK(nf90_inq_varid(ncid, "im_g_iw", varid))
3490 : : NCF_CHECK(nf90_get_var(ncid, varid, new_im_g_iw))
3491 : : ! G_tau
3492 : : write(std_out, '(2a)') ch10, " -- G(tau)"
3493 : : NCF_CHECK(nf90_inq_varid(ncid, "g_tau", varid))
3494 : : NCF_CHECK(nf90_get_var(ncid, varid, new_g_tau))
3495 : : ! G_l
3496 : : write(std_out, '(2a)') ch10, " -- G_l"
3497 : : NCF_CHECK(nf90_inq_varid(ncid, "gl", varid))
3498 : : NCF_CHECK(nf90_get_var(ncid, varid, new_gl))
3499 : :
3500 : : ! Assigning data
3501 : : do iflavor1=1, nflavor
3502 : : do iflavor2=1, nflavor
3503 : : do ifreq=1, paw_dmft%dmft_nwli
3504 : : gw_tmp_nd(ifreq, iflavor1, iflavor2) = new_re_g_iw(iflavor1, iflavor2, ifreq) &
3505 : : & + i*new_im_g_iw(iflavor1, iflavor2, ifreq)
3506 : : end do
3507 : : do itau=1, paw_dmft%dmftqmc_l
3508 : : gtmp_nd(itau, iflavor1, iflavor2) = new_g_tau(iflavor1, iflavor2, itau)
3509 : : end do
3510 : : do ileg=1, nleg
3511 : : gl_nd(ileg, iflavor1, iflavor2) = new_gl(iflavor1, iflavor2, ileg)
3512 : : end do
3513 : : end do
3514 : : end do
3515 : :
3516 : : ! Deallocating
3517 : : ABI_FREE(new_re_g_iw)
3518 : : ABI_FREE(new_im_g_iw)
3519 : : ABI_FREE(new_g_tau)
3520 : : ABI_FREE(new_gl)
3521 : : #endif
3522 : : elseif(paw_dmft%dmft_solv == 6 .or. paw_dmft%dmft_solv == 7) then
3523 : : !Calling interfaced TRIQS solver subroutine from src/01_triqs_ext package
3524 : : !----------------------------------------------------
3525 : : #if defined HAVE_TRIQS_v2_0 || defined HAVE_TRIQS_v1_4
3526 : : call Ctqmc_triqs_run ( rot_inv, leg_measure, hist, wrt_files, tot_not, &
3527 : : & nflavor, nfreq, ntau , nleg, int(paw_dmft%dmftqmc_n/paw_dmft%nproc), &
3528 : : & paw_dmft%dmftctqmc_meas*2*2*nflavor, paw_dmft%dmftqmc_therm, &
3529 : : & verbosity_solver, paw_dmft%dmftqmc_seed,beta, &
3530 : : & levels_ptr, u_mat_ij_ptr, u_mat_ijkl_ptr, fw1_nd_ptr, &
3531 : : !& g_iw_ptr, gtau_ptr, gl_ptr, paw_dmft%spacecomm )
3532 : : & g_iw_ptr, gtau_ptr, gl_ptr, paw_dmft%myproc )
3533 : : #endif
3534 : : endif
3535 : :
3536 : : !WRITE(*,*) "Hello Debug"
3537 : : !call xmpi_barrier(paw_dmft%spacecomm) !Resynch all processus after calling Impurity solver from TRIQS
3538 : :
3539 : : !Report output datas from TRIQS to Abinit
3540 : : !Interacting G(iw)
3541 : : ! OG Commented these loops because they are useless
3542 : : !do ifreq=1,nfreq
3543 : : ! do iflavor1=1,nflavor
3544 : : ! do iflavor=1,nflavor
3545 : : ! ! gw_tmp_nd(ifreq,iflavor,iflavor1) = g_iw(iflavor,iflavor1,ifreq) !* Ha_eV !because 1/ G0(eV)
3546 : : ! ! WRITE(503,*) "[OUT Fortran] G(iw)[ w= ",ifreq," l= ",iflavor," l_= ",iflavor1,"] = ",gw_tmp_nd(ifreq,iflavor,iflavor1)!g_iw(iflavor,iflavor1,ifreq)
3547 : : ! end do
3548 : : ! end do
3549 : : !end do
3550 : :
3551 : : ! Convert in Ha
3552 [ # # # # : 0 : gw_tmp_nd = gw_tmp_nd*Ha_eV
# # ]
3553 : :
3554 : : ! do iflavor1=1,nflavor
3555 : : ! do iflavor=1,nflavor
3556 : : !
3557 : : ! WRITE(510,*) "[OUT Fortran] U[ l= ",iflavor," l_= ",iflavor1,"] = ",u_mat_ij(iflavor,iflavor1)
3558 : : ! enddo
3559 : : ! enddo
3560 : :
3561 : : ! if(paw_dmft%myproc==0) write(6,*) "essai",paw_dmft%myproc, gw_tmp_nd(2,1,1)
3562 : : ! if(paw_dmft%myproc==1) write(6,*) "essai",paw_dmft%myproc,gw_tmp_nd(2,1,1)
3563 : : ! if(paw_dmft%myproc==0) write(621,*) "essai",paw_dmft%myproc, gw_tmp_nd(2,1,1)
3564 : : ! if(paw_dmft%myproc==1) write(622,*) "essai",paw_dmft%myproc,gw_tmp_nd(2,1,1)
3565 : : ! call flush_unit(621)
3566 : : ! call flush_unit(622)
3567 : : ! write(message,*) ch10, "essai",paw_dmft%myproc, paw_dmft%myproc,paw_dmft%dmftqmc_seed!gw_tmp_nd(2,1,1)
3568 : : ! call wrtout(555,message,'PERS',.true.)
3569 : : ! if(paw_dmft%myproc==0) write(499,*) "essai",paw_dmft%myproc, paw_dmft%dmftqmc_seed
3570 : : ! if(paw_dmft%myproc==1) write(498,*) "essai",paw_dmft%myproc,paw_dmft%dmftqmc_seed
3571 : :
3572 : : !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)...
3573 : : ! do iflavor=1,nflavor
3574 : : ! do iflavor1=1,nflavor
3575 : : ! do itau=1,ntau
3576 : : ! 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
3577 : : !gtmp_nd(itau,iflavor,iflavor1) = gtau(iflavor,iflavor1,itau)
3578 : : ! endif
3579 : : ! if(paw_dmft%myproc==0) then
3580 : : ! 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)
3581 : : ! endif
3582 : : ! enddo
3583 : : ! enddo
3584 : : ! enddo
3585 : :
3586 : : ! Write Legendre Polynoms G(L) for extrapolation of Interacting G(iw) by FT, only if leg_measure == TRUE
3587 : : ! -------------------------------------------------------------------------------------------
3588 [ # # ]: 0 : if (leg_measure) then
3589 [ # # ]: 0 : do ileg=1,nleg
3590 : 0 : WRITE(505,*) ileg,((gl_nd(ileg,iflavor,iflavor1),iflavor=1,nflavor),iflavor1=1,nflavor)
3591 : : end do
3592 : 0 : close(505)
3593 : : end if
3594 : : ! f(paw_dmft%myproc==0) then
3595 : : ! do itau=1,paw_dmft%dmftqmc_l
3596 : : ! write(490,*) ((gtmp_nd(itau,iflavor,iflavor1),iflavor=1,nflavor),iflavor1=1,nflavor)
3597 : : ! enddo
3598 : : ! ndif
3599 [ # # ]: 0 : ABI_FREE( fw1_nd_tmp )
3600 [ # # ]: 0 : ABI_FREE( g_iw )
3601 [ # # ]: 0 : ABI_FREE( u_mat_ijkl )
3602 [ # # ]: 0 : ABI_FREE( u_mat_ijkl_tmp )
3603 [ # # ]: 0 : ABI_FREE( u_mat_ij )
3604 : :
3605 : :
3606 : : ! Compute Green's function in imaginary freq using Legendre coefficients
3607 : : ! -----------------------------------------------------------------------
3608 [ # # ]: 0 : if (leg_measure) then
3609 : 0 : call xmpi_barrier(paw_dmft%spacecomm)
3610 : 0 : call flush_unit(std_out)
3611 : 0 : write(message,'(2a)') ch10," == Compute G(iw_n) from Legendre coefficients"
3612 : 0 : call wrtout(std_out,message,'COLL')
3613 [ # # # # : 0 : ABI_MALLOC( jbes, (nleg))
# # # # #
# # # ]
3614 [ # # # # : 0 : gw_tmp_nd=czero
# # ]
3615 : :
3616 : : ! write(77,*) " TEST OF BESSEL S ROUTINES 0 0"
3617 : :
3618 : : ! xx=0_dp
3619 : : ! ileg=0
3620 : : ! call sbf8(ileg+1,xx,jbes)
3621 : : ! write(77,*) "T0 A",jbes(ileg+1)
3622 : : ! call jbessel(jbes(ileg+1),besp,bespp,ileg,1,xx)
3623 : : ! write(77,*) "T0 B",jbes(ileg+1)
3624 : : ! write(77,*) "T0 C",bessel_jn(ileg,xx)
3625 : :
3626 : : ! write(77,*) " TEST OF BESSEL S ROUTINES 1.5 0"
3627 : :
3628 : : ! xx=1.5_dp
3629 : : ! ileg=0
3630 : : ! call sbf8(ileg+1,xx,jbes)
3631 : : ! write(77,*) "T1 A",jbes(ileg+1)
3632 : : ! call jbessel(jbes(ileg+1),besp,bespp,ileg,1,xx)
3633 : : ! write(77,*) "T1 B",jbes(ileg+1)
3634 : : ! write(77,*) "T1 C",bessel_jn(ileg,xx)
3635 : :
3636 : : ! write(77,*) " TEST OF BESSEL S ROUTINES 1.5 1"
3637 : :
3638 : : ! xx=1.5_dp
3639 : : ! ileg=1
3640 : : ! call sbf8(ileg+1,xx,jbes)
3641 : : ! write(77,*) "T2 A",jbes(ileg+1)
3642 : : ! call jbessel(jbes(ileg+1),besp,bespp,ileg,1,xx)
3643 : : ! write(77,*) "T2 B",jbes(ileg+1)
3644 : : ! write(77,*) "T2 C",bessel_jn(ileg,xx)
3645 : :
3646 : :
3647 [ # # ]: 0 : do ifreq=1,paw_dmft%dmft_nwli
3648 : 0 : xx=real(2*ifreq-1,kind=dp)*pi/two
3649 [ # # ]: 0 : if(xx<=100_dp) call sbf8(nleg,xx,jbes)
3650 [ # # ]: 0 : do ileg=1,nleg
3651 : : ! write(77,*) "A",ifreq,jbes(ileg),xx
3652 : :
3653 [ # # ]: 0 : if(xx>=99) call jbessel(jbes(ileg),besp,bespp,ileg-1,1,xx)
3654 : : ! write(77,*) "B",ifreq,jbes(ileg),xx
3655 : :
3656 : : !write(77,*) "C",ifreq,jbes(ileg),xx
3657 : :
3658 : 0 : u_nl=sqrt(float(2*ileg-1))*(-1)**(ifreq-1)*cmplx(0_dp,one)**(ileg)*jbes(ileg)
3659 : 0 : write(77,*) "----------",ileg,jbes(ileg), u_nl,gl_nd(ileg,1,1)
3660 : :
3661 [ # # ]: 0 : do iflavor=1,nflavor
3662 [ # # ]: 0 : do iflavor1=1,nflavor
3663 : : gw_tmp_nd(ifreq,iflavor,iflavor1)= gw_tmp_nd(ifreq,iflavor,iflavor1) + &
3664 : 0 : & u_nl*gl_nd(ileg,iflavor,iflavor1)
3665 : : end do
3666 : : end do
3667 : :
3668 : : ! write(77,*) "------------------", gw_tmp_nd(ifreq,1,1)
3669 : :
3670 : : end do
3671 : : ! write(77,*) "------------------ sum ", gw_tmp_nd(ifreq,1,1)
3672 : : end do
3673 [ # # ]: 0 : ABI_FREE( jbes )
3674 : 0 : call xmpi_barrier(paw_dmft%spacecomm)
3675 : 0 : call flush_unit(std_out)
3676 : : end if
3677 [ # # # # : 0 : gw_tmp_nd = gw_tmp_nd*Ha_eV
# # ]
3678 : :
3679 : :
3680 [ # # ]: 0 : if ( leg_measure ) then !only if functionality is enabled
3681 [ # # ]: 0 : ABI_FREE(gl_nd)
3682 : : end if
3683 : :
3684 : :
3685 [ # # ]: 0 : end subroutine ctqmc_calltriqs
3686 : : !!***
3687 : :
3688 : : !!****f* m_forctqmc/ctqmc_calltriqs_c
3689 : : !! NAME
3690 : : !! ctqmc_calltriqs_c
3691 : : !!
3692 : : !! FUNCTION
3693 : : !! This routines calls TRIQS/CTHYB using the C++ API in order
3694 : : !! to solve the impurity model.
3695 : : !!
3696 : : !! INPUTS
3697 : : !! paw_dmft <type(paw_dmft_type)>= DMFT data structure
3698 : : !! green <type(green_type)>= green's function
3699 : : !! self <type(self_type)>= self-energy
3700 : : !! hu <type(hu_type)>= U interaction
3701 : : !! weiss <type(green_type)>= inverse of weiss function
3702 : : !! self_new <type(self_type)>= impurity self-energy
3703 : : !! pawprtvol = flag for printing
3704 : : !!
3705 : : !! OUTPUT
3706 : : !!
3707 : : !! SIDE EFFECTS
3708 : : !!
3709 : : !! NOTES
3710 : : !!
3711 : : !! SOURCE
3712 : :
3713 : 0 : subroutine ctqmc_calltriqs_c(paw_dmft,green,self,hu,weiss,self_new,pawprtvol)
3714 : :
3715 : : #if defined HAVE_TRIQS_INTERNAL || defined HAVE_TRIQS_v3_2
3716 : : use TRIQS_CTQMC
3717 : : #endif
3718 : : use ISO_C_BINDING
3719 : :
3720 : : !Arguments ------------------------------------
3721 : : integer, intent(in) :: pawprtvol
3722 : : type(paw_dmft_type), intent(in) :: paw_dmft
3723 : : type(green_type), target, intent(inout) :: green,weiss
3724 : : type(self_type), intent(inout) :: self,self_new
3725 : : type(hu_type), intent(inout) :: hu(paw_dmft%ntypat)
3726 : : !Local variables ------------------------------
3727 : : integer :: basis,i,iatom,iblock,iflavor,iflavor1,iflavor2,ifreq,ilam,ileg,im,im1,integral,isppol,isub
3728 : : integer :: itau,itypat,iw,l,len_t,lpawu,myproc,natom,ncon,ndim,nflavor,nflavor_max,ngauss,nleg,nmoments
3729 : : integer :: nspinor,nsppol,nsub,ntau,ntot,nwlo,p,pad_elam,pad_lambda,read_data,rot_type_vee,tndim,unt,verbo,wdlr_size
3730 : : integer, target :: ndlr
3731 : : logical :: debug,density_matrix,entropy,leg_measure,nondiag,off_diag,rot_inv
3732 : : real(dp) :: besp,bespp,beta,dx,elam,emig_tot,err,err_,fact,fact2,shift_mu,tau,tol,xtau,xx
3733 : : complex(dp) :: mself_1,mself_2,occ_tmp,u_nl
3734 : : complex(dp), target :: eu
3735 : 0 : type(oper_type), target :: energy_level
3736 : 0 : type(self_type) :: hybmwdhyb
3737 : : type(c_ptr) :: block_ptr,eu_ptr,flavor_ptr,fname_data_ptr,fname_dataw_ptr,fname_histo_ptr,ftau_ptr,gl_ptr,gtau_ptr
3738 : : 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
3739 : : type(c_ptr) :: chiloc_ptr,magmom_ptr
3740 : 0 : integer, allocatable :: flavor_list(:,:,:),nblocks(:)
3741 : 0 : integer, target, allocatable :: block_list(:,:),flavor_tmp(:,:),inner_list(:,:),siz_block(:,:)
3742 : 0 : real(dp), allocatable :: adlr(:,:),bdlr(:),elam_list(:),emig(:),gl_dlr_re(:),gl_dlr_im(:),jbes(:),lam_list(:)
3743 : 0 : real(dp), allocatable :: leg_array(:,:),moment_fit(:),t_lp(:,:),tpoints(:),tweights(:),wdlr(:),wdlr_beta(:,:)
3744 : 0 : real(dp), target, allocatable :: wdlr_tmp(:), chiloc_tmp(:,:), magmom_array(:)
3745 : 0 : complex(dp), allocatable :: adlr_iw(:,:),gl_dlr(:,:,:,:),gl_tmp(:,:,:,:),gtau_dlr(:,:,:),gtau_leg(:,:,:),shift(:)
3746 : 0 : complex(dp), target, allocatable :: gl(:,:,:),gtau(:,:,:),levels_ctqmc(:,:),moments_self_1(:),moments_self_2(:),occ(:)
3747 : 0 : type(matlu_type), allocatable :: eigvectmatlu(:),matlu_tmp(:)
3748 : 0 : type(matlu_type), target, allocatable :: dmat_ctqmc(:),ftau(:),udens_rot(:)
3749 : 0 : type(matlu_type), pointer :: matlu_pt(:) => null()
3750 : 0 : type(vee_type), target, allocatable :: vee_rot(:)
3751 : 0 : type(coeff2c_type), allocatable :: magmom_tot(:)
3752 : 0 : type(matlu_type), allocatable :: matlumag_tot(:)
3753 : : character(len=1) :: tag_block4
3754 : : character(len=2) :: tag_block,tag_block3,tag_lam
3755 : : character(len=4) :: tag_at
3756 : : character(len=14) :: tag_elam,tag_lambda
3757 : : character(len=500) :: stringfile,tag_block2,tag_lam2
3758 : : character(len=10000) :: message
3759 : : character(len=fnlen), target :: fname_data,fname_dataw,fname_histo
3760 : : ! ************************************************************************
3761 : :
3762 : 0 : basis = paw_dmft%dmftctqmc_basis
3763 : 0 : beta = one / paw_dmft%temp
3764 : 0 : debug = paw_dmft%dmft_triqs_prt_entropy
3765 : 0 : density_matrix = paw_dmft%dmft_triqs_measure_density_matrix
3766 : 0 : entropy = (paw_dmft%dmft_triqs_entropy == 1)
3767 : 0 : integral = paw_dmft%dmft_triqs_compute_integral
3768 : 0 : leg_measure = paw_dmft%dmft_triqs_leg_measure
3769 : 0 : myproc = paw_dmft%myproc
3770 : 0 : natom = paw_dmft%natom
3771 : 0 : nflavor_max = 2 * (2*paw_dmft%maxlpawu+1)
3772 : 0 : ngauss = paw_dmft%dmft_triqs_gaussorder
3773 : 0 : nleg = paw_dmft%dmft_triqs_nleg
3774 : 0 : nspinor = paw_dmft%nspinor
3775 : 0 : nsppol = paw_dmft%nsppol
3776 : 0 : nsub = paw_dmft%dmft_triqs_nsubdivisions
3777 : 0 : ntau = paw_dmft%dmftqmc_l
3778 : 0 : nwlo = paw_dmft%dmft_nwlo
3779 : 0 : off_diag = paw_dmft%dmft_triqs_off_diag
3780 : 0 : rot_inv = (paw_dmft%dmft_solv == 7)
3781 : 0 : shift_mu = paw_dmft%dmft_triqs_shift_mu
3782 : 0 : tol = paw_dmft%dmft_triqs_tol_block
3783 : :
3784 [ # # ]: 0 : if (rot_inv) then
3785 : 0 : write(message,'(a,3x,a)') ch10,"== Rotationally Invariant Terms Included"
3786 : : else
3787 : 0 : write(message,'(a,3x,a)') ch10,"== Density-Density Terms Included"
3788 : : end if
3789 : 0 : call wrtout(std_out,message,"COLL")
3790 : :
3791 [ # # # # : 0 : ABI_MALLOC(block_list,(nflavor_max,natom))
# # # # #
# # # # #
# # ]
3792 [ # # # # : 0 : ABI_MALLOC(dmat_ctqmc,(natom))
# # # # #
# # # # #
# # # # ]
3793 [ # # # # : 0 : ABI_MALLOC(eigvectmatlu,(natom))
# # # # #
# # # # #
# # # # #
# ]
3794 [ # # # # : 0 : ABI_MALLOC(flavor_list,(nflavor_max,nflavor_max,natom))
# # # # #
# # # # #
# # # # #
# # # ]
3795 [ # # # # : 0 : ABI_MALLOC(ftau,(natom))
# # # # #
# # # # #
# # # # ]
3796 [ # # # # : 0 : ABI_MALLOC(inner_list,(nflavor_max,natom))
# # # # #
# # # # #
# # ]
3797 [ # # # # : 0 : ABI_MALLOC(matlu_tmp,(natom))
# # # # #
# # # # #
# # # # ]
3798 [ # # # # : 0 : ABI_MALLOC(nblocks,(natom))
# # # # #
# # # #
# ]
3799 [ # # # # : 0 : ABI_MALLOC(shift,(natom))
# # # # #
# # # ]
3800 [ # # # # : 0 : ABI_MALLOC(siz_block,(nflavor_max,natom))
# # # # #
# # # # #
# # # # ]
3801 [ # # # # : 0 : ABI_MALLOC(udens_rot,(natom))
# # # # #
# # # # #
# # # # ]
3802 [ # # # # : 0 : ABI_MALLOC(vee_rot,(natom))
# # # # #
# # # # #
# # # # ]
3803 : :
3804 : 0 : call init_matlu(natom,nspinor,nsppol,paw_dmft%lpawu(:),dmat_ctqmc(:))
3805 : 0 : call init_matlu(natom,nspinor,nsppol,paw_dmft%lpawu(:),eigvectmatlu(:))
3806 : 0 : call init_matlu(natom,2,ntau,paw_dmft%lpawu(:),ftau(:))
3807 : 0 : call init_matlu(natom,nspinor,nsppol,paw_dmft%lpawu(:),matlu_tmp(:))
3808 : 0 : call init_matlu(natom,2,1,paw_dmft%lpawu(:),udens_rot(:))
3809 : :
3810 : 0 : call init_oper(paw_dmft,energy_level,opt_ksloc=2)
3811 : :
3812 : 0 : call init_vee(paw_dmft,vee_rot(:))
3813 : :
3814 : 0 : call compute_levels(energy_level,self%hdc,paw_dmft)
3815 : :
3816 : 0 : write(message,'(a,3x,a)') ch10,"== Print Occupation matrix in cubic basis"
3817 : 0 : call wrtout(std_out,message,"COLL")
3818 : 0 : call print_matlu(green%occup%matlu(:),natom,1)
3819 : :
3820 : 0 : call compute_moments_loc(green,self,energy_level,weiss,0)
3821 : :
3822 : : ! Build hybridization and remove spurious 0th order moment
3823 [ # # ]: 0 : do ifreq=1,nwlo
3824 [ # # ]: 0 : shift(:) = cmplx(zero,paw_dmft%omega_lo(ifreq),kind=dp)
3825 : 0 : call shift_matlu(weiss%oper(ifreq)%matlu(:),natom,shift(:))
3826 : 0 : call fac_matlu(weiss%oper(ifreq)%matlu(:),natom,-cone)
3827 : 0 : call add_matlu(weiss%oper(ifreq)%matlu(:),energy_level%matlu(:),matlu_tmp(:),natom,-1)
3828 : 0 : call add_matlu(matlu_tmp(:),weiss%moments(1)%matlu(:),weiss%oper(ifreq)%matlu(:),natom,-1)
3829 : : end do ! ifreq
3830 : :
3831 : 0 : call zero_matlu(weiss%moments(1)%matlu(:),natom)
3832 : :
3833 : 0 : write(message,'(a,3x,a)') ch10,"== Print Delta(iw) for first frequency in cubic basis"
3834 : 0 : call wrtout(std_out,message,"COLL")
3835 : 0 : call print_matlu(weiss%oper(1)%matlu(:),natom,1)
3836 : :
3837 : : if (basis == 0) then
3838 : 0 : write(message,'(a,3x,a)') ch10,"== Switching to CTQMC basis: staying in cubic basis"
3839 : : else if (basis == 1) then
3840 : 0 : write(message,'(a,3x,2a)') ch10,"== Switching to CTQMC basis: using basis that", &
3841 : 0 : & " diagonalizes the electronic levels"
3842 : : else if (basis == 2) then
3843 : 0 : write(message,'(a,3x,2a)') ch10,"== Switching to CTQMC basis: using basis that", &
3844 : 0 : & " diagonalizes the occupation matrix"
3845 : : else if (basis == 3) then
3846 : 0 : write(message,'(a,3x,a)') ch10,"== Switching to CTQMC basis: using Ylm basis"
3847 : : else if (basis == 4) then
3848 : 0 : write(message,'(a,3x,a)') ch10,"== Switching to CTQMC basis: using JmJ basis"
3849 : : end if
3850 : 0 : call wrtout(std_out,message,"COLL")
3851 : :
3852 [ # # ]: 0 : if (basis == 1) then
3853 : 0 : call checkdiag_matlu(energy_level%matlu(:),natom,tol,nondiag)
3854 [ # # ]: 0 : if (.not. nondiag) then
3855 : 0 : basis = 0
3856 : 0 : write(message,'(a,3x,a)') ch10,"== Electronic levels are 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 ! nondiag
3860 : 0 : call wrtout(std_out,message,"COLL")
3861 : : end if ! basis=1
3862 : :
3863 [ # # ]: 0 : if (basis == 2) then
3864 : 0 : call checkdiag_matlu(green%occup%matlu(:),natom,tol,nondiag)
3865 [ # # ]: 0 : if (.not. nondiag) then
3866 : 0 : basis = 0
3867 : 0 : write(message,'(a,3x,a)') ch10,"== Occupation matrix is already diagonal: staying in the cubic basis"
3868 : : else
3869 : 0 : write(message,'(a,3x,a)') ch10,"== Switching to Ylm basis first"
3870 : : end if ! not nondiag
3871 : 0 : call wrtout(std_out,message,"COLL")
3872 : : end if ! basis=2
3873 : :
3874 : 0 : call copy_matlu(green%occup%matlu(:),dmat_ctqmc(:),natom)
3875 : :
3876 [ # # ]: 0 : if (basis > 0) then ! First switch to Ylm basis in every case
3877 : 0 : call slm2ylm_matlu(energy_level%matlu(:),natom,paw_dmft,1,0)
3878 : 0 : call slm2ylm_matlu(dmat_ctqmc(:),natom,paw_dmft,1,0)
3879 [ # # ]: 0 : do i=2,weiss%nmoments-1
3880 : 0 : call slm2ylm_matlu(weiss%moments(i)%matlu(:),natom,paw_dmft,1,0)
3881 : : end do ! i
3882 [ # # ]: 0 : do ifreq=1,nwlo
3883 [ # # ]: 0 : if (weiss%distrib%procf(ifreq) /= myproc) cycle
3884 : 0 : call slm2ylm_matlu(weiss%oper(ifreq)%matlu(:),natom,paw_dmft,1,0)
3885 : : end do ! ifreq
3886 : : end if ! basis>0
3887 : :
3888 [ # # ]: 0 : if (basis == 1 .or. basis == 2) then
3889 : : ! Find block structure in Ylm basis and diagonalize for each block (extremely useful in the
3890 : : ! case of degenerate levels ; this ensures minimal mixing of Ylm and thus maximal number of subspaces)
3891 [ # # ]: 0 : if (basis == 1) then
3892 : 0 : matlu_pt => energy_level%matlu(:)
3893 : : else
3894 : 0 : matlu_pt => dmat_ctqmc(:)
3895 : : end if ! basis
3896 : :
3897 [ # # ]: 0 : if (pawprtvol >= 3) then
3898 [ # # ]: 0 : if (basis == 1) then
3899 : 0 : write(message,'(a,3x,a)') ch10,"== Print Energy levels in Ylm basis"
3900 : : else
3901 : 0 : write(message,'(a,3x,a)') ch10,"== Print Occupation matrix in Ylm basis"
3902 : : end if
3903 : 0 : call wrtout(std_out,message,"COLL")
3904 : :
3905 [ # # ]: 0 : call print_matlu(matlu_pt(:),natom,1)
3906 : : end if ! pawprtvol>=3
3907 : :
3908 : : call find_block_structure(paw_dmft,block_list(:,:),inner_list(:,:), &
3909 [ # # ]: 0 : & flavor_list(:,:,:),siz_block(:,:),nblocks(:),matlu_pt(:),natom,nflavor_max)
3910 [ # # ]: 0 : call diag_block(matlu_pt)
3911 : 0 : matlu_pt => null()
3912 : :
3913 : : ! Make sure every process has the same rotation matrix in case of degenerate levels
3914 : 0 : call xmpi_matlu(eigvectmatlu(:),natom,paw_dmft%spacecomm,master=0,option=2)
3915 : :
3916 [ # # ]: 0 : if (basis == 1) then
3917 : 0 : call rotate_matlu(dmat_ctqmc(:),eigvectmatlu(:),natom,1)
3918 : : else
3919 : 0 : call rotate_matlu(energy_level%matlu(:),eigvectmatlu(:),natom,1)
3920 : : end if ! basis
3921 [ # # ]: 0 : do i=2,weiss%nmoments-1
3922 : 0 : call rotate_matlu(weiss%moments(i)%matlu(:),eigvectmatlu(:),natom,1)
3923 : : end do ! i
3924 [ # # ]: 0 : do ifreq=1,nwlo
3925 [ # # ]: 0 : if (weiss%distrib%procf(ifreq) /= myproc) cycle
3926 : 0 : call rotate_matlu(weiss%oper(ifreq)%matlu(:),eigvectmatlu(:),natom,1)
3927 : : end do ! ifreq
3928 : : end if ! basis=1 or 2
3929 : :
3930 [ # # ]: 0 : if (basis == 4) then
3931 : 0 : call ylm2jmj_matlu(energy_level%matlu(:),natom,1,paw_dmft)
3932 : 0 : call ylm2jmj_matlu(dmat_ctqmc(:),natom,1,paw_dmft)
3933 [ # # ]: 0 : do i=2,weiss%nmoments-1
3934 : 0 : call ylm2jmj_matlu(weiss%moments(i)%matlu(:),natom,1,paw_dmft)
3935 : : end do
3936 [ # # ]: 0 : do ifreq=1,nwlo
3937 [ # # ]: 0 : if (weiss%distrib%procf(ifreq) /= myproc) cycle
3938 : 0 : call ylm2jmj_matlu(weiss%oper(ifreq)%matlu(:),natom,1,paw_dmft)
3939 : : end do ! ifreq
3940 : : end if ! basis=4
3941 : :
3942 [ # # ]: 0 : if (basis == 0) then
3943 [ # # ]: 0 : do iatom=1,natom
3944 : 0 : lpawu = paw_dmft%lpawu(iatom)
3945 [ # # ]: 0 : if (lpawu == -1) cycle
3946 : 0 : itypat = paw_dmft%typat(iatom)
3947 [ # # # # ]: 0 : udens_rot(iatom)%mat(:,:,1) = hu(itypat)%udens(:,:)
3948 [ # # # # : 0 : vee_rot(iatom)%mat(:,:,:,:) = hu(itypat)%veeslm2(:,:,:,:)
# # # # ]
3949 : : end do ! iatom
3950 : : else
3951 : 0 : call gather_oper(weiss%oper(:),weiss%distrib,paw_dmft,opt_ksloc=2)
3952 : 0 : rot_type_vee = 4
3953 [ # # ]: 0 : if (basis == 3) rot_type_vee = 2
3954 [ # # ]: 0 : if (basis == 4) rot_type_vee = 3
3955 : 0 : call rotatevee_hu(hu(:),paw_dmft,pawprtvol,eigvectmatlu(:),rot_type_vee,udens_rot(:),vee_rot(:))
3956 : : end if ! basis
3957 : :
3958 : 0 : write(message,'(a,3x,a)') ch10,"== Print Energy levels in CTQMC basis"
3959 : 0 : call wrtout(std_out,message,"COLL")
3960 : 0 : call print_matlu(energy_level%matlu(:),natom,1)
3961 : :
3962 : 0 : write(message,'(a,3x,a)') ch10,"== Print Occupation matrix in CTQMC basis"
3963 : 0 : call wrtout(std_out,message,"COLL")
3964 : 0 : call print_matlu(dmat_ctqmc(:),natom,1)
3965 : :
3966 : 0 : write(message,'(a,3x,a)') ch10,"== Print Delta(iw) for first frequency in CTQMC basis"
3967 : 0 : call wrtout(std_out,message,"COLL")
3968 : 0 : call print_matlu(weiss%oper(1)%matlu(:),natom,1)
3969 : :
3970 : : ! Possibly set the imaginary part and off-diagonal elements to 0 now that we
3971 : : ! are in the CTQMC basis. This is extremely important to do it explicitly instead of
3972 : : ! simply sending the real part or the diagonal elements to TRIQS since this modifies
3973 : : ! the electronic levels and hybridization that are used in Dyson's equation later.
3974 : :
3975 : : #ifndef HAVE_TRIQS_COMPLEX
3976 : 0 : write(message,'(a,3x,2a)') ch10,"== The imaginary part of Delta(tau) and the ", &
3977 : 0 : & "electronic levels is now set to 0"
3978 : 0 : call wrtout(std_out,message,"COLL")
3979 : : ! Symmetrizing Delta(iw) is equivalent to neglecting the imaginary part of Delta(tau)
3980 : 0 : err = zero
3981 [ # # ]: 0 : do ifreq=1,nwlo
3982 : 0 : call symmetrize_matlu(weiss%oper(ifreq)%matlu(:),natom,err=err_)
3983 : 0 : if (err_ > err) err = err_
3984 : : end do ! ifreq
3985 [ # # ]: 0 : do i=2,weiss%nmoments-1
3986 : 0 : call symmetrize_matlu(weiss%moments(i)%matlu(:),natom,err=err_)
3987 : 0 : if (err_ > err) err = err_
3988 : : end do ! i
3989 : 0 : call zero_matlu(energy_level%matlu(:),natom,onlyimag=1,err=err_)
3990 : 0 : if (err_ > err) err = err_
3991 [ # # ]: 0 : if (err > tol) then
3992 : 0 : write(message,'(2a)') "WARNING: This is not a good approximation ; the imaginary ", &
3993 : 0 : & "part is non negligible !"
3994 : 0 : ABI_WARNING(message)
3995 : : end if ! err>tol
3996 : : #endif
3997 : :
3998 : 0 : err = zero
3999 [ # # ]: 0 : if ((.not. rot_inv) .or. (.not. off_diag)) then
4000 : 0 : call zero_matlu(energy_level%matlu(:),natom,onlynondiag=1,err=err_)
4001 : 0 : if (err_ > err) err = err_
4002 : : end if
4003 : :
4004 [ # # ]: 0 : if (.not. off_diag) then
4005 : 0 : write(message,'(a,3x,2a)') ch10,"== The off-diagonal elements of the hybridization ", &
4006 : 0 : & "and the electronic levels are now set to 0"
4007 : 0 : call wrtout(std_out,message,"COLL")
4008 [ # # ]: 0 : do ifreq=1,nwlo
4009 : 0 : call zero_matlu(weiss%oper(ifreq)%matlu(:),natom,onlynondiag=1,err=err_)
4010 : 0 : if (err_ > err) err = err_
4011 : : end do ! ifreq
4012 [ # # ]: 0 : do i=2,weiss%nmoments-1
4013 : 0 : call zero_matlu(weiss%moments(i)%matlu(:),natom,onlynondiag=1,err=err_)
4014 : 0 : if (err_ > err) err = err_
4015 : : end do ! i
4016 [ # # ]: 0 : if (err > tol) then
4017 : 0 : write(message,'(2a)') "WARNING: This is not a good approximation ; the off-diagonal ", &
4018 : 0 : & "elements are non negligible !"
4019 : 0 : ABI_WARNING(message)
4020 : : end if ! err>tol
4021 : : end if ! not off_diag
4022 : :
4023 : : ! Prepare DLR frequencies
4024 [ # # ]: 0 : if (.not. leg_measure) then
4025 : 0 : wdlr_size = 1000 ! make sure this is big enough
4026 [ # # ]: 0 : ABI_MALLOC(wdlr_tmp,(wdlr_size))
4027 : 0 : ndlr_ptr = C_LOC(ndlr)
4028 : 0 : wdlr_ptr = C_LOC(wdlr_tmp)
4029 : : #if defined HAVE_TRIQS_INTERNAL || defined HAVE_TRIQS_v3_2
4030 : : call build_dlr(wdlr_size,ndlr_ptr,wdlr_ptr,paw_dmft%dmft_triqs_lambda,paw_dmft%dmft_triqs_epsilon)
4031 : : #endif
4032 [ # # ]: 0 : if (ndlr > wdlr_size) then
4033 : 0 : write(message,'(a,i4,2a)') "You have more than ",wdlr_size," DLR frequencies.", &
4034 : 0 : & " Something is wrong here."
4035 : 0 : ABI_ERROR(message)
4036 : : end if
4037 : :
4038 [ # # # # : 0 : ABI_MALLOC(wdlr,(ndlr))
# # # # #
# # # ]
4039 [ # # # # : 0 : ABI_MALLOC(wdlr_beta,(ndlr,4))
# # # # #
# # # #
# ]
4040 [ # # ]: 0 : wdlr(:) = wdlr_tmp(1:ndlr)
4041 [ # # ]: 0 : wdlr_beta(:,1) = wdlr(:) / beta
4042 [ # # ]: 0 : do i=2,4
4043 [ # # ]: 0 : wdlr_beta(:,i) = wdlr_beta(:,i-1) * wdlr_beta(:,1)
4044 : : end do
4045 [ # # ]: 0 : ABI_FREE(wdlr_tmp)
4046 [ # # # # : 0 : ABI_MALLOC(adlr,(ndlr,ntau))
# # # # #
# # # # #
# # # # ]
4047 [ # # # # : 0 : ABI_MALLOC(adlr_iw,(ndlr,nwlo))
# # # # #
# # # # #
# # # # ]
4048 : :
4049 [ # # ]: 0 : do ifreq=1,nwlo
4050 [ # # ]: 0 : do iw=1,ndlr
4051 : 0 : adlr_iw(iw,ifreq) = k_iw(paw_dmft%omega_lo(ifreq),wdlr_beta(iw,1))
4052 : : end do ! iw
4053 : : end do ! ifreq
4054 : :
4055 [ # # ]: 0 : do itau=1,ntau
4056 [ # # ]: 0 : do iw=1,ndlr
4057 : 0 : adlr(iw,itau) = k_it(dble(itau-1)/dble(ntau-1),wdlr(iw))
4058 : : end do ! iw
4059 : : end do ! itau
4060 : :
4061 : 0 : write(tag_at,'(i4)') ndlr
4062 [ # # ]: 0 : write(message,'(a,3x,3a)') ch10,"== There are ",trim(adjustl(tag_at))," DLR frequencies"
4063 : 0 : call wrtout(std_out,message,"COLL")
4064 : 0 : write(message,'(3x,1000(e10.3,2x))') wdlr_beta(:,1)
4065 : 0 : call wrtout(std_out,message,"COLL")
4066 : 0 : call identity_oper(green%moments(1),2)
4067 : : end if ! not leg_measure
4068 : :
4069 : : ! 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
4070 : : ! Gauss-Legendre grid), since we need it for the rest of the SCF calculation
4071 [ # # ]: 0 : ntot = merge(ngauss*nsub+1,1,integral>0.and.entropy)
4072 : :
4073 [ # # # # : 0 : ABI_MALLOC(elam_list,(ntot))
# # # # #
# # # ]
4074 [ # # # # : 0 : ABI_MALLOC(lam_list,(ntot)) ! scaling factors of U matrix for thermodynamic integration
# # # # ]
4075 : 0 : lam_list(ntot) = one
4076 : 0 : green%integral = zero
4077 : 0 : green%ekin_imp = zero
4078 : :
4079 : : ! Prepare Gauss-Legendre quadrature for thermodynamic integration over U
4080 [ # # ]: 0 : if (integral > 0 .and. entropy) then
4081 : :
4082 [ # # # # : 0 : ABI_MALLOC(tweights,(ngauss))
# # # # #
# # # ]
4083 [ # # # # : 0 : ABI_MALLOC(tpoints,(ngauss))
# # # # ]
4084 : :
4085 : : ! Calculation of Gauss-Legendre grid (on [-1,1]) of size ngauss
4086 : 0 : call coeffs_gausslegint(-one,one,tpoints(:),tweights(:),ngauss)
4087 : :
4088 : 0 : dx = one / dble(nsub)
4089 : :
4090 : : ! Split [0,1] into nsub intervals [x_i,x_{i+1}],i=1,nsub with x_i=(i-1)*dx
4091 [ # # ]: 0 : do isub=1,nsub
4092 : : ! For each interval, the Gauss-Legendre grid of size ngauss is mapped from the
4093 : : ! t-world where t in [-1,1] to the x-world where x in [x_{isub},x_{isub+1}]
4094 [ # # ]: 0 : lam_list((isub-1)*ngauss+1:isub*ngauss) = (dble(isub)*two+tpoints(:)-one) * dx * half
4095 : : end do ! ilam
4096 : :
4097 : : end if ! integral and entropy
4098 : :
4099 : : ! Build most optimal block structure in CTQMC basis
4100 : 0 : write(message,'(a,3x,2a)') ch10,"== Searching for the most optimal block structure of", &
4101 : 0 : & " the electronic levels and the hybridization"
4102 : 0 : call wrtout(std_out,message,"COLL")
4103 : :
4104 : : call find_block_structure(paw_dmft,block_list(:,:),inner_list(:,:),flavor_list(:,:,:), &
4105 : 0 : & siz_block(:,:),nblocks(:),energy_level%matlu(:),natom,nflavor_max,hyb=weiss)
4106 : :
4107 : 0 : nmoments = weiss%nmoments - 2
4108 : :
4109 : : ! Inverse Fourier transform of the hybridization
4110 : 0 : call fourier_inv(paw_dmft,nmoments,ntau,ftau(:),weiss%oper(:),weiss%moments(2:nmoments+1))
4111 : :
4112 [ # # ]: 0 : if (entropy) then
4113 [ # # # # : 0 : ABI_MALLOC(emig,(natom))
# # # # #
# # # ]
4114 : : ! Cubic splines to compute the derivative of Delta(iw)
4115 : 0 : call initialize_self(hybmwdhyb,paw_dmft,opt_moments=1)
4116 : 0 : call cubic_spline()
4117 : 0 : call copy_matlu(energy_level%matlu(:),hybmwdhyb%moments(1)%matlu(:),natom)
4118 [ # # ]: 0 : do i=2,weiss%nmoments-1
4119 : 0 : call copy_matlu(weiss%moments(i)%matlu(:),hybmwdhyb%moments(i)%matlu(:),natom)
4120 : 0 : call fac_matlu(hybmwdhyb%moments(i)%matlu(:),natom,cmplx(dble(i),zero,kind=dp))
4121 : : end do ! i
4122 : : end if ! entropy
4123 : :
4124 : : ! Solve impurity model for each atom
4125 [ # # ]: 0 : do iatom=1,natom
4126 : :
4127 : 0 : lpawu = paw_dmft%lpawu(iatom)
4128 [ # # ]: 0 : if (lpawu == -1) cycle
4129 : 0 : ndim = 2*lpawu + 1
4130 : 0 : tndim = nspinor * ndim
4131 : 0 : nflavor = 2 * ndim
4132 : :
4133 : : !Local Spin-Spin correlation function
4134 [ # # ]: 0 : if (paw_dmft%dmft_triqs_chiloc > 0) then
4135 : :
4136 : : ! == slm case : \hat{S_z} = n_up - n_down
4137 [ # # # # : 0 : ABI_MALLOC(chiloc_tmp,(1:ntau,1:ntau))
# # # # #
# # # # #
# # # # ]
4138 : 0 : chiloc_ptr = C_LOC(chiloc_tmp)
4139 : :
4140 : : ! == Mj case : \hat{J_z} = n_mj * \mu_mjz
4141 [ # # # # ]: 0 : if(nspinor .eq. 2 .and. basis .eq. 4) then
4142 : 0 : magmom_ptr = C_NULL_PTR
4143 : :
4144 [ # # # # : 0 : ABI_MALLOC(magmom_tot,(natom))
# # # # #
# # # # #
# # # # #
# ]
4145 [ # # # # : 0 : ABI_MALLOC(matlumag_tot,(natom))
# # # # #
# # # # #
# # # # #
# ]
4146 : :
4147 : 0 : lpawu = paw_dmft%lpawu(iatom)
4148 [ # # ]: 0 : if (lpawu == -1) cycle
4149 [ # # # # : 0 : ABI_MALLOC(magmom_tot(iatom)%value,(2*(2*lpawu+1),2*(2*lpawu+1)))
# # # # #
# # # # #
# # # # #
# ]
4150 [ # # # # ]: 0 : magmom_tot(iatom)%value=czero
4151 : :
4152 : 0 : call init_matlu(natom=1,nspinor=paw_dmft%nspinor,nsppol=paw_dmft%nsppol,lpawu_natom=paw_dmft%lpawu,matlu=matlumag_tot)
4153 : 0 : call zero_matlu(matlumag_tot,natom=1)
4154 : 0 : call magmomjmj_matlu(matlumag_tot,natom=1)
4155 : 0 : call gather_matlu(matlumag_tot,magmom_tot,natom=1,option=1,prtopt=0)
4156 : 0 : call destroy_matlu(matlumag_tot,natom=1)
4157 : : !
4158 [ # # # # : 0 : ABI_MALLOC(magmom_array,(nflavor*nflavor))
# # # # #
# # # ]
4159 [ # # ]: 0 : magmom_array(:) = zero
4160 [ # # # # : 0 : magmom_array = reshape(real(magmom_tot(iatom)%value), (/nflavor*nflavor/))
# # # # #
# # # # #
# # ]
4161 : 0 : magmom_ptr = C_LOC(magmom_array)
4162 : : end if
4163 : : end if !end chiloc
4164 : :
4165 : 0 : write(tag_at,'(i4)') iatom
4166 : 0 : write(tag_block,'(i2)') nblocks(iatom)
4167 [ # # ]: 0 : write(message,'(a,3x,6a)') ch10,"== Solving impurity model for atom ",trim(adjustl(tag_at)), &
4168 [ # # ]: 0 : & ", where there are ",trim(adjustl(tag_block))," blocks",ch10
4169 : 0 : call wrtout(std_out,message,'COLL')
4170 : :
4171 [ # # ]: 0 : do iblock=1,nblocks(iatom)
4172 : 0 : write(tag_block,'(i2)') iblock - 1
4173 : 0 : tag_block2 = ""
4174 [ # # ]: 0 : do iflavor=1,siz_block(iblock,iatom)
4175 : 0 : write(tag_block3,'(i2)') flavor_list(iflavor,iblock,iatom)
4176 [ # # ]: 0 : tag_block2 = trim(tag_block2) // " " // trim(adjustl(tag_block3))
4177 : : end do ! iflavor
4178 : 0 : tag_block4 = ""
4179 [ # # ]: 0 : if (siz_block(iblock,iatom) > 1) tag_block4 = "s"
4180 [ # # # # : 0 : write(message,'(2x,4a,1x,a)') "--> Block ",trim(adjustl(tag_block))," contains flavor",trim(adjustl(tag_block4)),trim(adjustl(tag_block2))
# # ]
4181 : 0 : call wrtout(std_out,message,'COLL')
4182 : : end do ! iblock
4183 : :
4184 : 0 : write(message,'(a,3x,2a)') ch10,"== Schematic of the block structure",ch10
4185 : 0 : call wrtout(std_out,message,'COLL')
4186 : :
4187 : 0 : iflavor = 1
4188 [ # # ]: 0 : do iblock=1,nblocks(iatom)
4189 [ # # ]: 0 : do iflavor1=1,siz_block(iblock,iatom)
4190 : 0 : tag_block2 = ""
4191 [ # # ]: 0 : do iflavor2=1,iflavor-1
4192 [ # # ]: 0 : tag_block2 = trim(tag_block2) // " ."
4193 : : end do ! iflavor2
4194 [ # # ]: 0 : do iflavor2=1,iflavor1-1
4195 [ # # ]: 0 : tag_block2 = trim(tag_block2) // " x"
4196 : : end do ! iflavor2
4197 : 0 : write(tag_block,'(i2)') flavor_list(iflavor1,iblock,iatom)
4198 [ # # ]: 0 : i = merge(1,2,flavor_list(iflavor1,iblock,iatom)>=10)
4199 [ # # # # ]: 0 : tag_block2 = trim(tag_block2) // repeat(" ",i) // trim(adjustl(tag_block))
4200 [ # # ]: 0 : do iflavor2=iflavor1+1,siz_block(iblock,iatom)
4201 [ # # ]: 0 : tag_block2 = trim(tag_block2) // " x"
4202 : : end do ! iflavor2
4203 [ # # ]: 0 : do iflavor2=iflavor+siz_block(iblock,iatom),nflavor
4204 [ # # ]: 0 : tag_block2 = trim(tag_block2) // " ."
4205 : : end do ! iflavor2
4206 : 0 : write(message,'(4x,a)') tag_block2
4207 : 0 : call wrtout(std_out,message,'COLL')
4208 : : end do ! iflavor1
4209 : 0 : iflavor = iflavor + siz_block(iblock,iatom)
4210 : : end do ! iblock
4211 : :
4212 : 0 : call int2char4(iatom,tag_at)
4213 [ # # ]: 0 : ABI_CHECK((tag_at(1:1)/='#'),'Bug: string length too short!')
4214 : :
4215 [ # # ]: 0 : if (myproc == 0 .and. off_diag) then
4216 : :
4217 [ # # ]: 0 : if (open_file(trim(paw_dmft%filapp)//"_Hybridization_offdiag_iatom"//tag_at//".dat",message,newunit=unt) /= 0) ABI_ERROR(message)
4218 : 0 : write(unt,'(6a)') "# Off-diagonal components of Delta(tau) in the CTQMC basis",ch10, &
4219 : 0 : & "# Columns are ordered this way:",ch10, &
4220 : 0 : & "# Imaginary Time ((Re(Delta_{ij}) Im(Delta_{ij}),i=1,2*(2*l+1)),j=1,2*(2*l+1)) where the", &
4221 : 0 : & " leftmost index varies first"
4222 : :
4223 [ # # ]: 0 : do itau=1,ntau
4224 : 0 : write(unt,'(2x,393(e18.10e3,2x))') beta*dble(itau-1)/dble(ntau-1), &
4225 [ # # # # : 0 : & ((dble(ftau(iatom)%mat(im,im1,itau)),aimag(ftau(iatom)%mat(im,im1,itau)),im=1,nflavor),im1=1,nflavor)
# # # # ]
4226 : : end do ! itau
4227 : 0 : close(unt)
4228 : :
4229 : : end if ! myproc=0
4230 : :
4231 [ # # ]: 0 : if (myproc == 0) then
4232 : :
4233 [ # # ]: 0 : if (open_file(trim(paw_dmft%filapp)//"_Hybridization_diag_iatom"//tag_at//".dat",message,newunit=unt) /= 0) ABI_ERROR(message)
4234 : 0 : write(unt,'(5a)') "# Diagonal components of Delta(tau) in the CTQMC basis",ch10, &
4235 : 0 : & "# Columns are ordered this way:",ch10, &
4236 : 0 : & "# Imaginary Time (Delta_{ii},i=1,2*(2*l+1))"
4237 : :
4238 [ # # ]: 0 : do itau=1,ntau
4239 [ # # # # ]: 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)
4240 : : end do ! itau
4241 : 0 : close(unt)
4242 : :
4243 : : end if ! myproc=0
4244 : :
4245 [ # # # # : 0 : ABI_MALLOC(levels_ctqmc,(nflavor,nflavor))
# # # # #
# # # # #
# # ]
4246 [ # # # # : 0 : ABI_MALLOC(gtau,(ntau,nflavor,nflavor))
# # # # #
# # # # #
# # # # #
# # # ]
4247 [ # # # # : 0 : gtau(:,:,:) = czero
# # ]
4248 [ # # ]: 0 : if (density_matrix) then
4249 [ # # # # : 0 : ABI_MALLOC(occ,(nflavor))
# # # # #
# # # #
# ]
4250 : : end if
4251 [ # # # # ]: 0 : if ((.not. leg_measure) .and. density_matrix) then
4252 [ # # # # : 0 : ABI_MALLOC(moments_self_1,(nflavor))
# # # # #
# # # #
# ]
4253 [ # # # # : 0 : ABI_MALLOC(moments_self_2,(nflavor))
# # # # #
# ]
4254 : : end if
4255 : : if (leg_measure) then
4256 [ # # # # : 0 : ABI_MALLOC(gl,(nleg,nflavor,nflavor))
# # # # #
# # # # #
# # # # #
# # # ]
4257 [ # # # # : 0 : gl(:,:,:) = czero
# # ]
4258 : : end if
4259 [ # # # # : 0 : ABI_MALLOC(flavor_tmp,(nflavor,nflavor))
# # # # #
# # # # #
# # ]
4260 : :
4261 [ # # # # ]: 0 : levels_ctqmc(:,:) = czero
4262 [ # # ]: 0 : do isppol=1,nsppol
4263 : : levels_ctqmc(1+(isppol-1)*ndim:tndim+(isppol-1)*ndim,1+(isppol-1)*ndim:tndim+(isppol-1)*ndim) = &
4264 [ # # # # ]: 0 : & energy_level%matlu(iatom)%mat(:,:,isppol)
4265 [ # # # # : 0 : if (nsppol == 1 .and. nspinor == 1) levels_ctqmc(1+ndim:2*ndim,1+ndim:2*ndim) = levels_ctqmc(1:ndim,1:ndim)
# # # # #
# # # #
# ]
4266 : : end do ! isppol
4267 : :
4268 : : ! Need to slice flavor_list to make it size nflavor*nflavor instead of size nflavor_max*nflavor_max
4269 [ # # # # ]: 0 : flavor_tmp(:,:) = flavor_list(1:nflavor,1:nflavor,iatom)
4270 : :
4271 : 0 : block_ptr = C_LOC(block_list(:,iatom))
4272 : 0 : eu_ptr = C_LOC(eu)
4273 : 0 : flavor_ptr = C_LOC(flavor_tmp(:,:))
4274 : 0 : fname_data_ptr = C_LOC(fname_data)
4275 : 0 : fname_dataw_ptr = C_LOC(fname_dataw)
4276 : 0 : fname_histo_ptr = C_LOC(fname_histo)
4277 : 0 : ftau_ptr = C_LOC(ftau(iatom)%mat(:,:,:))
4278 : 0 : gl_ptr = C_LOC(gl(:,:,:))
4279 : 0 : gtau_ptr = C_LOC(gtau(:,:,:))
4280 : 0 : inner_ptr = C_LOC(inner_list(:,iatom))
4281 : 0 : levels_ptr = C_LOC(levels_ctqmc(:,:))
4282 : 0 : mself_1_ptr = C_LOC(moments_self_1(:))
4283 : 0 : mself_2_ptr = C_LOC(moments_self_2(:))
4284 : 0 : occ_ptr = C_LOC(occ(:))
4285 : 0 : siz_ptr = C_LOC(siz_block(:,iatom))
4286 : 0 : udens_ptr = C_LOC(udens_rot(iatom)%mat(:,:,1))
4287 : 0 : vee_ptr = C_LOC(vee_rot(iatom)%mat(:,:,:,:))
4288 : :
4289 : 0 : verbo = 1
4290 : :
4291 [ # # ]: 0 : do ilam=1,ntot
4292 : :
4293 [ # # ]: 0 : if (ilam /= ntot) then
4294 : 0 : write(message,'(a,3x,a,f6.4,a)') ch10,"== Thermodynamic integration over interaction for lambda= ",lam_list(ilam),ch10
4295 : 0 : call wrtout(std_out,message,'COLL')
4296 : :
4297 : : ! Integrate over diagonal electronic levels
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) + (lam_list(ilam)-one)*shift_mu
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 : :
4306 : : end if ! ilam/=ntot
4307 : :
4308 [ # # # # ]: 0 : if (ilam == ntot .and. entropy .and. integral == 1) then
4309 [ # # ]: 0 : do isppol=1,nsppol
4310 [ # # ]: 0 : do im=1,tndim
4311 : 0 : iflavor = im + (isppol-1)*ndim
4312 : 0 : levels_ctqmc(iflavor,iflavor) = energy_level%matlu(iatom)%mat(im,im,isppol)
4313 [ # # # # ]: 0 : if (nsppol == 1 .and. nspinor == 1) levels_ctqmc(iflavor+ndim,iflavor+ndim) = levels_ctqmc(iflavor,iflavor)
4314 : : end do ! im
4315 : : end do ! isppol
4316 : : end if
4317 : :
4318 : 0 : if (ilam == 2) verbo = 0
4319 : :
4320 [ # # ]: 0 : if (ilam < 10) then
4321 : 0 : write(tag_lam,'("0",i1)') ilam
4322 : : else
4323 : 0 : write(tag_lam,'(i2)') ilam
4324 : : end if
4325 : :
4326 : 0 : tag_lam2 = ""
4327 [ # # ]: 0 : if (ilam /= ntot) tag_lam2 = "_ilam" // tag_lam
4328 : :
4329 : 0 : read_data = paw_dmft%dmft_triqs_read_ctqmcdata
4330 [ # # # # ]: 0 : stringfile = "_iatom" // tag_at // trim(adjustl(tag_lam2)) // ".h5"
4331 : :
4332 [ # # ]: 0 : if (paw_dmft%idmftloop == 1) then
4333 : 0 : read_data = 0
4334 : : if (paw_dmft%dmft_triqs_read_ctqmcdata == 1 .and. paw_dmft%ireadctqmcdata == 1) read_data = 1
4335 [ # # # # ]: 0 : fname_data = trim(adjustl(paw_dmft%filctqmcdatain)) // stringfile
4336 : : else
4337 [ # # # # ]: 0 : fname_data = trim(adjustl(paw_dmft%filapp)) // "_CTQMC_DATA" // stringfile
4338 : : end if
4339 [ # # ]: 0 : len_t = len(trim(adjustl(fname_data))) + 1
4340 : 0 : fname_data(len_t:len_t) = c_null_char
4341 : :
4342 [ # # # # ]: 0 : fname_dataw = trim(adjustl(paw_dmft%filapp)) // "_CTQMC_DATA" // stringfile
4343 [ # # ]: 0 : len_t = len(trim(adjustl(fname_dataw))) + 1
4344 : 0 : fname_dataw(len_t:len_t) = c_null_char
4345 : :
4346 [ # # # # : 0 : fname_histo = trim(adjustl(paw_dmft%filapp)) // "_CTQMC_HISTOGRAM_iatom" // tag_at // trim(adjustl(tag_lam2)) // ".dat"
# # ]
4347 [ # # ]: 0 : len_t = len(trim(adjustl(fname_histo))) + 1
4348 : 0 : fname_histo(len_t:len_t) = c_null_char
4349 : :
4350 : 0 : call flush_unit(std_out)
4351 : :
4352 : : #if defined HAVE_TRIQS_INTERNAL || defined HAVE_TRIQS_v3_2
4353 : : call Ctqmc_triqs_run(rot_inv,leg_measure,paw_dmft%dmft_triqs_move_shift,paw_dmft%dmft_triqs_move_double, &
4354 : : & density_matrix,paw_dmft%dmft_triqs_time_invariance,paw_dmft%dmft_triqs_use_norm_as_weight, &
4355 : : & debug,merge(integral,0,ilam/=ntot),paw_dmft%dmft_triqs_loc_n_min,paw_dmft%dmft_triqs_loc_n_max, &
4356 : : & paw_dmft%dmft_triqs_seed_a,paw_dmft%dmft_triqs_seed_b,nflavor,ntau,nleg, &
4357 : : & paw_dmft%dmft_triqs_n_cycles,paw_dmft%dmftctqmc_meas,paw_dmft%dmftqmc_therm, &
4358 : : & paw_dmft%dmft_triqs_therm_restart,paw_dmft%dmft_triqs_det_init_size, &
4359 : : & paw_dmft%dmft_triqs_det_n_operations_before_check,myproc,nblocks(iatom),read_data,verbo, &
4360 : : & paw_dmft%dmft_triqs_chiloc,paw_dmft%dmft_triqs_chiloc_ins,beta,paw_dmft%dmft_triqs_imag_threshold, &
4361 : : & paw_dmft%dmft_triqs_det_precision_warning, &
4362 : : & paw_dmft%dmft_triqs_det_precision_error,paw_dmft%dmft_triqs_det_singular_threshold,lam_list(ilam), &
4363 : : & paw_dmft%dmft_triqs_pauli_prob,chiloc_ptr,magmom_ptr,block_ptr,flavor_ptr,inner_ptr,siz_ptr,ftau_ptr,gtau_ptr,gl_ptr, &
4364 : : & udens_ptr,vee_ptr,levels_ptr,mself_1_ptr,mself_2_ptr,occ_ptr,eu_ptr,fname_data_ptr,fname_dataw_ptr, &
4365 : : & fname_histo_ptr)
4366 : : #endif
4367 : :
4368 : 0 : call flush_unit(std_out)
4369 : :
4370 [ # # # # ]: 0 : if (ilam == ntot .or. debug) then
4371 : :
4372 [ # # ]: 0 : do isppol=1,nsppol
4373 [ # # # # ]: 0 : if (nsppol == 1 .and. nspinor == 1) then
4374 [ # # # # ]: 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
4375 : : else
4376 [ # # # # ]: 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)
4377 : : end if
4378 : : end do ! isppol
4379 : :
4380 [ # # # # : 0 : if ((.not. leg_measure) .and. density_matrix .and. ilam == ntot) then
# # ]
4381 : :
4382 : : ! Constrain the occupations and high-frequency moments with the more accurate values sampled from the CTQMC
4383 : :
4384 [ # # ]: 0 : do isppol=1,nsppol
4385 [ # # ]: 0 : do im=1,tndim
4386 : 0 : iflavor = im + (isppol-1)*ndim
4387 : :
4388 [ # # # # ]: 0 : if (nsppol == 1 .and. nspinor == 1) then
4389 : 0 : mself_1 = (moments_self_1(iflavor)+moments_self_1(iflavor+ndim)) * half
4390 : 0 : mself_2 = (moments_self_2(iflavor)+moments_self_2(iflavor+ndim)) * half
4391 : : else
4392 : 0 : mself_1 = moments_self_1(iflavor)
4393 : 0 : mself_2 = moments_self_2(iflavor)
4394 : : end if
4395 : :
4396 : 0 : green%moments(2)%matlu(iatom)%mat(im,im,isppol) = energy_level%matlu(iatom)%mat(im,im,isppol) + mself_1
4397 : 0 : green%moments(3)%matlu(iatom)%mat(im,im,isppol) = weiss%moments(2)%matlu(iatom)%mat(im,im,isppol) + mself_2
4398 : :
4399 : : end do ! im
4400 : :
4401 : : ! Use matmul in prevision of the day where the off-diagonal density matrix will be available
4402 : : green%moments(3)%matlu(iatom)%mat(:,:,isppol) = green%moments(3)%matlu(iatom)%mat(:,:,isppol) + &
4403 [ # # # # : 0 : & matmul(green%moments(2)%matlu(iatom)%mat(:,:,isppol),green%moments(2)%matlu(iatom)%mat(:,:,isppol))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
4404 : :
4405 : : end do ! isppol
4406 : :
4407 : : end if ! not leg and density_matrix
4408 : :
4409 [ # # ]: 0 : if (density_matrix) then
4410 : :
4411 : 0 : green%ecorr_qmc(iatom) = dble(eu)
4412 : :
4413 [ # # ]: 0 : do isppol=1,nsppol
4414 [ # # ]: 0 : do im=1,tndim
4415 : 0 : iflavor = im + (isppol-1)*ndim
4416 : :
4417 [ # # # # ]: 0 : if (nsppol == 1 .and. nspinor == 1) then
4418 : 0 : occ_tmp = (occ(iflavor)+occ(iflavor+ndim)) * half
4419 : : else
4420 : 0 : occ_tmp = occ(iflavor)
4421 : : end if
4422 : :
4423 : 0 : green%oper_tau(1)%matlu(iatom)%mat(im,im,isppol) = occ_tmp - cone
4424 : :
4425 : : end do ! im
4426 : : end do ! isppol
4427 : :
4428 : : end if ! density_matrix
4429 : :
4430 [ # # ]: 0 : if (ilam < ntot) then
4431 : 0 : call occup_green_tau(green)
4432 : :
4433 : 0 : write(message,'(a,3x,a)') ch10,"== Print Occupation matrix in CTQMC basis"
4434 : 0 : call wrtout(std_out,message,"COLL")
4435 : 0 : call print_matlu(green%occup_tau%matlu(:),natom,1)
4436 : : end if
4437 : :
4438 [ # # ]: 0 : if (leg_measure) then
4439 : :
4440 [ # # # # : 0 : ABI_MALLOC(gl_tmp,(nleg,tndim,tndim,nsppol))
# # # # #
# # # # #
# # # # #
# # # #
# ]
4441 [ # # # # : 0 : ABI_MALLOC(jbes,(nleg))
# # # # #
# # # ]
4442 : :
4443 [ # # # # : 0 : gl_tmp(:,:,:,:) = czero
# # # # ]
4444 : :
4445 [ # # ]: 0 : do ifreq=1,nwlo
4446 [ # # # # : 0 : green%oper(ifreq)%matlu(iatom)%mat(:,:,:) = czero
# # ]
4447 : 0 : xx = dble(2*ifreq-1) * pi / two
4448 [ # # ]: 0 : if (xx <= dble(100)) then
4449 : 0 : call sbf8(nleg,xx,jbes(:))
4450 : : end if
4451 [ # # ]: 0 : do isppol=1,nsppol
4452 [ # # ]: 0 : do im1=1,tndim
4453 : 0 : iflavor1 = im1 + (isppol-1)*ndim
4454 [ # # ]: 0 : do im=1,tndim
4455 : 0 : iflavor = im + (isppol-1)*ndim
4456 [ # # ]: 0 : do ileg=1,nleg
4457 [ # # ]: 0 : if (xx >= dble(99)) then
4458 : 0 : call jbessel(jbes(ileg),besp,bespp,ileg-1,1,xx)
4459 : : end if
4460 : 0 : u_nl = sqrt(dble(2*ileg-1))*(-1)**(ifreq-1)*(j_dpc**(ileg))*jbes(ileg)
4461 [ # # # # ]: 0 : if (nsppol == 1 .and. nspinor == 1) then
4462 : : gl_tmp(ileg,im,im1,isppol) = &
4463 : 0 : & (gl(ileg,iflavor,iflavor1)+gl(ileg,iflavor+ndim,iflavor1+ndim))*half
4464 : : else
4465 : 0 : gl_tmp(ileg,im,im1,isppol) = gl(ileg,iflavor,iflavor1)
4466 : : end if
4467 : : green%oper(ifreq)%matlu(iatom)%mat(im,im1,isppol) = &
4468 : : & green%oper(ifreq)%matlu(iatom)%mat(im,im1,isppol) + &
4469 : 0 : & u_nl*gl_tmp(ileg,im,im1,isppol)
4470 : : end do ! ileg
4471 : : end do ! im
4472 : : end do ! im1
4473 : : end do ! isppol
4474 : : end do ! ifreq
4475 : :
4476 [ # # ]: 0 : ABI_FREE(jbes)
4477 : :
4478 [ # # # # : 0 : ABI_MALLOC(gtau_leg,(ntau,nflavor,nflavor))
# # # # #
# # # # #
# # # # #
# ]
4479 [ # # # # : 0 : ABI_MALLOC(leg_array,(nleg,ntau))
# # # # #
# # # # #
# # ]
4480 : :
4481 [ # # ]: 0 : do itau=1,ntau
4482 : 0 : tau = dble(itau-1) * beta / (ntau-1)
4483 : 0 : xtau = two*tau/beta - one
4484 : 0 : leg_array(1,itau) = one
4485 : 0 : leg_array(2,itau) = xtau
4486 [ # # ]: 0 : do ileg=3,nleg
4487 : : leg_array(ileg,itau) = (dble(2*(ileg-2)+1)*xtau*leg_array(ileg-1,itau)- &
4488 : 0 : & dble(ileg-2)*leg_array(ileg-2,itau)) / dble(ileg-1)
4489 : : end do ! ileg
4490 : : end do ! itau
4491 : :
4492 [ # # # # : 0 : gtau_leg(:,:,:) = czero
# # ]
4493 [ # # ]: 0 : do iflavor1=1,nflavor
4494 [ # # ]: 0 : do iflavor=1,nflavor
4495 [ # # ]: 0 : do itau=1,ntau
4496 [ # # ]: 0 : do ileg=1,nleg
4497 : : gtau_leg(itau,iflavor,iflavor1) = gtau_leg(itau,iflavor,iflavor1) + &
4498 : 0 : & gl(ileg,iflavor,iflavor1)*leg_array(ileg,itau)*sqrt(dble(2*ileg-1))/beta
4499 : : end do ! ileg
4500 : : end do ! itau
4501 : : end do ! iflavor
4502 : : end do ! iflavor1
4503 : :
4504 [ # # ]: 0 : if (myproc == 0 .and. off_diag) then
4505 : :
4506 [ # # # # ]: 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)
4507 : 0 : write(unt,'(6a)') "# Off-diagonal components of Legendre-sampled G(tau) in the CTQMC basis",ch10, &
4508 : 0 : & "# Columns are ordered this way:",ch10, &
4509 : 0 : & "# Imaginary Time ((Re(G_{ij}) Im(G_{ij}),i=1,2*(2*l+1)),j=1,2*(2*l+1)) where the", &
4510 : 0 : & " leftmost index varies first"
4511 [ # # ]: 0 : do itau=1,ntau
4512 : 0 : write(unt,'(2x,393(e18.10e3,2x))') beta*dble(itau-1)/dble(ntau-1), &
4513 [ # # # # : 0 : & ((dble(gtau_leg(itau,im,im1)),aimag(gtau_leg(itau,im,im1)),im=1,nflavor),im1=1,nflavor)
# # # # ]
4514 : : end do ! itau
4515 : 0 : close(unt)
4516 : :
4517 : : end if ! myproc=0
4518 : :
4519 [ # # ]: 0 : if (myproc == 0) then
4520 : :
4521 [ # # # # ]: 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)
4522 : 0 : write(unt,'(5a)') "# Diagonal components of Legendre-sampled G(tau) in the CTQMC basis",ch10, &
4523 : 0 : & "# Columns are ordered this way:",ch10, &
4524 : 0 : & "# Imaginary Time (G_{ii},i=1,2*(2*l+1))"
4525 [ # # ]: 0 : do itau=1,ntau
4526 [ # # # # ]: 0 : write(unt,'(2x,393(e25.17e3,2x))') beta*dble(itau-1)/dble(ntau-1),(dble(gtau_leg(itau,im,im)),im=1,nflavor)
4527 : : end do ! itau
4528 : 0 : close(unt)
4529 : :
4530 : : end if ! myproc=0
4531 : :
4532 [ # # ]: 0 : ABI_FREE(gtau_leg)
4533 [ # # ]: 0 : ABI_FREE(leg_array)
4534 : :
4535 [ # # # # : 0 : ABI_MALLOC(t_lp,(nleg,green%nmoments))
# # # # #
# # # # #
# # ]
4536 : :
4537 : 0 : fact = one ! this is equal to (p-1)!
4538 : :
4539 : : ! Compute analytical moments of Fourier transform of Legendre polynomial
4540 : : ! (equation (E2) of PRB, 84(7), 2011, Boehnke et al)
4541 [ # # ]: 0 : do p=1,green%nmoments
4542 [ # # ]: 0 : if (p > 1) fact = fact * dble(p-1)
4543 : 0 : fact2 = fact
4544 [ # # ]: 0 : do l=0,nleg-1
4545 [ # # ]: 0 : if (l > 0) fact2 = fact2 * dble(l+p-1)
4546 [ # # ]: 0 : if (p > l+1) then
4547 : 0 : t_lp(l+1,p) = zero
4548 : : else
4549 [ # # ]: 0 : if (l-p+1 > 0) fact2 = fact2 / dble(l-p+1) ! fact2 is now equal to (l+p-1)...(l-p+2)
4550 [ # # ]: 0 : if (mod(p+l,2) == 0) then
4551 : 0 : t_lp(l+1,p) = zero
4552 : : else
4553 : 0 : t_lp(l+1,p) = (-1)**p * two * sqrt(dble(2*l+1)) * fact2 / fact
4554 : : end if
4555 : : end if ! p>l+1
4556 : : end do ! l
4557 [ # # ]: 0 : do isppol=1,nsppol
4558 [ # # ]: 0 : do im1=1,tndim
4559 [ # # ]: 0 : do im=1,tndim
4560 : : ! Do not use DOT_PRODUCT
4561 [ # # ]: 0 : green%moments(p)%matlu(iatom)%mat(im,im1,isppol) = sum(t_lp(:,p)*gl_tmp(:,im,im1,isppol)) / beta**p
4562 : : end do ! im
4563 : : end do ! im1
4564 : : end do ! isppol
4565 : : end do ! p
4566 : :
4567 [ # # ]: 0 : ABI_FREE(gl_tmp)
4568 [ # # ]: 0 : ABI_FREE(t_lp)
4569 : :
4570 [ # # ]: 0 : else if (ilam == ntot) then
4571 : :
4572 [ # # # # : 0 : ABI_MALLOC(gl_dlr,(ndlr,tndim,tndim,nsppol))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
4573 [ # # # # : 0 : ABI_MALLOC(gl_dlr_re,(ndlr))
# # # # #
# # # #
# ]
4574 [ # # # # : 0 : ABI_MALLOC(gl_dlr_im,(ndlr))
# # # # #
# ]
4575 [ # # # # : 0 : ABI_MALLOC(bdlr,(ntau))
# # # # #
# # # #
# ]
4576 [ # # # # : 0 : ABI_MALLOC(gtau_dlr,(ntau,nflavor,nflavor))
# # # # #
# # # # #
# # # # #
# # # ]
4577 [ # # # # : 0 : ABI_MALLOC(moment_fit,(green%nmoments))
# # # # #
# # # #
# ]
4578 : :
4579 [ # # # # : 0 : gtau_dlr(:,:,:) = czero
# # ]
4580 : :
4581 : 0 : call fit_dlr()
4582 : :
4583 [ # # ]: 0 : if (myproc == 0 .and. off_diag) then
4584 : :
4585 [ # # # # ]: 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)
4586 : 0 : write(unt,'(6a)') "# Off-diagonal components of DLR fit of G(tau) in the CTQMC basis",ch10, &
4587 : 0 : & "# Columns are ordered this way:",ch10, &
4588 : 0 : & "# Imaginary Time ((Re(G_{ij}) Im(G_{ij}),i=1,2*(2*l+1)),j=1,2*(2*l+1)) where the", &
4589 : 0 : & " leftmost index varies first"
4590 : :
4591 [ # # ]: 0 : do itau=1,ntau
4592 : 0 : write(unt,'(2x,393(e18.10e3,2x))') beta*dble(itau-1)/dble(ntau-1), &
4593 [ # # # # : 0 : & ((dble(gtau_dlr(itau,im,im1)),aimag(gtau_dlr(itau,im,im1)),im=1,nflavor),im1=1,nflavor)
# # # # ]
4594 : : end do ! itau
4595 : 0 : close(unt)
4596 : :
4597 : : end if ! myproc=0 and off_diag
4598 : :
4599 [ # # ]: 0 : if (myproc == 0) then
4600 : :
4601 [ # # # # ]: 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)
4602 : 0 : write(unt,'(5a)') "# Diagonal components of DLR fit of G(tau) in the CTQMC basis",ch10, &
4603 : 0 : & "# Columns are ordered this way:",ch10, &
4604 : 0 : & "# Imaginary Time (G_{ii},i=1,2*(2*l+1))"
4605 [ # # ]: 0 : do itau=1,ntau
4606 [ # # # # ]: 0 : write(unt,'(2x,393(e25.17e3,2x))') beta*dble(itau-1)/dble(ntau-1),(dble(gtau_dlr(itau,im,im)),im=1,nflavor)
4607 : : end do ! itau
4608 : 0 : close(unt)
4609 : :
4610 : : end if ! myproc
4611 : :
4612 [ # # ]: 0 : ABI_FREE(gl_dlr)
4613 [ # # ]: 0 : ABI_FREE(gl_dlr_re)
4614 [ # # ]: 0 : ABI_FREE(gl_dlr_im)
4615 [ # # ]: 0 : ABI_FREE(bdlr)
4616 [ # # ]: 0 : ABI_FREE(gtau_dlr)
4617 [ # # ]: 0 : ABI_FREE(moment_fit)
4618 : :
4619 : : end if ! leg_measure
4620 : :
4621 [ # # # # ]: 0 : if (myproc == 0 .and. paw_dmft%dmft_triqs_chiloc > 0) then
4622 [ # # ]: 0 : if (open_file(trim(paw_dmft%filapp)//"_LocalSusceptibility.dat",message,newunit=unt,status='unknown',form='formatted') /= 0) ABI_ERROR(message)
4623 [ # # ]: 0 : do itau=1,ntau
4624 : 0 : write(unt,*) beta * DBLE(itau-1) / DBLE(ntau), (chiloc_tmp(itau,1))
4625 : : end do
4626 : 0 : close(unt)
4627 : : end if
4628 : :
4629 [ # # ]: 0 : if (myproc == 0 .and. off_diag) then
4630 : :
4631 [ # # # # ]: 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)
4632 : 0 : write(unt,'(6a)') "# Off-diagonal components of binned G(tau) in the CTQMC basis",ch10, &
4633 : 0 : & "# Columns are ordered this way:",ch10, &
4634 : 0 : & "# Imaginary Time ((Re(G_{ij}) Im(G_{ij}),i=1,2*(2*l+1)),j=1,2*(2*l+1)) where the", &
4635 : 0 : & " leftmost index varies first"
4636 : :
4637 [ # # ]: 0 : do itau=1,ntau
4638 : 0 : write(unt,'(2x,393(e18.10e3,2x))') beta*dble(itau-1)/dble(ntau-1), &
4639 [ # # # # : 0 : & ((dble(gtau(itau,im,im1)),aimag(gtau(itau,im,im1)),im=1,nflavor),im1=1,nflavor)
# # # # ]
4640 : : end do ! itau
4641 : 0 : close(unt)
4642 : :
4643 : : end if ! myproc
4644 : :
4645 [ # # ]: 0 : if (myproc == 0) then
4646 : :
4647 [ # # # # ]: 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)
4648 : 0 : write(unt,'(5a)') "# Diagonal components of binned G(tau) in the CTQMC basis",ch10, &
4649 : 0 : & "# Columns are ordered this way:",ch10, &
4650 : 0 : & "# Imaginary Time (G_{ii},i=1,2*(2*l+1))"
4651 [ # # ]: 0 : do itau=1,ntau
4652 [ # # # # ]: 0 : write(unt,'(2x,393(e25.17e3,2x))') beta*dble(itau-1)/dble(ntau-1),(dble(gtau(itau,im,im)),im=1,nflavor)
4653 : : end do ! itau
4654 : 0 : close(unt)
4655 : :
4656 : : end if ! myproc
4657 : :
4658 [ # # # # ]: 0 : if (entropy .and. ilam == ntot) then
4659 : :
4660 : 0 : call compute_migdal_energy(emig(:),emig_tot,green,paw_dmft,hybmwdhyb,iatom=iatom)
4661 : 0 : green%ekin_imp = green%ekin_imp + two*emig_tot
4662 : :
4663 : : end if ! entropy
4664 : :
4665 : : end if ! ilam=ntot or debug
4666 : :
4667 [ # # # # : 0 : if (integral > 0 .and. ilam < ntot .and. entropy) then
# # ]
4668 : :
4669 : 0 : elam = dble(eu)
4670 : :
4671 [ # # ]: 0 : do isppol=1,nsppol
4672 [ # # ]: 0 : do im=1,tndim
4673 : 0 : iflavor = im + (isppol-1)*ndim
4674 : :
4675 [ # # # # ]: 0 : if (nsppol == 1 .and. nspinor == 1) then
4676 : 0 : occ_tmp = occ(iflavor) + occ(iflavor+ndim)
4677 : : else
4678 : 0 : occ_tmp = occ(iflavor)
4679 : : end if
4680 : 0 : elam = elam + dble(shift_mu*occ_tmp)
4681 : : end do ! im
4682 : : end do ! isppol
4683 : :
4684 : 0 : i = mod(ilam-1,ngauss) + 1
4685 : 0 : green%integral = green%integral + tweights(i)*elam*dx*half
4686 : 0 : elam_list(ilam) = elam
4687 : :
4688 : : end if ! integral and ilam<ntot and entropy
4689 : :
4690 [ # # # # ]: 0 : if (integral > 0 .and. ilam == ntot-1 .and. entropy) then
4691 : 0 : write(message,'(a,3(3x,2a),a,12x,a,6x,2a,8x,a)') ch10,repeat("=",39),ch10,"== Summary of thermodynamic integration", &
4692 : 0 : & ch10,repeat("=",39),ch10,ch10,"Lambda","<dH/dlambda>",ch10,repeat("-",29)
4693 : 0 : call wrtout(std_out,message,'COLL')
4694 [ # # ]: 0 : do i=1,ntot-1
4695 : 0 : write(tag_lambda,'(f14.4)') lam_list(i)
4696 : 0 : write(tag_elam,'(f14.4)') elam_list(i)
4697 : 0 : tag_lambda = adjustl(tag_lambda)
4698 : 0 : tag_elam = adjustl(tag_elam)
4699 : 0 : pad_lambda = (14-len_trim(tag_lambda)) / 2
4700 : 0 : pad_elam = (14-len_trim(tag_elam)) / 2
4701 [ # # # # : 0 : write(message,'(8x,2(3a,1x),a,8x,a)') repeat(" ",pad_lambda),trim(tag_lambda),repeat(" ",14-pad_lambda-len_trim(tag_lambda)), &
# # # # #
# ]
4702 [ # # # # : 0 : & repeat(" ",pad_elam),trim(tag_elam),repeat(" ",14-pad_elam-len_trim(tag_elam)),ch10,repeat("-",29)
# # ]
4703 : 0 : call wrtout(std_out,message,'COLL')
4704 : : end do ! i
4705 : 0 : write(message,'(a,3x,a,f10.4,a)') ch10,"--> Integral is: ",green%integral,ch10
4706 : 0 : call wrtout(std_out,message,'COLL')
4707 : : end if ! integral and ilam=ntot-1 and entropy
4708 : :
4709 : : end do ! ilam
4710 : :
4711 [ # # ]: 0 : ABI_FREE(flavor_tmp)
4712 [ # # ]: 0 : ABI_FREE(gtau)
4713 [ # # ]: 0 : ABI_FREE(levels_ctqmc)
4714 [ # # ]: 0 : ABI_SFREE(gl)
4715 [ # # ]: 0 : ABI_SFREE(moments_self_1)
4716 [ # # ]: 0 : ABI_SFREE(moments_self_2)
4717 [ # # ]: 0 : ABI_SFREE(occ)
4718 : :
4719 [ # # ]: 0 : if (paw_dmft%dmft_triqs_chiloc > 0) then
4720 [ # # ]: 0 : ABI_FREE(chiloc_tmp)
4721 : :
4722 [ # # ]: 0 : if (basis .eq. 4) then
4723 : : !do iatom=1,natom
4724 : 0 : lpawu = paw_dmft%lpawu(iatom)
4725 [ # # ]: 0 : if (lpawu == -1) cycle
4726 [ # # ]: 0 : ABI_FREE(magmom_tot(iatom)%value)
4727 : : !end do
4728 [ # # # # ]: 0 : ABI_FREE(magmom_tot)
4729 [ # # ]: 0 : ABI_FREE(magmom_array)
4730 [ # # # # : 0 : ABI_FREE(matlumag_tot)
# # # # ]
4731 : 0 : magmom_ptr = C_NULL_PTR
4732 : : end if
4733 : : end if
4734 : :
4735 : : end do ! iatom
4736 : :
4737 [ # # ]: 0 : ABI_FREE(elam_list)
4738 : 0 : ABI_FREE(lam_list)
4739 : :
4740 [ # # ]: 0 : ABI_SFREE(tweights)
4741 [ # # ]: 0 : ABI_SFREE(tpoints)
4742 : :
4743 : 0 : call occup_green_tau(green)
4744 : :
4745 : 0 : write(message,'(a,3x,a)') ch10,"== Print Occupation matrix in CTQMC basis"
4746 : 0 : call wrtout(std_out,message,"COLL")
4747 : 0 : call print_matlu(green%occup_tau%matlu(:),natom,1)
4748 : :
4749 [ # # ]: 0 : if (basis > 0) then
4750 : 0 : write(message,'(a,3x,a)') ch10,"== Rotating back to cubic basis"
4751 : 0 : call wrtout(std_out,message,"COLL")
4752 : : end if
4753 : :
4754 : : ! Build back Weiss field
4755 [ # # ]: 0 : do ifreq=1,nwlo
4756 [ # # ]: 0 : shift(:) = cmplx(zero,paw_dmft%omega_lo(ifreq),kind=dp)
4757 : 0 : call add_matlu(weiss%oper(ifreq)%matlu(:),energy_level%matlu(:),matlu_tmp(:),natom,1)
4758 : 0 : call copy_matlu(matlu_tmp(:),weiss%oper(ifreq)%matlu(:),natom)
4759 : 0 : call shift_matlu(weiss%oper(ifreq)%matlu(:),natom,shift(:))
4760 : 0 : call fac_matlu(weiss%oper(ifreq)%matlu(:),natom,-cone)
4761 : : end do ! ifreq
4762 : :
4763 [ # # ]: 0 : if (basis > 0) then
4764 [ # # ]: 0 : if (basis == 1 .or. basis == 2) then
4765 : 0 : call rotate_matlu(energy_level%matlu(:),eigvectmatlu(:),natom,0)
4766 [ # # ]: 0 : else if (basis == 4) then
4767 : 0 : call ylm2jmj_matlu(energy_level%matlu(:),natom,2,paw_dmft)
4768 : : end if ! basis /= 3
4769 : 0 : call slm2ylm_matlu(energy_level%matlu(:),natom,paw_dmft,2,0)
4770 [ # # ]: 0 : do i=2,weiss%nmoments-1
4771 [ # # ]: 0 : if (basis == 1 .or. basis == 2) then
4772 : 0 : call rotate_matlu(weiss%moments(i)%matlu(:),eigvectmatlu(:),natom,0)
4773 [ # # ]: 0 : else if (basis == 4) then
4774 : 0 : call ylm2jmj_matlu(weiss%moments(i)%matlu(:),natom,2,paw_dmft)
4775 : : end if
4776 : 0 : call slm2ylm_matlu(weiss%moments(i)%matlu(:),natom,paw_dmft,2,0)
4777 : : end do ! i
4778 [ # # ]: 0 : do i=1,green%nmoments
4779 [ # # ]: 0 : if (basis == 1 .or. basis == 2) then
4780 : 0 : call rotate_matlu(green%moments(i)%matlu(:),eigvectmatlu(:),natom,0)
4781 [ # # ]: 0 : else if (basis == 4) then
4782 : 0 : call ylm2jmj_matlu(green%moments(i)%matlu(:),natom,2,paw_dmft)
4783 : : end if
4784 : 0 : call slm2ylm_matlu(green%moments(i)%matlu(:),natom,paw_dmft,2,0)
4785 : : end do ! i
4786 [ # # ]: 0 : do ifreq=1,nwlo
4787 [ # # ]: 0 : if (green%distrib%procf(ifreq) /= myproc) cycle
4788 [ # # ]: 0 : if (basis == 1 .or. basis == 2) then
4789 : 0 : call rotate_matlu(weiss%oper(ifreq)%matlu(:),eigvectmatlu(:),natom,0)
4790 : 0 : call rotate_matlu(green%oper(ifreq)%matlu(:),eigvectmatlu(:),natom,0)
4791 [ # # ]: 0 : else if (basis == 4) then
4792 : 0 : call ylm2jmj_matlu(weiss%oper(ifreq)%matlu(:),natom,2,paw_dmft)
4793 : 0 : call ylm2jmj_matlu(green%oper(ifreq)%matlu(:),natom,2,paw_dmft)
4794 : : end if
4795 : 0 : call slm2ylm_matlu(weiss%oper(ifreq)%matlu(:),natom,paw_dmft,2,0)
4796 : 0 : call slm2ylm_matlu(green%oper(ifreq)%matlu(:),natom,paw_dmft,2,0)
4797 : : end do ! ifreq
4798 [ # # ]: 0 : if (basis == 1 .or. basis == 2) then
4799 : 0 : call rotate_matlu(green%occup_tau%matlu(:),eigvectmatlu(:),natom,0)
4800 [ # # ]: 0 : else if (basis == 4) then
4801 : 0 : call ylm2jmj_matlu(green%occup_tau%matlu(:),natom,2,paw_dmft)
4802 : : end if
4803 : 0 : call slm2ylm_matlu(green%occup_tau%matlu(:),natom,paw_dmft,2,0)
4804 : : end if! basis > 0
4805 : :
4806 : : ! Since we possibly neglected some off-diagonal elements and imaginary part,
4807 : : ! the levels and hybridization might not be symmetrized anymore
4808 : 0 : call sym_matlu(energy_level%matlu(:),paw_dmft)
4809 [ # # ]: 0 : do i=2,weiss%nmoments-1
4810 : 0 : call sym_matlu(weiss%moments(i)%matlu(:),paw_dmft)
4811 : : end do ! i
4812 [ # # ]: 0 : do i=1,green%nmoments
4813 : 0 : call sym_matlu(green%moments(i)%matlu(:),paw_dmft)
4814 : : end do ! i
4815 [ # # ]: 0 : do ifreq=1,nwlo
4816 [ # # ]: 0 : if (green%distrib%procf(ifreq) /= myproc) cycle
4817 : 0 : call sym_matlu(weiss%oper(ifreq)%matlu(:),paw_dmft)
4818 : 0 : call sym_matlu(green%oper(ifreq)%matlu(:),paw_dmft)
4819 : : end do ! ifreq
4820 : 0 : call copy_matlu(green%occup_tau%matlu(:),dmat_ctqmc(:),natom)
4821 : 0 : call sym_matlu(green%occup_tau%matlu(:),paw_dmft)
4822 : :
4823 : 0 : call diff_matlu("CTQMC occupations","Symmetrized CTQMC occupations",dmat_ctqmc(:),green%occup_tau%matlu(:),natom,0,tol4)
4824 : :
4825 : 0 : call gather_oper(weiss%oper(:),weiss%distrib,paw_dmft,opt_ksloc=2)
4826 : 0 : call gather_oper(green%oper(:),green%distrib,paw_dmft,opt_ksloc=2)
4827 : :
4828 : 0 : call compute_moments_loc(green,self_new,energy_level,weiss,1,opt_log=paw_dmft%dmft_triqs_entropy,shift_mu=shift_mu)
4829 : :
4830 [ # # ]: 0 : if (entropy .and. integral > 0) then
4831 : 0 : call compute_trace_log_loc(weiss,paw_dmft,green%fband_weiss,opt_inv=1)
4832 : : end if
4833 : :
4834 : 0 : call destroy_matlu(dmat_ctqmc(:),natom)
4835 : 0 : call destroy_matlu(eigvectmatlu(:),natom)
4836 : 0 : call destroy_matlu(ftau(:),natom)
4837 : 0 : call destroy_matlu(matlu_tmp(:),natom)
4838 : 0 : call destroy_matlu(udens_rot(:),natom)
4839 : :
4840 : 0 : call destroy_oper(energy_level)
4841 : :
4842 : 0 : call destroy_vee(paw_dmft,vee_rot(:))
4843 : :
4844 [ # # ]: 0 : ABI_FREE(block_list)
4845 [ # # # # : 0 : ABI_FREE(dmat_ctqmc)
# # # # ]
4846 [ # # # # : 0 : ABI_FREE(eigvectmatlu)
# # # # ]
4847 [ # # ]: 0 : ABI_FREE(flavor_list)
4848 [ # # # # : 0 : ABI_FREE(ftau)
# # # # ]
4849 [ # # ]: 0 : ABI_FREE(inner_list)
4850 [ # # # # : 0 : ABI_FREE(matlu_tmp)
# # # # ]
4851 [ # # ]: 0 : ABI_FREE(nblocks)
4852 [ # # ]: 0 : ABI_FREE(shift)
4853 [ # # ]: 0 : ABI_FREE(siz_block)
4854 [ # # # # : 0 : ABI_FREE(udens_rot)
# # # # ]
4855 [ # # # # : 0 : ABI_FREE(vee_rot)
# # # # ]
4856 : :
4857 [ # # ]: 0 : ABI_SFREE(adlr)
4858 [ # # ]: 0 : ABI_SFREE(adlr_iw)
4859 [ # # ]: 0 : ABI_SFREE(emig)
4860 [ # # ]: 0 : ABI_SFREE(wdlr)
4861 [ # # ]: 0 : ABI_SFREE(wdlr_beta)
4862 : :
4863 [ # # # # : 0 : if (entropy) then
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
4864 : 0 : call destroy_self(hybmwdhyb)
4865 : : end if
4866 : :
4867 : : contains
4868 : :
4869 : 0 : subroutine cubic_spline()
4870 : :
4871 : : !Arguments ------------------------------------
4872 : : !Local variables ------------------------------
4873 : 0 : complex(dp), allocatable :: y(:),yp(:)
4874 : : ! ************************************************************************
4875 : :
4876 [ # # # # : 0 : ABI_MALLOC(y,(nwlo))
# # # # #
# # # ]
4877 [ # # # # : 0 : ABI_MALLOC(yp,(nwlo))
# # # # ]
4878 : :
4879 [ # # ]: 0 : do iatom=1,natom
4880 : 0 : lpawu = paw_dmft%lpawu(iatom)
4881 [ # # ]: 0 : if (lpawu == -1) cycle
4882 : 0 : tndim = nspinor * (2*lpawu+1)
4883 [ # # ]: 0 : do isppol=1,nsppol
4884 [ # # ]: 0 : do im1=1,tndim
4885 [ # # ]: 0 : do im=1,tndim
4886 [ # # ]: 0 : do ifreq=1,nwlo
4887 : 0 : y(ifreq) = weiss%oper(ifreq)%matlu(iatom)%mat(im,im1,isppol)
4888 : : end do ! ifreq
4889 : : ! Boundary condition not-a-knot seems to get the best results
4890 : 0 : call spline2_complex(paw_dmft%omega_lo(:),y(:),nwlo,yp(:),czero,czero,3,3)
4891 [ # # ]: 0 : do ifreq=1,nwlo
4892 : : hybmwdhyb%oper(ifreq)%matlu(iatom)%mat(im,im1,isppol) = &
4893 : : & energy_level%matlu(iatom)%mat(im,im1,isppol) + y(ifreq) - &
4894 : 0 : & paw_dmft%omega_lo(ifreq)*yp(ifreq)
4895 : : end do ! ifreq
4896 : : end do ! im
4897 : : end do ! im1
4898 : : end do ! isppol
4899 : : end do ! iatom
4900 : :
4901 [ # # ]: 0 : ABI_FREE(y)
4902 [ # # ]: 0 : ABI_FREE(yp)
4903 : :
4904 : 0 : end subroutine cubic_spline
4905 : :
4906 : 0 : subroutine fit_dlr()
4907 : :
4908 : : !Arguments ------------------------------------
4909 : : !Local variables ------------------------------
4910 : : ! ************************************************************************
4911 : :
4912 [ # # ]: 0 : do isppol=1,nsppol
4913 [ # # ]: 0 : do im1=1,tndim
4914 : 0 : iflavor1 = im1 + (isppol-1)*ndim
4915 [ # # ]: 0 : do im=1,tndim
4916 : 0 : iflavor = im + (isppol-1)*ndim
4917 : :
4918 [ # # # # ]: 0 : ncon = merge(merge(4,3,iflavor==iflavor1),1,density_matrix)
4919 [ # # ]: 0 : nmoments = merge(3,1,density_matrix)
4920 [ # # # # ]: 0 : if (nsppol == 1 .and. nspinor == 1) gtau(:,iflavor,iflavor1) = &
4921 [ # # ]: 0 : & (gtau(:,iflavor,iflavor1)+gtau(:,iflavor+ndim,iflavor1+ndim)) * half
4922 : 0 : occ_tmp = green%oper_tau(1)%matlu(iatom)%mat(im,im1,isppol)
4923 : :
4924 [ # # ]: 0 : bdlr(:) = dble(gtau(:,iflavor,iflavor1))
4925 : :
4926 [ # # ]: 0 : do i=1,nmoments
4927 : 0 : moment_fit(i) = dble(green%moments(i)%matlu(iatom)%mat(im,im1,isppol))
4928 : : end do ! i
4929 : :
4930 : 0 : call slsqp_wrapper(ncon,ndlr,lsq_g,con_moments,jac_lsq_g,jac_con_moments,gl_dlr_re(:))
4931 : :
4932 [ # # ]: 0 : if (density_matrix) ncon = 3
4933 : :
4934 [ # # ]: 0 : bdlr(:) = aimag(gtau(:,iflavor,iflavor1))
4935 [ # # ]: 0 : do i=1,nmoments
4936 : 0 : moment_fit(i) = aimag(green%moments(i)%matlu(iatom)%mat(im,im1,isppol))
4937 : : end do ! i
4938 : :
4939 : 0 : call slsqp_wrapper(ncon,ndlr,lsq_g,con_moments,jac_lsq_g,jac_con_moments,gl_dlr_im(:))
4940 : :
4941 [ # # ]: 0 : gl_dlr(:,im,im1,isppol) = cmplx(gl_dlr_re(:),gl_dlr_im(:),kind=dp)
4942 : :
4943 : : ! Do not use DOT_PRODUCT
4944 [ # # ]: 0 : green%moments(1)%matlu(iatom)%mat(im,im1,isppol) = sum(gl_dlr(:,im,im1,isppol))
4945 [ # # ]: 0 : do i=2,green%nmoments
4946 [ # # ]: 0 : green%moments(i)%matlu(iatom)%mat(im,im1,isppol) = sum(gl_dlr(:,im,im1,isppol)*wdlr_beta(:,i-1))
4947 : : end do ! i
4948 : :
4949 [ # # ]: 0 : do itau=1,ntau
4950 : : ! Do not use DOT_PRODUCT
4951 [ # # ]: 0 : gtau_dlr(itau,iflavor,iflavor1) = sum(gl_dlr(:,im,im1,isppol)*adlr(:,itau))
4952 : : end do ! itau
4953 [ # # # # : 0 : if (nsppol == 1 .and. nspinor == 1) gtau_dlr(:,iflavor+ndim,iflavor1+ndim) = gtau_dlr(:,iflavor,iflavor1)
# # ]
4954 : :
4955 : : end do ! im
4956 : : end do ! im1
4957 : : end do ! isppol
4958 : :
4959 [ # # ]: 0 : do ifreq=1,nwlo
4960 [ # # ]: 0 : do isppol=1,nsppol
4961 [ # # ]: 0 : do im1=1,tndim
4962 [ # # ]: 0 : do im=1,tndim
4963 : : ! Do not use DOT_PRODUCT
4964 [ # # ]: 0 : green%oper(ifreq)%matlu(iatom)%mat(im,im1,isppol) = sum(gl_dlr(:,im,im1,isppol)*adlr_iw(:,ifreq))
4965 : : end do ! im
4966 : : end do ! im1
4967 : : end do ! isppol
4968 : : end do ! ifreq
4969 : :
4970 : 0 : end subroutine fit_dlr
4971 : :
4972 : 0 : subroutine diag_block(matlu)
4973 : :
4974 : : !Arguments ------------------------------------
4975 : : type(matlu_type), intent(inout) :: matlu(natom)
4976 : : !Local variables ------------------------------
4977 : : integer :: i,iatom,iblock,iflavor,iflavor1,im,im1
4978 : : integer :: info,is,j,lpawu,lwork,ndim,sizb,tndim
4979 : 0 : real(dp), allocatable :: eig(:),rwork(:)
4980 : 0 : complex(dp), allocatable :: mat_tmp(:,:),work(:)
4981 : : ! ************************************************************************
4982 : :
4983 : 0 : is = 1
4984 [ # # # # : 0 : ABI_MALLOC(eig,(nflavor_max))
# # # # #
# # # ]
4985 [ # # # # : 0 : ABI_MALLOC(mat_tmp,(nflavor_max,nflavor_max))
# # # # #
# # # # #
# # ]
4986 [ # # # # : 0 : ABI_MALLOC(rwork,(3*nflavor_max-2))
# # # # #
# # # #
# ]
4987 [ # # # # : 0 : ABI_MALLOC(work,(2*nflavor_max-1))
# # # # #
# # # #
# ]
4988 : :
4989 [ # # ]: 0 : do iatom=1,natom
4990 : 0 : lpawu = paw_dmft%lpawu(iatom)
4991 [ # # ]: 0 : if (lpawu == -1) cycle
4992 : 0 : ndim = 2*lpawu + 1
4993 : 0 : tndim = nspinor * ndim
4994 [ # # ]: 0 : do iblock=1,nblocks(iatom)
4995 : 0 : sizb = siz_block(iblock,iatom)
4996 : 0 : lwork = 2*sizb - 1
4997 [ # # ]: 0 : do j=1,sizb
4998 : 0 : iflavor1 = flavor_list(j,iblock,iatom) + 1
4999 : 0 : im1 = mod(iflavor1-1,tndim) + 1
5000 [ # # ]: 0 : if (nspinor == 1) then
5001 : 0 : is = (iflavor1-1)/ndim + 1
5002 [ # # ]: 0 : if (is > nsppol) exit
5003 : : end if
5004 [ # # ]: 0 : do i=1,sizb
5005 : 0 : iflavor = flavor_list(i,iblock,iatom) + 1
5006 : 0 : im = mod(iflavor-1,tndim) + 1
5007 : 0 : mat_tmp(i,j) = matlu(iatom)%mat(im,im1,is)
5008 : 0 : matlu(iatom)%mat(im,im1,is) = czero
5009 : : end do ! i
5010 : : end do ! j
5011 : :
5012 [ # # ]: 0 : if (is > nsppol) cycle
5013 : :
5014 : : call zheev('v','u',sizb,mat_tmp(:,1:sizb),nflavor_max,eig(1:sizb), &
5015 : 0 : & work(1:lwork),lwork,rwork(1:3*sizb-2),info)
5016 : :
5017 [ # # ]: 0 : do j=1,sizb
5018 : 0 : iflavor1 = flavor_list(j,iblock,iatom) + 1
5019 : 0 : im1 = mod(iflavor1-1,tndim) + 1
5020 : 0 : matlu(iatom)%mat(im1,im1,is) = cmplx(eig(j),zero,kind=dp)
5021 [ # # ]: 0 : do i=1,sizb
5022 : 0 : iflavor = flavor_list(i,iblock,iatom) + 1
5023 : 0 : im = mod(iflavor-1,tndim) + 1
5024 : 0 : eigvectmatlu(iatom)%mat(im,im1,is) = mat_tmp(i,j)
5025 : : end do ! i
5026 : : end do ! j
5027 : : end do ! iblock
5028 : :
5029 [ # # ]: 0 : if (pawprtvol >= 3) then
5030 : 0 : write(tag_at,'(i4)') iatom
5031 [ # # ]: 0 : do isppol=1,nsppol
5032 [ # # ]: 0 : write(message,'(4a,i1)') ch10," EIGENVECTORS for atom ",trim(adjustl(tag_at))
5033 [ # # ]: 0 : if (nspinor == 1) then
5034 : 0 : write(tag_block4,'(i1)') isppol
5035 [ # # ]: 0 : message = trim(message) // " and isppol " // tag_block4
5036 : : end if
5037 : 0 : call wrtout(std_out,message,'COLL')
5038 [ # # ]: 0 : do im=1,tndim
5039 : : write(message,'(12(1x,18(1x,"(",f9.3,",",f9.3,")")))') &
5040 [ # # # # ]: 0 : & (eigvectmatlu(iatom)%mat(im,im1,isppol),im1=1,tndim)
5041 : 0 : call wrtout(std_out,message,'COLL')
5042 : : end do ! im1
5043 : : end do ! isppol
5044 : : end if ! pawprtvol>=3
5045 : :
5046 : : end do ! iatom
5047 : :
5048 [ # # ]: 0 : ABI_FREE(eig)
5049 [ # # ]: 0 : ABI_FREE(mat_tmp)
5050 [ # # ]: 0 : ABI_FREE(rwork)
5051 [ # # ]: 0 : ABI_FREE(work)
5052 : :
5053 : 0 : end subroutine diag_block
5054 : :
5055 [ # # ]: 0 : subroutine lsq_g(gl,err)
5056 : :
5057 : : !Arguments ------------------------------------
5058 : : real(dp), intent(in) :: gl(:)
5059 : : real(dp), intent(out) :: err
5060 : : !Local variables ------------------------------
5061 : : ! ************************************************************************
5062 : :
5063 : 0 : err = zero
5064 [ # # ]: 0 : do itau=1,ntau
5065 [ # # ]: 0 : err = err + (dot_product(gl(:),adlr(:,itau))-bdlr(itau))**2
5066 : : end do
5067 : :
5068 : 0 : end subroutine lsq_g
5069 : :
5070 [ # # # # ]: 0 : subroutine jac_lsq_g(gl,jac)
5071 : :
5072 : : !Arguments ------------------------------------
5073 : : real(dp), intent(in) :: gl(:)
5074 : : real(dp), intent(inout) :: jac(:)
5075 : : !Local variables ------------------------------
5076 : : ! ************************************************************************
5077 : :
5078 [ # # ]: 0 : jac(:) = zero
5079 [ # # ]: 0 : do itau=1,ntau
5080 [ # # # # ]: 0 : jac(1:ndlr) = jac(1:ndlr) + (dot_product(gl(:),adlr(:,itau))-bdlr(itau))*adlr(:,itau)
5081 : : end do
5082 [ # # ]: 0 : jac = jac * two
5083 : :
5084 : 0 : end subroutine jac_lsq_g
5085 : :
5086 [ # # # # ]: 0 : subroutine con_moments(gl,con)
5087 : :
5088 : : !Arguments ------------------------------------
5089 : : real(dp), intent(in) :: gl(:)
5090 : : real(dp), intent(inout) :: con(:)
5091 : : !Local variables ------------------------------
5092 : : ! ************************************************************************
5093 : :
5094 [ # # ]: 0 : con(1) = sum(gl(:)) - moment_fit(1)
5095 [ # # ]: 0 : if (ncon > 1) then
5096 [ # # ]: 0 : con(2) = dot_product(gl(:),wdlr_beta(:,1)) - moment_fit(2)
5097 [ # # ]: 0 : con(3) = dot_product(gl(:),wdlr_beta(:,2)) - moment_fit(3)
5098 [ # # # # ]: 0 : if (ncon == 4) con(4) = dot_product(gl(:),adlr(:,1)) - dble(occ_tmp)
5099 : : end if ! ncon>1
5100 : :
5101 : 0 : end subroutine con_moments
5102 : :
5103 [ # # ]: 0 : subroutine jac_con_moments(gl,jac_con)
5104 : :
5105 : : !Arguments ------------------------------------
5106 : : real(dp), intent(in) :: gl(:)
5107 : : real(dp), intent(inout) :: jac_con(:,:)
5108 : : !Local variables ------------------------------
5109 : : ! ************************************************************************
5110 : :
5111 : : ABI_UNUSED(gl(:))
5112 : :
5113 [ # # ]: 0 : jac_con(1,1:ndlr) = one
5114 [ # # ]: 0 : if (ncon > 1) then
5115 [ # # ]: 0 : jac_con(2,1:ndlr) = wdlr_beta(:,1)
5116 [ # # ]: 0 : jac_con(3,1:ndlr) = wdlr_beta(:,2)
5117 [ # # # # ]: 0 : if (ncon == 4) jac_con(4,1:ndlr) = adlr(:,1)
5118 : : end if ! ncon>1
5119 [ # # ]: 0 : jac_con(:,ndlr+1) = zero ! not sure if this is necessary, but this is what they do in the SCIPY interface with SLSQP
5120 : :
5121 : 0 : end subroutine jac_con_moments
5122 : :
5123 : : end subroutine ctqmc_calltriqs_c
5124 : : !!***
5125 : :
5126 : : !!****f* m_forctqmc/k_it
5127 : : !! NAME
5128 : : !! k_it
5129 : : !!
5130 : : !! FUNCTION
5131 : : !! Computes the imaginary time kernel K(tau,omega).
5132 : : !!
5133 : : !! INPUTS
5134 : : !! tau = imaginary time divided by beta
5135 : : !! omega = real frequency multiplied by beta
5136 : : !!
5137 : : !! OUTPUT
5138 : : !!
5139 : : !! SOURCE
5140 : :
5141 : 0 : function k_it(tau,omega)
5142 : :
5143 : : !Arguments ------------------------------------
5144 : : real(dp), intent(in) :: tau, omega
5145 : : real(dp) :: k_it
5146 : : ! *********************************************************************
5147 : :
5148 [ # # ]: 0 : k_it = merge(-exp(-tau*omega)/(one+exp(-omega)),-exp((one-tau)*omega)/(one+exp(omega)),omega>=0)
5149 : :
5150 : 0 : end function k_it
5151 : : !!***
5152 : :
5153 : : !!****f* m_forctqmc/k_iw
5154 : : !! NAME
5155 : : !! k_iw
5156 : : !!
5157 : : !! FUNCTION
5158 : : !! Computes the imaginary frequency kernel K(iom,omega)
5159 : : !!
5160 : : !! INPUTS
5161 : : !! iom = imaginary part of the Matsubara frequency
5162 : : !! omega = real frequency
5163 : : !!
5164 : : !! OUTPUT
5165 : : !!
5166 : : !! SOURCE
5167 : :
5168 : 0 : function k_iw(iom,omega)
5169 : :
5170 : : !Arguments ------------------------------------
5171 : : real(dp), intent(in) :: iom,omega
5172 : : complex(dp) :: k_iw
5173 : : ! *********************************************************************
5174 : :
5175 : 0 : k_iw = cone / (cmplx(zero,iom,kind=dp)-omega)
5176 : :
5177 : : end function k_iw
5178 : : !!***
5179 : :
5180 : : !!****f* m_forctqmc/slsqp_wrapper
5181 : : !! NAME
5182 : : !! slsqp_wrapper
5183 : : !!
5184 : : !! FUNCTION
5185 : : !! Optimizes a function with several variables
5186 : : !! under several constraints, using the SLSQP algorithm.
5187 : : !!
5188 : : !! INPUTS
5189 : : !! m = number of constraints
5190 : : !! n = number of variables
5191 : : !! fun = function to optimize
5192 : : !! con = constraints
5193 : : !! jac = jacobian of the function
5194 : : !! jac_con = jacobian of the constraints
5195 : : !!
5196 : : !! OUTPUT
5197 : : !! x(n) = minimizer
5198 : : !!
5199 : : !! SOURCE
5200 : :
5201 : 0 : subroutine slsqp_wrapper(m,n,fun,con,jac,jac_con,x)
5202 : :
5203 : : use m_slsqp, only : slsqp
5204 : :
5205 : : !Arguments ------------------------------------
5206 : : integer, intent(in) :: m,n
5207 : : real(dp), intent(inout) :: x(n)
5208 : :
5209 : : interface
5210 : :
5211 : : subroutine fun(x,f)
5212 : : use defs_basis
5213 : : real(dp), intent(in) :: x(:)
5214 : : real(dp), intent(out) :: f
5215 : : end subroutine fun
5216 : :
5217 : : subroutine con(x,c)
5218 : : use defs_basis
5219 : : real(dp), intent(in) :: x(:)
5220 : : real(dp), intent(inout) :: c(:)
5221 : : end subroutine con
5222 : :
5223 : : subroutine jac(x,g)
5224 : : use defs_basis
5225 : : real(dp), intent(in) :: x(:)
5226 : : real(dp), intent(inout) :: g(:)
5227 : : end subroutine jac
5228 : :
5229 : : subroutine jac_con(x,a)
5230 : : use defs_basis
5231 : : real(dp), intent(in) :: x(:)
5232 : : real(dp), intent(inout) :: a(:,:)
5233 : : end subroutine jac_con
5234 : :
5235 : : end interface
5236 : : !Local variables ------------------------------
5237 : : integer :: i,iexact,incons,ireset,iter,itermx,l_jw,l_w,la
5238 : : integer :: line,maxiter,meq,mineq,mode,n1,n2,n3
5239 : : real(dp) :: f,acc,alpha,f0,gs,h1,h2,h3,h4,t,t0,tol
5240 : 0 : real(dp) :: c(max(m,1)),g(n+1),xl(n),xu(n)
5241 : 0 : real(dp) :: a(max(m,1),n+1)
5242 : 0 : real(dp), allocatable :: w(:)
5243 : 0 : integer, allocatable :: jw(:)
5244 : : ! ************************************************************************
5245 : :
5246 : 0 : maxiter = 10000
5247 : 0 : meq = m ! all constraints are equality constraints here
5248 : 0 : la = max(m,1)
5249 [ # # # # : 0 : x(:) = zero ; xl(:) = zero ; xu(:) = zero
# # ]
5250 [ # # ]: 0 : xl(:) = xl(:) / zero ! set lower and upper bounds to NaN (very important, this is how slsqp recognizes that no bounds should be applied)
5251 [ # # ]: 0 : xu(:) = xu(:) / zero
5252 : :
5253 : 0 : call fun(x(:),f)
5254 : 0 : call con(x(:),c(:))
5255 : 0 : call jac(x(:),g(:))
5256 : 0 : call jac_con(x(:),a(:,:))
5257 : 0 : acc = tol8 ! best not to overconverge the result, in order to avoid overfitting
5258 : 0 : iter = maxiter
5259 : 0 : mode = 0
5260 : : n1 = n + 1
5261 : 0 : mineq = m - meq + 2*n1
5262 : : l_w = (3*n1+m)*(n1+1) + (n1-meq+1)*(mineq+2) + 2*mineq & ! as recommended
5263 : 0 : & +(n1+mineq)*(n1-meq) + 2*meq + n1 + n1*n/2 + 2*m + 3*n + 3*n1 + 1
5264 [ # # # # : 0 : ABI_MALLOC(w,(l_w))
# # # # #
# # # ]
5265 [ # # ]: 0 : w = zero
5266 : 0 : l_jw = mineq ! as recommended
5267 [ # # # # : 0 : ABI_MALLOC(jw,(l_jw))
# # # # #
# # # ]
5268 [ # # ]: 0 : jw = 0 ; alpha = zero ; f0 = zero
5269 : 0 : gs = zero ; h1 = zero ; h2 = zero
5270 : 0 : h3 = zero ; h4 = zero ; t = zero
5271 : 0 : t0 = zero ; tol = zero ; iexact = 0
5272 : 0 : incons = 0 ; ireset = 0 ; itermx = 0
5273 : 0 : line = 0 ; n1 = 0 ; n2 = 0 ; n3 = 0
5274 : :
5275 [ # # ]: 0 : do i=1,maxiter
5276 : :
5277 : : call slsqp(m,meq,la,n,x(:),xl(:),xu(:),f,c(:),g(:),a(:,:),acc,iter,mode,w(:),l_w, &
5278 : : & jw(:),l_jw,alpha,f0,gs,h1,h2,h3,h4,t,t0,tol,iexact,incons,ireset,itermx, &
5279 : 0 : & line,n1,n2,n3)
5280 : :
5281 [ # # ]: 0 : if (abs(mode) /= 1) exit
5282 [ # # ]: 0 : if (mode == -1) then
5283 : 0 : call jac(x(:),g(:))
5284 : 0 : call jac_con(x(:),a(:,:))
5285 : : end if
5286 [ # # ]: 0 : if (mode == 1) then
5287 : 0 : call fun(x(:),f)
5288 : 0 : call con(x(:),c(:))
5289 : : end if
5290 : : end do ! i
5291 : :
5292 [ # # ]: 0 : if (mode /= 0) ABI_ERROR("Error in the optimization procedure during the DLR fit")
5293 : :
5294 [ # # ]: 0 : ABI_FREE(w)
5295 [ # # ]: 0 : ABI_FREE(jw)
5296 : :
5297 : 0 : end subroutine slsqp_wrapper
5298 : : !!***
5299 : :
5300 : : !!****f* m_forctqmc/fourier_inv
5301 : : !! NAME
5302 : : !! fourier_inv
5303 : : !!
5304 : : !! FUNCTION
5305 : : !! Computes the inverse Fourier transform of a frequency-dependent operator,
5306 : : !! using analytical formulas for the asymptotic behavior. It is assumed the
5307 : : !! asymptotic behavior is moments(1)/(iw_n) + moments(2)/(iwn)**2 + ...,
5308 : : !! so if you want to use this routine for an operator with a 0th order moment,
5309 : : !! you need to subtract it before calling this routine.
5310 : : !!
5311 : : !! INPUTS
5312 : : !! paw_dmft <type(paw_dmft_type)>= DMFT data structure
5313 : : !! nmoments = number of moments
5314 : : !! ntau = number of (equidistant) imaginary time points on [0,beta]
5315 : : !! oper_freq = operator for each Matsubara frequency
5316 : : !! moments = high-frequency moments of the operator
5317 : : !!
5318 : : !! OUTPUT
5319 : : !! matlu_tau(2*(2*lpawu+1),2*(2*lpawu+1),ntau) = operator for each tau point
5320 : : !!
5321 : : !! SIDE EFFECTS
5322 : : !!
5323 : : !! NOTES
5324 : : !!
5325 : : !! SOURCE
5326 : :
5327 : 0 : subroutine fourier_inv(paw_dmft,nmoments,ntau,matlu_tau,oper_freq,moments)
5328 : :
5329 : : !Arguments ------------------------------------
5330 : : integer, intent(in) :: nmoments,ntau
5331 : : type(paw_dmft_type), intent(in) :: paw_dmft
5332 : : type(oper_type), intent(in) :: oper_freq(paw_dmft%dmft_nwlo),moments(nmoments)
5333 : : type(matlu_type), intent(inout) :: matlu_tau(paw_dmft%natom)
5334 : : !Local variables ------------------------------
5335 : : integer :: i,iatom,ibuf,ibuf_tau,ierr,ifreq,im1,isppol
5336 : : integer :: itau,itaub,itauf,lpawu,myproc,natom,ndim,nproc
5337 : : integer :: nspinor,nsppol,ntau_proc,nwlo,ratio,residu,siz_buf,tndim
5338 : : real(dp) :: beta,omegatau,tau
5339 : : complex(dp) :: fac
5340 : 0 : integer, allocatable :: displs(:),recvcounts(:)
5341 : 0 : complex(dp), allocatable :: buffer(:),buffer_tot(:),omega_fac(:)
5342 : : ! ************************************************************************
5343 : :
5344 : 0 : beta = one / paw_dmft%temp
5345 : 0 : myproc = paw_dmft%myproc
5346 : 0 : natom = paw_dmft%natom
5347 : 0 : nspinor = paw_dmft%nspinor
5348 : 0 : nsppol = paw_dmft%nsppol
5349 : 0 : nproc = paw_dmft%nproc
5350 : 0 : nwlo = paw_dmft%dmft_nwlo
5351 : :
5352 : 0 : call zero_matlu(matlu_tau(:),natom)
5353 : :
5354 [ # # # # : 0 : ABI_MALLOC(displs,(nproc))
# # # # #
# # # ]
5355 [ # # # # : 0 : ABI_MALLOC(recvcounts,(nproc))
# # # # ]
5356 : :
5357 : 0 : ratio = ntau / nproc
5358 : 0 : residu = ntau - ratio*nproc
5359 : :
5360 : 0 : itau = 1
5361 [ # # ]: 0 : do i=0,nproc-1
5362 [ # # ]: 0 : ntau_proc = merge(ratio+1,ratio,i<residu)
5363 : 0 : recvcounts(i+1) = ntau_proc
5364 [ # # ]: 0 : if (myproc == i) itaub = itau
5365 : 0 : itau = itau + ntau_proc
5366 : : end do ! i
5367 : 0 : itauf = itaub + recvcounts(myproc+1) - 1
5368 : :
5369 : 0 : siz_buf = 0
5370 [ # # ]: 0 : do iatom=1,natom
5371 : 0 : lpawu = paw_dmft%lpawu(iatom)
5372 [ # # ]: 0 : if (lpawu == -1) cycle
5373 : 0 : siz_buf = siz_buf + (2*lpawu+1)**2
5374 : : end do ! iatom
5375 : :
5376 : 0 : siz_buf = siz_buf * (nspinor**2) * nsppol
5377 : :
5378 [ # # ]: 0 : recvcounts(:) = recvcounts(:) * siz_buf
5379 : :
5380 : 0 : displs(1) = 0
5381 [ # # ]: 0 : do i=2,nproc
5382 : 0 : displs(i) = displs(i-1) + recvcounts(i-1)
5383 : : end do ! i
5384 : :
5385 [ # # # # : 0 : ABI_MALLOC(buffer,(recvcounts(myproc+1)))
# # # # #
# # # ]
5386 [ # # # # : 0 : ABI_MALLOC(buffer_tot,(recvcounts(nproc)+displs(nproc)))
# # # # #
# # # ]
5387 [ # # # # : 0 : ABI_MALLOC(omega_fac,(nmoments))
# # # # #
# # # ]
5388 : :
5389 [ # # ]: 0 : buffer(:) = czero
5390 : :
5391 : : ibuf_tau = 0
5392 [ # # ]: 0 : do itau=itaub,itauf
5393 : :
5394 : 0 : tau = dble(itau-1) * beta / dble(ntau-1)
5395 [ # # ]: 0 : omega_fac(:) = czero
5396 : :
5397 [ # # ]: 0 : do ifreq=nwlo,1,-1 ! NEVER change this summation order and DON'T replace by the intrinsic SUM
5398 : 0 : omegatau = mod(paw_dmft%omega_lo(ifreq)*tau,two_pi)
5399 : 0 : fac = two * paw_dmft%temp * exp(-j_dpc*omegatau)
5400 [ # # ]: 0 : do i=1,nmoments
5401 : 0 : omega_fac(i) = omega_fac(i) - fac/(j_dpc*paw_dmft%omega_lo(ifreq))**i
5402 : : end do
5403 : : ibuf = 0
5404 [ # # ]: 0 : do iatom=1,natom
5405 : 0 : lpawu = paw_dmft%lpawu(iatom)
5406 [ # # ]: 0 : if (lpawu == -1) cycle
5407 : 0 : tndim = nspinor * (2*lpawu+1)
5408 [ # # ]: 0 : do isppol=1,nsppol
5409 [ # # ]: 0 : do im1=1,tndim
5410 : : buffer(ibuf_tau+ibuf+1:ibuf_tau+ibuf+tndim) = buffer(ibuf_tau+ibuf+1:ibuf_tau+ibuf+tndim) + &
5411 [ # # ]: 0 : fac*oper_freq(ifreq)%matlu(iatom)%mat(:,im1,isppol)
5412 : 0 : ibuf = ibuf + tndim
5413 : : end do ! im
5414 : : end do ! isppol
5415 : : end do ! iatom
5416 : : end do ! ifreq
5417 : :
5418 : 0 : omega_fac(1) = omega_fac(1) - half
5419 : 0 : omega_fac(2) = omega_fac(2) + tau/two - beta/four
5420 : 0 : omega_fac(3) = omega_fac(3) - (tau**2)/four + tau*beta/four
5421 : :
5422 [ # # ]: 0 : do i=1,nmoments
5423 : : ibuf = 0
5424 [ # # ]: 0 : do iatom=1,natom
5425 : 0 : lpawu = paw_dmft%lpawu(iatom)
5426 [ # # ]: 0 : if (lpawu == -1) cycle
5427 : 0 : tndim = nspinor * (2*lpawu+1)
5428 [ # # ]: 0 : do isppol=1,nsppol
5429 [ # # ]: 0 : do im1=1,tndim
5430 : : buffer(ibuf_tau+ibuf+1:ibuf_tau+ibuf+tndim) = buffer(ibuf_tau+ibuf+1:ibuf_tau+ibuf+tndim) + &
5431 [ # # ]: 0 : & moments(i)%matlu(iatom)%mat(:,im1,isppol)*omega_fac(i)
5432 : 0 : ibuf = ibuf + tndim
5433 : : end do ! im1
5434 : : end do ! isppol
5435 : : end do ! iatom
5436 : : end do ! i
5437 : :
5438 : 0 : ibuf_tau = ibuf_tau + siz_buf
5439 : :
5440 : : end do ! itau
5441 : :
5442 [ # # ]: 0 : ABI_FREE(omega_fac)
5443 : :
5444 : 0 : call xmpi_allgatherv(buffer(:),recvcounts(myproc+1),buffer_tot(:),recvcounts(:),displs(:),paw_dmft%spacecomm,ierr)
5445 : :
5446 : 0 : ABI_FREE(displs)
5447 : 0 : ABI_FREE(recvcounts)
5448 : :
5449 : 0 : ibuf = 0
5450 [ # # ]: 0 : do itau=1,ntau
5451 [ # # ]: 0 : do iatom=1,natom
5452 : 0 : lpawu = paw_dmft%lpawu(iatom)
5453 [ # # ]: 0 : if (lpawu == -1) cycle
5454 : 0 : ndim = 2*lpawu + 1
5455 : 0 : tndim = ndim * nspinor
5456 [ # # ]: 0 : do isppol=1,nsppol
5457 [ # # ]: 0 : do im1=1,tndim
5458 [ # # ]: 0 : matlu_tau(iatom)%mat(1+(isppol-1)*ndim:tndim+(isppol-1)*ndim,im1+(isppol-1)*ndim,itau) = buffer_tot(ibuf+1:ibuf+tndim)
5459 : 0 : ibuf = ibuf + tndim
5460 : : end do ! im1
5461 : : end do ! isppol
5462 [ # # ]: 0 : if (nsppol == 1 .and. nspinor == 1) matlu_tau(iatom)%mat(ndim+1:2*ndim,ndim+1:2*ndim,itau) = &
5463 [ # # # # ]: 0 : & matlu_tau(iatom)%mat(1:ndim,1:ndim,itau)
5464 : 0 : ndim = 2 * ndim
5465 : : matlu_tau(iatom)%mat(1:ndim,1:ndim,itau) = (matlu_tau(iatom)%mat(1:ndim,1:ndim,itau)+ &
5466 [ # # # # : 0 : & conjg(transpose(matlu_tau(iatom)%mat(1:ndim,1:ndim,itau)))) * half
# # # # #
# ]
5467 : : end do ! iatom
5468 : : end do ! itau
5469 : :
5470 [ # # ]: 0 : ABI_FREE(buffer)
5471 [ # # ]: 0 : ABI_FREE(buffer_tot)
5472 : :
5473 : 0 : end subroutine fourier_inv
5474 : : !!***
5475 : :
5476 : : !!****f* m_forctqmc/find_block_structure
5477 : : !! NAME
5478 : : !! find_block_structure
5479 : : !!
5480 : : !! FUNCTION
5481 : : !! Find the most optimal block structure of a matlu
5482 : : !!
5483 : : !! INPUTS
5484 : : !! paw_dmft <type(paw_dmft_type)>= DMFT data structure
5485 : : !! matlu <type(oper_type)>= matrix for which the block structure is to be found
5486 : : !! natom = number of atoms
5487 : : !! nflavor_max = max number of orbitals
5488 : : !! hyb <type(green_type)>= hybridization ; if present, the block structure will
5489 : : !! match both matlu and hyb
5490 : : !!
5491 : : !! OUTPUT
5492 : : !! block_list(nflavor,natom) = block index for each flavor and atom
5493 : : !! inner_list(nflavor,natom) = inner block index for each flavor and atom
5494 : : !! flavor_list(nflavor,nflavor,natom) = flavor for each block and inner indexes
5495 : : !! siz_block(nflavor,natom) = block size for each block and atom
5496 : : !! nblocks = number of blocks for each atom
5497 : : !!
5498 : : !! SIDE EFFECTS
5499 : : !!
5500 : : !! NOTES
5501 : : !!
5502 : : !! SOURCE
5503 : :
5504 : 0 : subroutine find_block_structure(paw_dmft,block_list,inner_list,flavor_list, &
5505 : 0 : & siz_block,nblocks,matlu,natom,nflavor_max,hyb)
5506 : :
5507 : : !Arguments ------------------------------------
5508 : : integer, intent(in) :: natom,nflavor_max
5509 : : integer, intent(inout) :: block_list(nflavor_max,natom),inner_list(nflavor_max,natom)
5510 : : integer, intent(inout) :: flavor_list(nflavor_max,nflavor_max,natom)
5511 : : integer, intent(inout) :: siz_block(nflavor_max,natom),nblocks(natom)
5512 : : type(paw_dmft_type), intent(in) :: paw_dmft
5513 : : type(green_type), optional, intent(inout) :: hyb
5514 : : type(matlu_type), intent(inout) :: matlu(natom)
5515 : : !Local variables ------------------------------
5516 : : integer :: i,iatom,iblock,iblock1,iblock2,iflavor,ifreq,lpawu
5517 : : integer :: nflavor,nspinor,nsppol,nwlo
5518 : 0 : integer, allocatable :: found_block(:),label_block(:)
5519 : : ! ************************************************************************
5520 : :
5521 : 0 : nspinor = paw_dmft%nspinor
5522 : 0 : nsppol = paw_dmft%nsppol
5523 : 0 : nwlo = paw_dmft%dmft_nwlo
5524 : :
5525 [ # # ]: 0 : do iflavor=1,nflavor_max
5526 [ # # ]: 0 : block_list(iflavor,:) = iflavor - 1
5527 : : end do ! iflavor
5528 : :
5529 [ # # # # : 0 : ABI_MALLOC(found_block,(nflavor_max))
# # # # #
# # # ]
5530 [ # # # # : 0 : ABI_MALLOC(label_block,(nflavor_max))
# # # # ]
5531 : :
5532 : 0 : call find_block_structure_mat(matlu(:))
5533 : :
5534 [ # # ]: 0 : if (present(hyb)) then
5535 [ # # ]: 0 : do i=2,hyb%nmoments-1
5536 : 0 : call find_block_structure_mat(hyb%moments(i)%matlu(:))
5537 : : end do ! i
5538 : :
5539 [ # # ]: 0 : do ifreq=1,nwlo
5540 : 0 : call find_block_structure_mat(hyb%oper(ifreq)%matlu(:))
5541 : : end do ! ifreq
5542 : : end if ! present(hyb)
5543 : :
5544 [ # # # # ]: 0 : siz_block(:,:) = 0
5545 : :
5546 : : ! Rename the blocks from 0 to nblocks-1 and build lists
5547 [ # # ]: 0 : do iatom=1,natom
5548 : 0 : lpawu = paw_dmft%lpawu(iatom)
5549 [ # # ]: 0 : if (lpawu == -1) cycle
5550 : 0 : nflavor = 2 * (2*lpawu+1)
5551 : :
5552 [ # # ]: 0 : found_block(:) = 0
5553 : :
5554 : 0 : iblock1 = 0 ! number of blocks
5555 [ # # ]: 0 : do iflavor=1,nflavor
5556 : 0 : iblock = block_list(iflavor,iatom)
5557 [ # # ]: 0 : if (found_block(iblock+1) == 0) then
5558 : 0 : label_block(iblock+1) = iblock1
5559 : 0 : iblock1 = iblock1 + 1 ! next block index
5560 : : end if
5561 : 0 : iblock2 = label_block(iblock+1) ! new block index
5562 : 0 : block_list(iflavor,iatom) = iblock2
5563 : 0 : inner_list(iflavor,iatom) = found_block(iblock+1)
5564 : 0 : found_block(iblock+1) = found_block(iblock+1) + 1
5565 : 0 : siz_block(iblock2+1,iatom) = siz_block(iblock2+1,iatom) + 1
5566 : 0 : flavor_list(found_block(iblock+1),iblock2+1,iatom) = iflavor - 1
5567 : : end do ! iflavor
5568 : 0 : nblocks(iatom) = iblock1
5569 : : end do ! iatom
5570 : :
5571 [ # # ]: 0 : ABI_FREE(found_block)
5572 [ # # ]: 0 : ABI_FREE(label_block)
5573 : :
5574 : : ! Set to 0 the off-diagonal elements that are not kept in a block
5575 : 0 : call apply_block_structure_mat(matlu(:))
5576 : :
5577 [ # # ]: 0 : if (present(hyb)) then
5578 : :
5579 [ # # ]: 0 : do i=2,hyb%nmoments-1
5580 : 0 : call apply_block_structure_mat(hyb%moments(i)%matlu(:))
5581 : : end do ! i
5582 : :
5583 [ # # ]: 0 : do ifreq=1,nwlo
5584 : 0 : call apply_block_structure_mat(hyb%oper(ifreq)%matlu(:))
5585 : : end do ! ifreq
5586 : :
5587 : : end if ! present(hyb)
5588 : :
5589 : : contains
5590 : :
5591 : 0 : subroutine find_block_structure_mat(mat)
5592 : :
5593 : : !Arguments ------------------------------------
5594 : : type(matlu_type), intent(inout) :: mat(natom)
5595 : : !Local variables ------------------------------
5596 : : integer :: i,iflavor1,im,im1,isppol,ndim,tndim
5597 : : ! ************************************************************************
5598 : :
5599 [ # # ]: 0 : do iatom=1,natom
5600 : 0 : lpawu = paw_dmft%lpawu(iatom)
5601 [ # # ]: 0 : if (lpawu == -1) cycle
5602 : 0 : ndim = 2*lpawu + 1
5603 : 0 : tndim = ndim * nspinor
5604 : 0 : nflavor = 2 * ndim
5605 [ # # ]: 0 : do isppol=1,nsppol
5606 [ # # ]: 0 : do im1=1,tndim
5607 : 0 : iflavor1 = im1 + (isppol-1)*ndim
5608 : 0 : iblock1 = block_list(iflavor1,iatom)
5609 [ # # ]: 0 : do im=1,tndim
5610 : 0 : iflavor = im + (isppol-1)*ndim
5611 : 0 : iblock = block_list(iflavor,iatom)
5612 [ # # ]: 0 : if (iblock == iblock1) cycle
5613 [ # # ]: 0 : if (abs(mat(iatom)%mat(im,im1,isppol)) > paw_dmft%dmft_triqs_tol_block) then ! Merge the two blocks
5614 [ # # ]: 0 : do i=1,nflavor
5615 [ # # ]: 0 : if (block_list(i,iatom) == iblock) block_list(i,iatom) = iblock1
5616 : : end do ! i
5617 : : end if
5618 : : end do ! im
5619 : : end do ! im1
5620 : : end do ! isppol
5621 [ # # # # : 0 : if (nsppol == 1 .and. nspinor == 1) block_list(ndim+1:nflavor,iatom) = block_list(1:ndim,iatom) + ndim
# # ]
5622 : : end do ! iatom
5623 : :
5624 : 0 : end subroutine find_block_structure_mat
5625 : :
5626 : 0 : subroutine apply_block_structure_mat(mat)
5627 : :
5628 : : !Arguments ------------------------------------
5629 : : type(matlu_type), intent(inout) :: mat(natom)
5630 : : !Local variables ------------------------------
5631 : : integer :: iflavor1,im,im1,isppol,ndim,tndim
5632 : : ! ************************************************************************
5633 : :
5634 [ # # ]: 0 : do iatom=1,natom
5635 : 0 : lpawu = paw_dmft%lpawu(iatom)
5636 [ # # ]: 0 : if (lpawu == -1) cycle
5637 : 0 : ndim = 2*lpawu + 1
5638 : 0 : tndim = nspinor * ndim
5639 [ # # ]: 0 : do isppol=1,nsppol
5640 [ # # ]: 0 : do im1=1,tndim
5641 : 0 : iflavor1 = im1 + (isppol-1)*ndim
5642 : 0 : iblock1 = block_list(iflavor1,iatom)
5643 [ # # ]: 0 : do im=1,tndim
5644 : 0 : iflavor = im + (isppol-1)*ndim
5645 : 0 : iblock = block_list(iflavor,iatom)
5646 [ # # ]: 0 : if (iblock == iblock1) cycle
5647 : 0 : mat(iatom)%mat(im,im1,isppol) = czero
5648 : : end do ! im
5649 : : end do ! im1
5650 : : end do ! isppol
5651 : : end do ! iatom
5652 : :
5653 : 0 : end subroutine apply_block_structure_mat
5654 : :
5655 : : end subroutine find_block_structure
5656 : : !!***
5657 : :
5658 [ # # ]: 0 : END MODULE m_forctqmc
5659 : : !!***
|
