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