Line data Source code
1 :
2 : #if defined HAVE_CONFIG_H
3 : #include "config.h"
4 : #endif
5 : !!****m* ABINIT/m_ImpurityOperator
6 : !! NAME
7 : !! m_ImpurityOperator
8 : !!
9 : !! FUNCTION
10 : !! manage all related to Impurity
11 : !!
12 : !! COPYRIGHT
13 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
14 : !! This file is distributed under the terms of the
15 : !! GNU General Public License, see ~abinit/COPYING
16 : !! or http://www.gnu.org/copyleft/gpl.txt .
17 : !!
18 : !! NOTES
19 : !!
20 : !! SOURCE
21 :
22 : #include "defs.h"
23 : MODULE m_ImpurityOperator
24 : USE m_ListCdagC
25 : USE m_Global
26 : IMPLICIT NONE
27 :
28 : !!***
29 :
30 : PRIVATE
31 :
32 : !!****t* m_ImpurityOperator/ImpurityOperator
33 : !! NAME
34 : !! ImpurityOperator
35 : !!
36 : !! FUNCTION
37 : !! This structured datatype contains the necessary data
38 : !!
39 : !! COPYRIGHT
40 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
41 : !! This file is distributed under the terms of the
42 : !! GNU General Public License, see ~abinit/COPYING
43 : !! or http://www.gnu.org/copyleft/gpl.txt .
44 : !!
45 : !! SOURCE
46 :
47 : TYPE, PUBLIC :: ImpurityOperator
48 : LOGICAL _PRIVATE :: doCheck = .FALSE.
49 : INTEGER _PRIVATE :: flavors
50 : ! Number of flavors
51 : INTEGER :: activeFlavor
52 : ! Flavor considered e.g when a segment is added
53 :
54 :
55 : DOUBLE PRECISION _PRIVATE :: beta
56 : ! Inverse of temperature.
57 :
58 : DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: mat_U
59 : ! for iflavor1 and iflavor2, mat_U(iflavor1,iflavor2) is the
60 : ! coulomb interaction between iflavor1 and iflavor2.
61 :
62 : DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) _PRIVATE :: overlaps ! total overlaps
63 : ! for iflavor1 and iflavor2 overlaps(iflavor1,iflavor2) is the total
64 : ! overlap between segments of iflavor1 and segments of iflavor2.
65 :
66 : DOUBLE PRECISION, ALLOCATABLE, DIMENSION(: ) _PRIVATE :: updates ! new_(anti)seg
67 : ! For a given flavor (activeflavor), gives for each other flavors, the
68 : ! supplementary overlaps, called updates(otherflavor).
69 :
70 : TYPE(ListCdagC) _PRIVATE :: list_swap
71 : TYPE(ListCdagC) , ALLOCATABLE, DIMENSION(: ) :: particles
72 : ! for each flavor, particles(iflavor)%list(2,maxnbofsegment)
73 : ! gives the beginning and end of each segment.
74 :
75 : DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: Magmommat_orb
76 : ! for iflavor1 and iflavor2, Magmommat(iflavor1,iflavor2) is the
77 : ! orbital magnetic moments
78 :
79 : DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: Magmommat_spin
80 : ! for iflavor1 and iflavor2, Magmommat(iflavor1,iflavor2) is the
81 : ! spin magnetic moments
82 :
83 : DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: Magmommat_tot
84 : ! for iflavor1 and iflavor2, Magmommat(iflavor1,iflavor2) is the
85 : ! total magnetic moments
86 :
87 : DOUBLE PRECISION _PRIVATE :: checkNumber
88 : DOUBLE PRECISION _PRIVATE :: tolerance
89 : DOUBLE PRECISION _PRIVATE :: meanError
90 : END TYPE ImpurityOperator
91 : !!***
92 :
93 : PUBLIC :: ImpurityOperator_init
94 : PUBLIC :: ImpurityOperator_reset
95 : PUBLIC :: ImpurityOperator_computeU
96 : PUBLIC :: ImpurityOperator_setUmat
97 : PUBLIC :: ImpurityOperator_setUmatComplex
98 : PUBLIC :: ImpurityOperator_setMu
99 : PUBLIC :: ImpurityOperator_activateParticle
100 : PUBLIC :: ImpurityOperator_getAvailableTime
101 : PUBLIC :: ImpurityOperator_getAvailedTime
102 : PUBLIC :: ImpurityOperator_add
103 : PUBLIC :: ImpurityOperator_getSegment
104 : PUBLIC :: ImpurityOperator_getsign
105 : PUBLIC :: ImpurityOperator_remove
106 : PUBLIC :: ImpurityOperator_getNewOverlap
107 : PUBLIC :: ImpurityOperator_getTraceAdd
108 : PUBLIC :: ImpurityOperator_getTraceRemove
109 : PRIVATE :: ImpurityOperator_overlapSegFlav
110 : PUBLIC :: ImpurityOperator_overlapflavor
111 : PUBLIC :: ImpurityOperator_overlapSwap
112 : PUBLIC :: ImpurityOperator_swap
113 : PRIVATE :: ImpurityOperator_overlapIJ
114 : PUBLIC :: ImpurityOperator_measDE
115 : PUBLIC :: ImpurityOperator_measDEComplex
116 : PUBLIC :: ImpurityOperator_cleanOverlaps
117 : PUBLIC :: ImpurityOperator_measN
118 : PUBLIC :: ImpurityOperator_destroy
119 : PUBLIC :: ImpurityOperator_getErrorOverlap
120 : PUBLIC :: ImpurityOperator_doCheck
121 : PRIVATE :: ImpurityOperator_checkOverlap
122 : PUBLIC :: ImpurityOperator_getError
123 : PUBLIC :: ImpurityOperator_printLatex
124 : PUBLIC :: ImpurityOperator_occup_histo_time
125 : PUBLIC :: ImpurityOperator_setMagmommat
126 :
127 : CONTAINS
128 : !!***
129 :
130 : !SUBROUTINE ImpurityOperator_init(this, flavors, beta, N)
131 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_init
132 : !! NAME
133 : !! ImpurityOperator_init
134 : !!
135 : !! FUNCTION
136 : !! Initialize and allocate
137 : !!
138 : !! COPYRIGHT
139 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
140 : !! This file is distributed under the terms of the
141 : !! GNU General Public License, see ~abinit/COPYING
142 : !! or http://www.gnu.org/copyleft/gpl.txt .
143 : !!
144 : !! INPUTS
145 : !! this=ImpurtiyOperator
146 : !! flavors=number of flavors
147 : !! beta=inverse temperature
148 : !! opt_histo=opt_histo
149 : !!
150 : !! OUTPUT
151 : !!
152 : !! SIDE EFFECTS
153 : !!
154 : !! NOTES
155 : !!
156 : !! SOURCE
157 :
158 102 : SUBROUTINE ImpurityOperator_init(this, flavors, beta)
159 :
160 : !Arguments ------------------------------------
161 : TYPE(ImpurityOperator), INTENT(INOUT) :: this
162 : INTEGER , INTENT(IN ) :: flavors
163 : !DOUBLE PRECISION , INTENT(IN ) :: U
164 : !DOUBLE PRECISION , INTENT(IN ) :: J
165 : DOUBLE PRECISION , INTENT(IN ) :: beta
166 : !INTEGER , INTENT(IN ) :: N
167 : !Local variables ------------------------------
168 : INTEGER :: IT
169 :
170 102 : this%flavors = flavors
171 102 : this%activeFlavor = 0
172 102 : this%beta = beta
173 :
174 102 : IF ( MOD(flavors,2) .NE. 0 ) &
175 0 : CALL ERROR("ImpurityOperator_init : flavors is not even ")
176 :
177 : !#ifdef CTQMC_CHECK
178 102 : this%meanError = 0.d0
179 102 : this%checkNumber = 0.d0
180 102 : this%tolerance = 0.d0
181 102 : this%doCheck = .FALSE.
182 : !#endif
183 102 : DT_FREEIF(this%particles)
184 1382 : DT_MALLOC(this%particles,(1:flavors))
185 102 : FREEIF(this%mat_U)
186 408 : MALLOC(this%mat_U,(1:flavors,1:flavors))
187 102 : FREEIF(this%overlaps)
188 306 : MALLOC(this%overlaps,(1:flavors,1:flavors))
189 13170 : this%overlaps = 0.d0
190 102 : FREEIF(this%updates)
191 306 : MALLOC(this%updates,(1:flavors))
192 1178 : this%updates = 0.d0
193 102 : FREEIF(this%Magmommat_orb)
194 306 : MALLOC(this%Magmommat_orb,(1:flavors,1:flavors))
195 102 : FREEIF(this%Magmommat_spin)
196 306 : MALLOC(this%Magmommat_spin,(1:flavors,1:flavors))
197 102 : FREEIF(this%Magmommat_tot)
198 306 : MALLOC(this%Magmommat_tot,(1:flavors,1:flavors))
199 : !CALL ImpurityOperator_computeU(this, U, J)
200 : !this%mat_U = U
201 : !IF ( ASSOCIATED(this%mu) ) FREE(this%mu)
202 : !MALLOC(this%mu,(1:flavors))
203 :
204 : !this%shift_mu = SUM(this%mat_U(:,1)) * .5d0
205 1178 : DO IT = 1,flavors
206 : !CALL ListCdagC_init(this%particles(IT), DBLE(N)/beta,100) !FIXME size of the List
207 1076 : CALL ListCdagC_init(this%particles(IT),100) !FIXME size of the List
208 1076 : this%particles(IT)%list(0,C_ ) = beta ! Empty orbital
209 1178 : this%particles(IT)%list(0,Cdag_) = 0.d0
210 : ! this%particles(IT)%list(0)%Cdag = beta ! Full orbital
211 : ! this%particles(IT)%list(0)%C = 0.d0
212 : END DO
213 102 : this%activeFlavor = 0
214 102 : END SUBROUTINE ImpurityOperator_init
215 : !!***
216 :
217 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_reset
218 : !! NAME
219 : !! ImpurityOperator_reset
220 : !!
221 : !! FUNCTION
222 : !! reset operator
223 : !!
224 : !! COPYRIGHT
225 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
226 : !! This file is distributed under the terms of the
227 : !! GNU General Public License, see ~abinit/COPYING
228 : !! or http://www.gnu.org/copyleft/gpl.txt .
229 : !!
230 : !! INPUTS
231 : !! this=ImpurtiyOperator
232 : !!
233 : !! OUTPUT
234 : !!
235 : !! SIDE EFFECTS
236 : !!
237 : !! NOTES
238 : !!
239 : !! SOURCE
240 :
241 49 : SUBROUTINE ImpurityOperator_reset(this)
242 :
243 : !Arguments ------------------------------------
244 : TYPE(ImpurityOperator), INTENT(INOUT) :: this
245 : !Local variables ------------------------------
246 : INTEGER :: IT
247 :
248 49 : this%activeFlavor = 0
249 6363 : this%overlaps = 0.d0
250 567 : this%updates = 0.d0
251 : !#ifdef CTQMC_CHECK
252 49 : this%meanError = 0.d0
253 49 : this%checkNumber = 0.d0
254 49 : this%tolerance = 0.d0
255 49 : this%doCheck = .FALSE.
256 : !#endif
257 567 : DO IT = 1,this%flavors
258 518 : CALL ListCdagC_clear(this%particles(IT))
259 518 : this%particles(IT)%list(0,C_ ) = this%beta ! Empty orbital
260 567 : this%particles(IT)%list(0,Cdag_) = 0.d0
261 : ! this%particles(IT)%list(0)%Cdag = beta ! Full orbital
262 : ! this%particles(IT)%list(0)%C = 0.d0
263 : END DO
264 :
265 49 : END SUBROUTINE ImpurityOperator_reset
266 : !!***
267 :
268 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_computeU
269 : !! NAME
270 : !! ImpurityOperator_computeU
271 : !!
272 : !! FUNCTION
273 : !! Compute an interaction this for t2g like interaction
274 : !!
275 : !! COPYRIGHT
276 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
277 : !! This file is distributed under the terms of the
278 : !! GNU General Public License, see ~abinit/COPYING
279 : !! or http://www.gnu.org/copyleft/gpl.txt .
280 : !!
281 : !! INPUTS
282 : !! this=ImpurityOperator
283 : !! U=Coulomb scrren interaction
284 : !! J=Hund couplage
285 : !!
286 : !! OUTPUT
287 : !!
288 : !! SIDE EFFECTS
289 : !!
290 : !! NOTES
291 : !!
292 : !! SOURCE
293 :
294 102 : SUBROUTINE ImpurityOperator_computeU(this, U, J)
295 :
296 : !Arguments ------------------------------------
297 : TYPE(ImpurityOperator), INTENT(INOUT) :: this
298 : DOUBLE PRECISION , INTENT(IN ) :: U
299 : DOUBLE PRECISION , INTENT(IN ) :: J
300 : !Local variables ------------------------------
301 : INTEGER :: flavor11
302 : INTEGER :: flavor12
303 : INTEGER :: flavor21
304 : INTEGER :: flavor22
305 : INTEGER :: flavors
306 : INTEGER :: flavors_2
307 : DOUBLE PRECISION :: Uprime
308 :
309 102 : Uprime = U - 2.d0 * J
310 102 : flavors = this%flavors
311 102 : flavors_2 = flavors / 2
312 640 : DO flavor11 = 1, flavors_2
313 538 : flavor12 = flavors - flavor11 + 1
314 538 : this%mat_U(flavor11, flavor11) = 0.d0
315 538 : this%mat_U(flavor12, flavor12) = 0.d0
316 538 : this%mat_U(flavor11+flavors_2, flavor11) = U
317 538 : this%mat_U(flavor12-flavors_2, flavor12) = U
318 1768 : DO flavor21 = flavor11+1, flavors_2
319 1230 : flavor22 = flavors - flavor21 + 1
320 1230 : this%mat_U(flavor21, flavor11) = Uprime
321 1230 : this%mat_U(flavor22-flavors_2, flavor12-flavors_2) = Uprime
322 1230 : this%mat_U(flavor21+flavors_2, flavor11+flavors_2) = Uprime
323 1768 : this%mat_U(flavor22, flavor12) = Uprime
324 : END DO
325 1870 : DO flavor21 = flavor11+flavors_2+1, flavors
326 1230 : flavor22 = flavors - flavor21 + 1
327 1230 : this%mat_U(flavor21, flavor11) = Uprime - J
328 1230 : this%mat_U(flavor22+flavors_2, flavor12-flavors_2) = Uprime - J
329 1230 : this%mat_U(flavor21-flavors_2, flavor11+flavors_2) = Uprime - J
330 1768 : this%mat_U(flavor22, flavor12) = Uprime - J
331 : END DO
332 : END DO
333 102 : END SUBROUTINE ImpurityOperator_computeU
334 : !!***
335 :
336 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_setUmat
337 : !! NAME
338 : !! ImpurityOperator_setUmat
339 : !!
340 : !! FUNCTION
341 : !! Set directly the U interaction this
342 : !!
343 : !! COPYRIGHT
344 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
345 : !! This file is distributed under the terms of the
346 : !! GNU General Public License, see ~abinit/COPYING
347 : !! or http://www.gnu.org/copyleft/gpl.txt .
348 : !!
349 : !! INPUTS
350 : !! this=ImpurtityOperator
351 : !! matU=interaction this
352 : !!
353 : !! OUTPUT
354 : !!
355 : !! SIDE EFFECTS
356 : !!
357 : !! NOTES
358 : !!
359 : !! SOURCE
360 :
361 49 : SUBROUTINE ImpurityOperator_setUmat(this, matU)
362 :
363 : !Arguments ------------------------------------
364 : TYPE(ImpurityOperator), INTENT(INOUT) :: this
365 : DOUBLE PRECISION, DIMENSION(:,:), INTENT(IN ) :: matU
366 :
367 : INTEGER :: iflavor1
368 : INTEGER :: iflavor2
369 :
370 147 : IF ( SIZE(matU) .NE. this%flavors*this%flavors ) &
371 0 : CALL ERROR("ImpurityOperator_setUmat : Wrong interaction this")
372 :
373 567 : DO iflavor1 = 1, this%flavors
374 3206 : DO iflavor2 = iflavor1+1, this%flavors
375 2639 : this%mat_U(iflavor1,iflavor2) = matU(iflavor1,iflavor2)
376 3157 : this%mat_U(iflavor2,iflavor1) = matU(iflavor2,iflavor1)
377 : END DO
378 : END DO
379 49 : END SUBROUTINE ImpurityOperator_setUmat
380 : !!***
381 :
382 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_setUmatComplex
383 : !! NAME
384 : !! ImpurityOperator_setUmatComplex
385 : !!
386 : !! FUNCTION
387 : !! Set directly the complex U interaction
388 : !!
389 : !! COPYRIGHT
390 : !! Copyright (C) 2013-2025 ABINIT group (J. Bieder)
391 : !! This file is distributed under the terms of the
392 : !! GNU General Public License, see ~abinit/COPYING
393 : !! or http://www.gnu.org/copyleft/gpl.txt .
394 : !!
395 : !! INPUTS
396 : !! this=ImpurtityOperator
397 : !! matU=interaction this
398 : !!
399 : !! OUTPUT
400 : !!
401 : !! SIDE EFFECTS
402 : !!
403 : !! NOTES
404 : !!
405 : !! SOURCE
406 :
407 0 : SUBROUTINE ImpurityOperator_setUmatComplex(this, matU)
408 :
409 : !Arguments ------------------------------------
410 : TYPE(ImpurityOperator), INTENT(INOUT) :: this
411 : COMPLEX(KIND=8), DIMENSION(:,:), INTENT(IN ) :: matU
412 :
413 : INTEGER :: iflavor1
414 : INTEGER :: iflavor2
415 :
416 0 : IF ( SIZE(matU) .NE. this%flavors*this%flavors ) &
417 0 : CALL ERROR("ImpurityOperator_setUmatComplex : Wrong interaction this")
418 :
419 0 : DO iflavor1 = 1, this%flavors
420 0 : DO iflavor2 = iflavor1+1, this%flavors
421 0 : this%mat_U(iflavor1,iflavor2) = matU(iflavor1,iflavor2)
422 0 : this%mat_U(iflavor2,iflavor1) = matU(iflavor2,iflavor1)
423 : END DO
424 : END DO
425 0 : END SUBROUTINE ImpurityOperator_setUmatComplex
426 : !!***
427 :
428 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_setMu
429 : !! NAME
430 : !! ImpurityOperator_setMu
431 : !!
432 : !! FUNCTION
433 : !! Set directly the chemical potential
434 : !!
435 : !! COPYRIGHT
436 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
437 : !! This file is distributed under the terms of the
438 : !! GNU General Public License, see ~abinit/COPYING
439 : !! or http://www.gnu.org/copyleft/gpl.txt .
440 : !!
441 : !! INPUTS
442 : !! this=ImpurtityOperator
443 : !! mu=chimical potential
444 : !!
445 : !! OUTPUT
446 : !!
447 : !! SIDE EFFECTS
448 : !!
449 : !! NOTES
450 : !!
451 : !! SOURCE
452 :
453 49 : SUBROUTINE ImpurityOperator_setMu(this, mu)
454 :
455 : !Arguments ------------------------------------
456 : TYPE(ImpurityOperator), INTENT(INOUT) :: this
457 : DOUBLE PRECISION, DIMENSION(:), INTENT(IN ) :: mu
458 : INTEGER :: iflavor
459 :
460 49 : IF ( SIZE(mu) .NE. this%flavors ) &
461 0 : CALL ERROR("ImpurityOperator_setMu : Wrong chimical potentials")
462 :
463 567 : DO iflavor = 1, this%flavors
464 567 : this%mat_U(iflavor,iflavor) = mu(iflavor)
465 : END DO
466 49 : END SUBROUTINE ImpurityOperator_setMu
467 : !!***
468 :
469 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_activateParticle
470 : !! NAME
471 : !! ImpurityOperator_activateParticle
472 : !!
473 : !! FUNCTION
474 : !! active a flavor
475 : !!
476 : !! COPYRIGHT
477 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
478 : !! This file is distributed under the terms of the
479 : !! GNU General Public License, see ~abinit/COPYING
480 : !! or http://www.gnu.org/copyleft/gpl.txt .
481 : !!
482 : !! INPUTS
483 : !! this=ImpurityOperator
484 : !! flavor=the flavor
485 : !!
486 : !! OUTPUT
487 : !!
488 : !! SIDE EFFECTS
489 : !!
490 : !! NOTES
491 : !!
492 : !! SOURCE
493 :
494 0 : SUBROUTINE ImpurityOperator_activateParticle(this,flavor)
495 :
496 : !Arguments ------------------------------------
497 : TYPE(ImpurityOperator), INTENT(INOUT) :: this
498 : INTEGER , INTENT(IN ) :: flavor
499 :
500 0 : IF ( flavor .GT. this%flavors ) &
501 0 : CALL ERROR("ImpurityOperator_activateParticle : out of range ")
502 0 : IF ( ALLOCATED(this%particles) ) THEN
503 0 : this%activeFlavor = flavor
504 : ELSE
505 0 : CALL ERROR("ImpurityOperator_activateParticle : not allocated ")
506 : END IF
507 0 : END SUBROUTINE ImpurityOperator_activateParticle
508 : !!***
509 :
510 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_getAvailableTime
511 : !! NAME
512 : !! ImpurityOperator_getAvailableTime
513 : !!
514 : !! FUNCTION
515 : !! get the time available and the position of the segment to consider
516 : !! negative if on a segment
517 : !! positive if outside a segment
518 : !!
519 : !! COPYRIGHT
520 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
521 : !! This file is distributed under the terms of the
522 : !! GNU General Public License, see ~abinit/COPYING
523 : !! or http://www.gnu.org/copyleft/gpl.txt .
524 : !!
525 : !! INPUTS
526 : !! this=ImpurityOperator
527 : !! time=time to look for
528 : !!
529 : !! OUTPUT
530 : !! ImpurityOperator_getAvailableTime=Time available
531 : !! position=position of the next segment
532 : !!
533 : !! SIDE EFFECTS
534 : !!
535 : !! NOTES
536 : !!
537 : !! SOURCE
538 :
539 1022389057 : DOUBLE PRECISION FUNCTION ImpurityOperator_getAvailableTime(this, time, position)
540 :
541 : !Arguments ------------------------------------
542 : TYPE(ImpurityOperator), INTENT(IN ) :: this
543 : DOUBLE PRECISION , INTENT(IN ) :: time
544 : INTEGER , INTENT(OUT ) :: position
545 : !Local variables ------------------------------
546 : DOUBLE PRECISION :: t_avail
547 : INTEGER :: position_dwn
548 : INTEGER :: aF
549 : #include "ListCdagC_firstHigher.h"
550 1022389057 : aF = this%activeFlavor
551 1022389057 : IF ( aF .LE. 0 ) &
552 0 : CALL ERROR("ImpurityOperator_getAvailableTime : no active flav")
553 :
554 1022389057 : IF ( this%particles(aF)%tail .EQ. 0 ) THEN
555 448384430 : t_avail = this%particles(aF)%list(0,C_) - this%particles(aF)%list(0,Cdag_)
556 448384430 : position = SIGN(1,INT(t_avail))
557 : ELSE
558 : ! position = ListCdagC_firstHigher( this%particles(aF), time )
559 : #define list_1 this%particles(aF)
560 : #include "ListCdagC_firstHigher"
561 : #undef list_1
562 574004627 : position = firstHigher
563 574004627 : position_dwn = position - 1
564 574004627 : IF ( position_dwn .LE. 0) position_dwn = this%particles(aF)%tail
565 :
566 : ! t_avail = (time - this%particles(aF)%list(position_dwn)) .MOD. this%beta
567 574004627 : t_avail = time - this%particles(aF)%list(position_dwn,C_)
568 574004627 : IF ( this%particles(aF)%list(position_dwn,Cdag_) .GT. time ) &
569 208166099 : t_avail = t_avail + this%beta
570 :
571 574004627 : IF ( t_avail .GT. 0.d0 ) THEN !! We are outside the position_dwn segment
572 : ! t_avail = (this%particles(aF)%list(ABS(position)) - time ) .MOD. this%beta
573 483417801 : t_avail = this%particles(aF)%list(ABS(position),Cdag_) - time
574 483417801 : IF ( this%particles(aF)%list(ABS(position),Cdag_) .LT. time ) &
575 177302137 : t_avail = t_avail + this%beta
576 : ! ABS is used to prevent position to be -1 which is HERE the same as 1
577 : ELSE
578 90586826 : position = - position_dwn
579 : END IF
580 : END IF
581 :
582 1022389057 : ImpurityOperator_getAvailableTime = t_avail
583 :
584 1022389057 : END FUNCTION ImpurityOperator_getAvailableTime
585 : !!***
586 :
587 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_getAvailedTime
588 : !! NAME
589 : !! ImpurityOperator_getAvailedTime
590 : !!
591 : !! FUNCTION
592 : !! get the time available without the segment "position"
593 : !!
594 : !! COPYRIGHT
595 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
596 : !! This file is distributed under the terms of the
597 : !! GNU General Public License, see ~abinit/COPYING
598 : !! or http://www.gnu.org/copyleft/gpl.txt .
599 : !!
600 : !! INPUTS
601 : !! this=ImpurityOperator
602 : !! position=position of the segment
603 : !!
604 : !! OUTPUT
605 : !! ImpurityOperator_getAvailedTime=time available before ...
606 : !!
607 : !! SIDE EFFECTS
608 : !!
609 : !! NOTES
610 : !!
611 : !! SOURCE
612 :
613 573945019 : DOUBLE PRECISION FUNCTION ImpurityOperator_getAvailedTime(this, position)
614 :
615 : !Arguments ------------------------------------
616 : TYPE(ImpurityOperator), INTENT(IN ) :: this
617 : INTEGER , INTENT(IN ) :: position
618 : DOUBLE PRECISION :: T_avail
619 : INTEGER :: Pup
620 : INTEGER :: ABSp
621 : INTEGER :: tail
622 : INTEGER :: aF
623 :
624 573945019 : aF = this%activeFlavor
625 573945019 : IF ( aF .LE. 0 ) &
626 0 : CALL ERROR("ImpurityOperator_getAvailedTime : no active flavor")
627 573945019 : ABSp = ABS(position)
628 : ! position_up = (ABSposition+1).MOD.this%particles(aF)%tail
629 573945019 : tail = this%particles(aF)%tail
630 573945019 : MODCYCLE(ABSp+1,tail,Pup)
631 573945019 : IF ( position .GT. 0 ) THEN
632 : t_avail = this%particles(aF)%list(Pup, Cdag_) &
633 286970080 : - this%particles(aF)%list(ABSp,Cdag_)
634 : ELSE
635 : t_avail = this%particles(aF)%list(Pup ,C_) &
636 286974939 : - this%particles(aF)%list(ABSp,C_)
637 : END IF
638 573945019 : IF ( t_avail .LE. 0.d0 ) t_avail = t_avail + this%beta
639 573945019 : ImpurityOperator_getAvailedTime = t_avail
640 573945019 : END FUNCTION ImpurityOperator_getAvailedTime
641 : !!***
642 :
643 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_add
644 : !! NAME
645 : !! ImpurityOperator_add
646 : !!
647 : !! FUNCTION
648 : !! add a segment to the active flavor
649 : !!
650 : !! COPYRIGHT
651 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
652 : !! This file is distributed under the terms of the
653 : !! GNU General Public License, see ~abinit/COPYING
654 : !! or http://www.gnu.org/copyleft/gpl.txt .
655 : !!
656 : !! INPUTS
657 : !! this=ImpurityOperator
658 : !! CdagC_1=couple of times
659 : !! position_val=position of the CdagC_1 couple in the list
660 : !!
661 : !! OUTPUT
662 : !!
663 : !! SIDE EFFECTS
664 : !! this=ImpurityOperatoroffdiag
665 : !! this%particles(aF)%list is updated
666 : !! this%overlaps is updated
667 : !! NOTES
668 : !!
669 : !! SOURCE
670 :
671 85920850 : SUBROUTINE ImpurityOperator_add(this, CdagC_1, position_val)
672 :
673 : !Arguments ------------------------------------
674 : TYPE(ImpurityOperator), INTENT(INOUT) :: this
675 : DOUBLE PRECISION, DIMENSION(1:2), INTENT(IN ) :: CdagC_1
676 : INTEGER , INTENT(IN ) :: position_val
677 : !Local variables ------------------------------
678 : INTEGER :: position
679 : INTEGER :: aF
680 : INTEGER :: i
681 : DOUBLE PRECISION, DIMENSION(1:2) :: C2modify
682 : DOUBLE PRECISION, DIMENSION(1:2) :: C2add
683 : DOUBLE PRECISION :: TCdag
684 : DOUBLE PRECISION :: TC
685 :
686 85920850 : aF = this%activeFlavor
687 85920850 : IF ( aF .LE. 0 ) &
688 0 : CALL ERROR("ImpurityOperator_add : no active flavor ")
689 :
690 85920850 : position = position_val
691 :
692 85920850 : IF ( CdagC_1(C_) .GT. CdagC_1(Cdag_) ) THEN ! Ajout d'un segment
693 62352885 : C2add = CdagC_1
694 : ELSE ! Ajout d'un antisegment
695 23567965 : IF ( (this%particles(aF)%tail .EQ. 0) .AND. (this%particles(aF)%list(0,C_) .EQ. 0d0)) THEN ! should be full orbital
696 36539 : IF ( CdagC_1(Cdag_) .GT. this%beta ) THEN
697 : ! CALL CdagC_init(C2add,CdagC_1%Cdag-this%beta,CdagC_1%C)
698 : ! From the IF condition and the creation of CdagC in TryAddRemove, we have
699 : ! CdagC_1(Cdag_) > beta
700 : ! CdagC_1(C_) < beta
701 5786 : C2add(Cdag_) = CdagC_1(Cdag_)-this%beta
702 5786 : C2add(C_ ) = CdagC_1(C_)
703 : ! Now C2add(Cdag_) < beta
704 : ! still C2add(C_) < beta
705 : ELSE
706 : ! CALL CdagC_init(C2add,CdagC_1%Cdag,CdagC_1%C+this%beta)
707 : ! CdagC_1(Cdag_) < beta
708 : ! CdagC_1(C_) < beta
709 30753 : C2add(Cdag_) = CdagC_1(Cdag_)
710 30753 : C2add(C_ ) = CdagC_1(C_)+this%beta
711 : ! C2add(Cdag_) < beta
712 : ! C2ass(C_) > beta
713 : END IF
714 36539 : position = 0
715 : ! See impurityoperator_init to understand this. This is due to the
716 : ! convention for the full orbital case.
717 36539 : this%particles(aF)%list(0,C_ ) = this%beta
718 36539 : this%particles(aF)%list(0,Cdag_) = 0.d0
719 23531426 : ELSE IF ( this%particles(aF)%tail .GT. 0 ) THEN
720 23531426 : position = ABS(position)
721 23531426 : TCdag = this%particles(aF)%list(position,Cdag_)
722 23531426 : TC = CdagC_1(C_)
723 23531426 : IF ( TCdag .GT. TC ) TC = TC + this%beta
724 : ! CALL CdagC_init(C2modify,TCdag,TC)
725 23531426 : C2modify(Cdag_) = TCdag
726 23531426 : C2modify(C_ ) = TC
727 :
728 : ! TCdag = CdagC_1%Cdag.MOD.this%beta
729 23531426 : MODCYCLE(CdagC_1(Cdag_),this%beta,TCdag)
730 23531426 : TC = this%particles(aF)%list(position,C_)
731 : ! CALL CdagC_init(C2add,TCdag,TC)
732 23531426 : C2add(Cdag_) = TCdag
733 23531426 : C2add(C_ ) = TC
734 :
735 70594278 : this%particles(aF)%list(position,:) = C2modify
736 23531426 : IF ( C2modify(Cdag_) .GT. C2add(Cdag_) ) THEN
737 2859166 : position = 0
738 : ! C2add%C = C2add%C.MOD.this%beta
739 2859166 : MODCYCLE(C2add(C_),this%beta,C2add(C_))
740 : END IF
741 : ELSE
742 0 : CALL ERROR("ImpurityOperator_add : try to add an antisegment to an empty orbital")
743 : END IF
744 23567965 : position = position + 1
745 : END IF
746 85920850 : CALL ListCdagC_insert(this%particles(aF), c2add, position)
747 1141261694 : DO i = 1, this%flavors
748 1055340844 : this%overlaps(i,aF) = this%overlaps(i,aF) + this%updates(i)
749 1141261694 : this%overlaps(aF,i) = this%overlaps(i,aF)
750 : END DO
751 :
752 85920850 : END SUBROUTINE ImpurityOperator_add
753 : !!***
754 :
755 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_getSegment
756 : !! NAME
757 : !! ImpurityOperator_getSegment
758 : !!
759 : !! FUNCTION
760 : !! Return the segment at position_val
761 : !!
762 : !! COPYRIGHT
763 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
764 : !! This file is distributed under the terms of the
765 : !! GNU General Public License, see ~abinit/COPYING
766 : !! or http://www.gnu.org/copyleft/gpl.txt .
767 : !!
768 : !! INPUTS
769 : !! this=ImpurityOperator
770 : !! position_val=position of the asked segment
771 : !!
772 : !! OUTPUT
773 : !! ImpurityOperator_getSegment(2)=the couple of time
774 : !!
775 : !! SIDE EFFECTS
776 : !!
777 : !! NOTES
778 : !!
779 : !! SOURCE
780 :
781 573945019 : FUNCTION ImpurityOperator_getSegment(this,position_val)
782 :
783 : !Arguments ------------------------------------
784 : TYPE(ImpurityOperator), INTENT(INOUT) :: this
785 : INTEGER , INTENT(IN ) :: position_val
786 : !Local variables ------------------------------
787 : INTEGER :: position
788 : INTEGER :: tail
789 : INTEGER :: aF
790 : DOUBLE PRECISION :: beta
791 : DOUBLE PRECISION :: ImpurityOperator_getSegment(1:2)
792 :
793 573945019 : aF = this%activeFlavor
794 573945019 : IF ( aF .LE. 0 ) &
795 0 : CALL ERROR("ImpurityOperator_getSegment : no active flavor ")
796 :
797 573945019 : IF ( position_val .GT. 0 ) THEN
798 860910240 : ImpurityOperator_getSegment = this%particles(aF)%list(position_val,1:2)
799 : ELSE
800 286974939 : position = ABS(position_val)
801 286974939 : tail = this%particles(aF)%tail
802 286974939 : beta = this%beta
803 286974939 : ImpurityOperator_getSegment(C_) = this%particles(aF)%list(position,C_)
804 286974939 : position = position + 1
805 286974939 : IF ( position .GT. tail ) THEN
806 182719745 : IF ( ImpurityOperator_getSegment(C_) .LT. beta ) THEN
807 165235495 : ImpurityOperator_getSegment(Cdag_) = this%particles(aF)%list(1,Cdag_) + beta
808 : ELSE
809 17484250 : ImpurityOperator_getSegment(Cdag_) = this%particles(aF)%list(1,Cdag_)
810 17484250 : ImpurityOperator_getSegment(C_) = ImpurityOperator_getSegment(C_) -beta
811 : END IF
812 : ELSE
813 104255194 : ImpurityOperator_getSegment(Cdag_) = this%particles(aF)%list(position,Cdag_)
814 : END IF
815 :
816 : END IF
817 : END FUNCTION ImpurityOperator_getSegment
818 : !!***
819 :
820 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_remove
821 : !! NAME
822 : !! ImpurityOperator_remove
823 : !!
824 : !! FUNCTION
825 : !! Remove a segment for the active flavor
826 : !!
827 : !! COPYRIGHT
828 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
829 : !! This file is distributed under the terms of the
830 : !! GNU General Public License, see ~abinit/COPYING
831 : !! or http://www.gnu.org/copyleft/gpl.txt .
832 : !!
833 : !! INPUTS
834 : !! this=ImpurityOperator
835 : !! ieme=segment to remove
836 : !!
837 : !! OUTPUT
838 : !!
839 : !! SIDE EFFECTS
840 : !!
841 : !! NOTES
842 : !!
843 : !! SOURCE
844 :
845 85918401 : SUBROUTINE ImpurityOperator_remove(this,ieme)
846 :
847 : !Arguments ------------------------------------
848 : TYPE(ImpurityOperator), INTENT(INOUT) :: this
849 : INTEGER , INTENT(IN ) :: ieme
850 : !Local variables ------------------------------
851 : DOUBLE PRECISION, DIMENSION(1:2) :: CdagC_1
852 : INTEGER :: position
853 : INTEGER :: position_dwn
854 : INTEGER :: i
855 : INTEGER :: tail
856 : INTEGER :: aF
857 : ! DOUBLE PRECISION :: toRemove
858 :
859 85918401 : aF = this%activeFlavor
860 85918401 : IF ( aF .LE. 0 ) &
861 0 : CALL ERROR("ImpurityOperator_removeIeme : no active flavor ")
862 85918401 : position = ABS(ieme)
863 85918401 : IF ( position .GT. this%particles(aF)%tail ) &
864 0 : CALL ERROR("ImpurityOperator_removeIeme : out of range ")
865 :
866 85918401 : IF ( (ieme .LT. 0) .AND. (this%particles(aF)%tail .GT. 1) ) THEN
867 23532317 : position_dwn = position
868 : ! position = (position+1).MOD.this%particles(aF)%tail
869 23532317 : tail = this%particles(aF)%tail
870 23532317 : MODCYCLE((position+1),tail,position)
871 23532317 : CdagC_1(Cdag_) = this%particles(aF)%list(position_dwn,Cdag_)
872 23532317 : CdagC_1(C_ ) = this%particles(aF)%list(position,C_)
873 23532317 : IF (position_dwn .GT. position) CdagC_1(C_) = CdagC_1(C_) + this%beta
874 : ! toRemove = this%particles(aF)%list(position)%C - (CdagC_1%C.MOD.this%beta)
875 : ! CdagC_1%C = CdagC_1%C + toRemove
876 70596951 : this%particles(aF)%list(position_dwn,:) = CdagC_1
877 : END IF
878 :
879 85918401 : IF ( position .EQ. 1 ) THEN
880 33087724 : SELECT CASE (ieme)
881 : CASE (1)
882 33087724 : this%particles(aF)%list(0,C_ ) = this%beta
883 33087724 : this%particles(aF)%list(0,Cdag_) = 0.d0
884 : CASE (-1)
885 36539 : this%particles(aF)%list(0,C_ ) = 0.d0
886 35984060 : this%particles(aF)%list(0,Cdag_) = this%beta
887 : END SELECT
888 : END IF
889 85918401 : CALL ListCdagC_erase(this%particles(aF),position)
890 1141234195 : DO i = 1, this%flavors
891 1055315794 : this%overlaps(i,aF) = this%overlaps(i,aF) - this%updates(i)
892 1141234195 : this%overlaps(aF,i) = this%overlaps(i,aF)
893 : END DO
894 85918401 : END SUBROUTINE ImpurityOperator_remove
895 : !!***
896 :
897 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_getNewOverlap
898 : !! NAME
899 : !! ImpurityOperator_getNewOverlap
900 : !!
901 : !! FUNCTION
902 : !! Get the overlap induced by CdagC_1 in the current configuration
903 : !!
904 : !! COPYRIGHT
905 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
906 : !! This file is distributed under the terms of the
907 : !! GNU General Public License, see ~abinit/COPYING
908 : !! or http://www.gnu.org/copyleft/gpl.txt .
909 : !!
910 : !! INPUTS
911 : !! this=ImpurityOperator
912 : !! CdagC_1=the segment
913 : !!
914 : !! OUTPUT
915 : !! ImpurityOperator_getNewOverlap=overlap..
916 : !!
917 : !! SIDE EFFECTS
918 : !!
919 : !! NOTES
920 : !!
921 : !! SOURCE
922 :
923 1085148433 : DOUBLE PRECISION FUNCTION ImpurityOperator_getNewOverlap(this, CdagC_1)
924 :
925 : !Arguments ------------------------------------
926 : TYPE(ImpurityOperator), INTENT(INOUT) :: this
927 : DOUBLE PRECISION, DIMENSION(1:2), INTENT(IN) :: CdagC_1
928 : !Local variables ------------------------------
929 : DOUBLE PRECISION, DIMENSION(1:2) :: CdagC_2
930 : DOUBLE PRECISION :: overlap
931 : DOUBLE PRECISION :: totalOverlap
932 : DOUBLE PRECISION :: sign
933 : INTEGER :: flavor
934 : INTEGER :: otherFlavor
935 :
936 1085148433 : flavor = this%activeFlavor
937 1085148433 : IF ( flavor .LE. 0 ) &
938 0 : CALL ERROR("ImpurityOperator_getNewOverlap : no active flavor ")
939 1085148433 : IF ( CdagC_1(Cdag_) .LT. CdagC_1(C_) ) THEN ! segment C*C
940 752590856 : CdagC_2 = CdagC_1
941 752590856 : sign = -1.d0
942 : ELSE
943 332557577 : CdagC_2(C_) = CdagC_1(Cdag_)
944 332557577 : CdagC_2(Cdag_) = CdagC_1(C_)
945 332557577 : sign = 1.d0
946 : END IF
947 :
948 1085148433 : totalOverlap = 0.d0
949 :
950 15549099615 : DO otherFlavor = 1, this%flavors
951 14463951182 : IF ( otherFlavor .EQ. flavor ) CYCLE
952 13378802749 : overlap = ImpurityOperator_overlapSegFlav(this,CdagC_2(1:2),otherflavor)
953 : totalOverlap = totalOverlap &
954 13378802749 : + overlap * this%mat_U(otherFlavor,flavor)
955 15549099615 : this%updates(otherFlavor) = -sign * overlap
956 : END DO
957 :
958 1085148433 : totalOverlap = totalOverlap * sign
959 1085148433 : ImpurityOperator_getNewOverlap = totalOverlap
960 :
961 1085148433 : END FUNCTION ImpurityOperator_getNewOverlap
962 : !!***
963 :
964 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_getsign
965 : !! NAME
966 : !! ImpurityOperator_getsign
967 : !!
968 : !! FUNCTION
969 : !! Get the sign of the ratio of impurity traces
970 : !!
971 : !! COPYRIGHT
972 : !! Copyright (C) 2013-2026 ABINIT group (B. Amadon)
973 : !! This file is distributed under the terms of the
974 : !! GNU General Public License, see ~abinit/COPYING
975 : !! or http://www.gnu.org/copyleft/gpl.txt .
976 : !!
977 : !! INPUTS
978 : !! this = ImpurityOperator
979 : !! time2 = for segment/antisegment addition, end of segment
980 : !! position = for segment/antisegment removal, position of segment/antisegment removed
981 : !! action = > 0.5 addition
982 : !! < 0.5 removal
983 : !!
984 : !! OUTPUT
985 : !! ImpurityOperator_getsign = sign of ratio of impurity traces
986 : !!
987 : !! SIDE EFFECTS
988 : !!
989 : !! NOTES
990 : !!
991 : !! SOURCE
992 :
993 0 : DOUBLE PRECISION FUNCTION ImpurityOperator_getsign(this, time2, i, action, position)
994 :
995 : !Arguments ------------------------------------
996 : TYPE(ImpurityOperator), INTENT(IN) :: this
997 : DOUBLE PRECISION, INTENT(IN) :: time2, action
998 : INTEGER , INTENT(IN) :: i,position
999 : !Local variables ------------------------------
1000 : INTEGER :: tailint
1001 : DOUBLE PRECISION :: sign_imp
1002 : ! ************************************************************************
1003 0 : tailint=this%particles(this%activeflavor)%tail
1004 0 : if(action < 0.5d0) then
1005 0 : if(tailint>=1) then
1006 0 : if ( this%particles(this%activeFlavor)%list(tailint,2)>this%beta ) then ! segment winds around
1007 0 : if (i==1) then ! add segment do not change winding
1008 : sign_imp = 1
1009 0 : else if (i==2) then ! antisegment
1010 0 : if(time2>this%beta) then ! suppress winding around
1011 : sign_imp = -1
1012 : else ! winding around still here
1013 0 : sign_imp = 1
1014 : endif
1015 : endif
1016 : else ! segment do not wind around
1017 0 : if (i==1) then ! segment
1018 0 : if(time2>this%beta) then ! create winding
1019 : sign_imp = -1
1020 : else ! do not create winding
1021 0 : sign_imp = 1
1022 : endif
1023 0 : else if (i==2) then ! no winding in any case
1024 0 : sign_imp = 1
1025 : endif
1026 : endif
1027 0 : else if (tailint==0) then
1028 0 : if (i==1) then ! segment
1029 0 : if(time2>this%beta) then ! create winding
1030 : sign_imp = -1
1031 : else ! do not create winding
1032 0 : sign_imp = 1
1033 : endif
1034 0 : else if (i==2) then ! antisegment
1035 0 : if(time2>this%beta) then ! do not create winding
1036 : sign_imp = 1
1037 : else ! create winding
1038 0 : sign_imp = -1
1039 : endif
1040 : endif
1041 : endif
1042 : else
1043 0 : if ( this%particles(this%activeFlavor)%list(tailint,2)>this%beta ) then ! segment winds around
1044 0 : if (i==1) then ! remove segment
1045 0 : if(position==tailint) then ! suppress winding around
1046 : sign_imp = -1
1047 : else ! winding around still here
1048 0 : sign_imp = 1
1049 : endif
1050 0 : else if (i==2) then ! remove antisegment
1051 0 : if(tailint==1) then ! if tailint=1, create full orbital
1052 : sign_imp = -1
1053 : else ! if tailint >1 preserve winding
1054 0 : sign_imp = 1
1055 : endif
1056 : endif
1057 : else ! segments do not wind around
1058 0 : if (i==1) then ! suppress segment do not change winding
1059 : sign_imp = 1
1060 0 : else if (i==2) then ! antisegment
1061 0 : if(abs(position)==tailint) then ! create winding around only tailint >=1
1062 0 : if(tailint==1) then
1063 : sign_imp = 1
1064 : else
1065 0 : sign_imp = -1
1066 : endif
1067 : else !do not create winding around
1068 : sign_imp = 1
1069 : endif
1070 : endif
1071 : endif
1072 : endif
1073 :
1074 0 : ImpurityOperator_getsign=sign_imp
1075 :
1076 :
1077 0 : END FUNCTION ImpurityOperator_getsign
1078 : !!***
1079 :
1080 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_getTraceAdd
1081 : !! NAME
1082 : !! ImpurityOperator_getTraceAdd
1083 : !!
1084 : !! FUNCTION
1085 : !! Get the ratio of the traces of the impurity hamiltonien with and without the
1086 : !! new (anti-)segment.
1087 : !!
1088 : !! COPYRIGHT
1089 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
1090 : !! This file is distributed under the terms of the
1091 : !! GNU General Public License, see ~abinit/COPYING
1092 : !! or http://www.gnu.org/copyleft/gpl.txt .
1093 : !!
1094 : !! INPUTS
1095 : !! this=ImpurityOperator
1096 : !! CdagC_1=the segment
1097 : !!
1098 : !! OUTPUT
1099 : !! ImpurityOperator_getTraceAdd = Tr[exp(-beta !H_impurity)c(t1)cd(t1)c(t2)cd(t2)...]/Tr[..]
1100 : !!
1101 : !! SIDE EFFECTS
1102 : !!
1103 : !! NOTES
1104 : !!
1105 : !! SOURCE
1106 :
1107 511203414 : FUNCTION ImpurityOperator_getTraceAdd(this, CdagC_1) RESULT(trace)
1108 :
1109 : TYPE(ImpurityOperator) , INTENT(INOUT) :: this
1110 : DOUBLE PRECISION, DIMENSION(1:2), INTENT(IN ) :: CdagC_1
1111 : LOGICAL :: antiseg
1112 : DOUBLE PRECISION :: trace
1113 : DOUBLE PRECISION :: overlap
1114 : DOUBLE PRECISION :: length
1115 : DOUBLE PRECISION :: antisym_sign
1116 : DOUBLE PRECISION :: beta
1117 :
1118 511203414 : beta = this%beta
1119 511203414 : antisym_sign = 1.0d0
1120 511203414 : overlap = ImpurityOperator_getNewOverlap(this,CdagC_1)
1121 511203414 : length = CdagC_1(C_ ) - CdagC_1(Cdag_)
1122 511203414 : antiseg = length .LT. 0.d0
1123 : ! length > 0 if segment; < 0 if antisegment
1124 511203414 : if ( this%particles(this%activeFlavor)%tail .GT. 0 .AND. &
1125 : ( ( (.NOT. antiseg) .AND. CdagC_1(C_) .GT. beta ) .OR. &! for seg only
1126 : ( antiseg .AND. CdagC_1(C_) .LT. beta .AND. CdagC_1(Cdag_) .GT. beta ) & ! SIGN > 0 for antiseg only
1127 : ) &
1128 : ) THEN
1129 : antisym_sign = -1.d0
1130 464337415 : ELSE IF ( this%particles(this%activeFlavor)%tail .EQ. 0 .AND. &
1131 : ( ( (.NOT. antiseg) .AND. CdagC_1(C_) .GT. beta ) .OR. & ! >beta only possible for seg
1132 : ( antiseg .AND. CdagC_1(Cdag_) .LT. beta ) & ! antiseg cdag < beta
1133 : ) &
1134 : ) THEN
1135 511203414 : antisym_sign = -1.d0
1136 : END IF
1137 :
1138 511203414 : trace = antisym_sign * DEXP(this%mat_U(this%activeFlavor,this%activeFlavor)*length + overlap)
1139 :
1140 511203414 : END FUNCTION ImpurityOperator_getTraceAdd
1141 : !!***
1142 :
1143 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_getTraceRemove
1144 : !! NAME
1145 : !! ImpurityOperator_getTraceRemove
1146 : !!
1147 : !! FUNCTION
1148 : !! Get the ratio of the traces of the impurity hamiltonien without and with the
1149 : !! (anti-)segment.
1150 : !!
1151 : !! COPYRIGHT
1152 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
1153 : !! This file is distributed under the terms of the
1154 : !! GNU General Public License, see ~abinit/COPYING
1155 : !! or http://www.gnu.org/copyleft/gpl.txt .
1156 : !!
1157 : !! INPUTS
1158 : !! this=ImpurityOperator
1159 : !! position=position of the segment
1160 : !!
1161 : !! OUTPUT
1162 : !! ImpurityOperator_getTraceRemove = Tr[exp(-beta !H_impurity)c(t1)cd(t1)c(t2)cd(t2)...]/Tr[..]
1163 : !!
1164 : !! SIDE EFFECTS
1165 : !!
1166 : !! NOTES
1167 : !!
1168 : !! SOURCE
1169 :
1170 573945019 : FUNCTION ImpurityOperator_getTraceRemove(this, position) RESULT(trace)
1171 :
1172 : TYPE(ImpurityOperator), INTENT(INOUT) :: this
1173 : INTEGER , INTENT(IN ) :: position
1174 : INTEGER :: tail
1175 : DOUBLE PRECISION :: trace
1176 : DOUBLE PRECISION :: overlap
1177 : DOUBLE PRECISION :: length
1178 : DOUBLE PRECISION :: antisym_sign
1179 : DOUBLE PRECISION :: last_C
1180 : DOUBLE PRECISION :: beta
1181 : DOUBLE PRECISION, DIMENSION(1:2) :: CdagC_1
1182 :
1183 573945019 : beta = this%beta
1184 573945019 : antisym_sign = 1.0d0
1185 :
1186 573945019 : CdagC_1 = ImpurityOperator_getSegment(this,position)
1187 573945019 : length = CdagC_1(C_) - CdagC_1(Cdag_)
1188 : ! length > 0 if segment; < 0 if antisegment
1189 573945019 : overlap = ImpurityOperator_getNewOverlap(this,CdagC_1)
1190 :
1191 573945019 : tail = this%particles(this%activeFlavor)%tail
1192 573945019 : last_C = this%particles(this%activeFlavor)%list(tail,C_)
1193 573945019 : IF ( last_C .GT. beta ) THEN ! tail > 0 since if tail == 0 {0,beta}
1194 90558972 : IF ( ( position .EQ. tail ) .OR. & ! only possible for segment (<0 if antiseg)
1195 : ( length .LT. 0.d0 .AND. tail .EQ. 1 ) ) THEN
1196 573945019 : antisym_sign = -1.d0
1197 : END IF
1198 : ELSE
1199 483386047 : IF ( tail .GT. 1 .AND. position .EQ. -tail ) & !tail>1 and last antisegment
1200 573945019 : antisym_sign = -1.d0
1201 : END IF
1202 :
1203 573945019 : trace = antisym_sign * DEXP(-this%mat_U(this%activeFlavor,this%activeFlavor)*length-overlap)
1204 :
1205 573945019 : END FUNCTION ImpurityOperator_getTraceRemove
1206 : !!***
1207 :
1208 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_overlapSegFlav
1209 : !! NAME
1210 : !! ImpurityOperator_overlapSegFlav
1211 : !!
1212 : !! FUNCTION
1213 : !! Compute the overlap of a segment with a flavor
1214 : !!
1215 : !! COPYRIGHT
1216 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
1217 : !! This file is distributed under the terms of the
1218 : !! GNU General Public License, see ~abinit/COPYING
1219 : !! or http://www.gnu.org/copyleft/gpl.txt .
1220 : !!
1221 : !! INPUTS
1222 : !! this=ImpurityOperator
1223 : !! CdagC_1=segment
1224 : !! flavor=flavor to use
1225 : !!
1226 : !! OUTPUT
1227 : !! ImpurityOperator_overlapSegFlav=overlap between CdagC_1 and flavor
1228 : !!
1229 : !! SIDE EFFECTS
1230 : !!
1231 : !! NOTES
1232 : !!
1233 : !! SOURCE
1234 :
1235 13379075945 : DOUBLE PRECISION FUNCTION ImpurityOperator_overlapSegFlav(this,CdagC_1,flavor)
1236 :
1237 : !Arguments ------------------------------------
1238 : TYPE(ImpurityOperator), INTENT(INOUT) :: this
1239 : ! TYPE(CdagC) , INTENT(IN) :: CdagC_1
1240 : DOUBLE PRECISION, DIMENSION(1:2), INTENT(IN) :: CdagC_1
1241 : INTEGER , INTENT(IN) :: flavor
1242 : !Local variables ------------------------------
1243 : ! TYPE(CdagC), DIMENSION(:), POINTER :: list => NULL()
1244 : DOUBLE PRECISION :: totalCdag
1245 : DOUBLE PRECISION :: totalC
1246 : DOUBLE PRECISION :: beta
1247 : DOUBLE PRECISION :: Time
1248 : DOUBLE PRECISION :: Tmin
1249 : DOUBLE PRECISION :: Tmax
1250 : DOUBLE PRECISION :: TmaxBeta
1251 : DOUBLE PRECISION :: TscanMin
1252 : DOUBLE PRECISION :: TscanMax
1253 : ! DOUBLE PRECISION :: sign
1254 : DOUBLE PRECISION :: C
1255 : DOUBLE PRECISION :: Cdag
1256 : DOUBLE PRECISION :: loop
1257 : DOUBLE PRECISION :: itmin
1258 : DOUBLE PRECISION :: itmax
1259 : INTEGER :: tail
1260 : INTEGER :: tp1
1261 : INTEGER :: scanning
1262 : INTEGER :: imin
1263 : INTEGER :: imax
1264 : INTEGER :: loops
1265 : INTEGER :: iloop
1266 : #include "ListCdagC_firstHigher.h"
1267 :
1268 13379075945 : beta = this%beta
1269 13379075945 : Tmin = CdagC_1(Cdag_)
1270 13379075945 : Tmax = CdagC_1(C_)
1271 13379075945 : itmin= 0.d0
1272 :
1273 : ! TmaxBeta = Tmax.MOD.beta
1274 13379075945 : MODCYCLE(Tmax,beta,TmaxBeta)
1275 :
1276 13379075945 : tail = this%particles(flavor)%tail
1277 :
1278 13379075945 : totalC = 0.d0
1279 13379075945 : totalCdag = 0.d0
1280 13379075945 : IF ( tail .NE. 0 ) THEN
1281 7496007418 : tp1 = tail + 1
1282 7496007418 : loop = 0.d0
1283 : ! imin = ListCdagC_firstHigher( this%particles(flavor), Tmin ) - 1
1284 7496007418 : Time = Tmin
1285 : #define list_1 this%particles(flavor)
1286 : #include "ListCdagC_firstHigher"
1287 7496007418 : imin = firstHigher - 1
1288 :
1289 : SELECT CASE ( imin )
1290 : CASE(0)
1291 : scanning = tail
1292 2695371299 : loop = -1.d0
1293 : CASE(-2)
1294 2695371299 : scanning = tail
1295 : CASE DEFAULT
1296 4800636119 : scanning = imin
1297 : END SELECT
1298 : ! imax = ListCdagC_firstHigher( this%particles(flavor), TmaxBeta ) !- 1 Jamais atteint
1299 7496007418 : Time = TmaxBeta
1300 : #include "ListCdagC_firstHigher"
1301 : #undef list_1
1302 7496007418 : imax = firstHigher
1303 :
1304 7496007418 : TscanMin = Tmin
1305 7496007418 : TscanMax = Tmax
1306 :
1307 : ! Regarder avant
1308 7496007418 : IF ( (imin .EQ. 0) ) THEN
1309 2739387399 : C = this%particles(flavor)%list(scanning,C_) +loop* beta
1310 2739387399 : Cdag = this%particles(flavor)%list(scanning,Cdag_) +loop* beta
1311 2739387399 : itmax = MAX(TscanMin, Cdag)
1312 2739387399 : itmin = MIN(TscanMax, C )
1313 :
1314 2739387399 : IF ( itmin .GT. itmax ) THEN ! si egal alors overlap de 0
1315 110426425 : totalC = totalC + itmin
1316 110426425 : totalCdag = totalCdag + itmax
1317 : END IF
1318 2739387399 : scanning = scanning+1
1319 2739387399 : IF ( scanning .EQ. tp1 ) THEN
1320 2739387399 : scanning = 1
1321 : END IF
1322 : END IF
1323 :
1324 7496007418 : loops = imax - scanning
1325 7496007418 : IF ( TmaxBeta .NE. Tmax ) THEN
1326 2318179831 : loops = tail - loops
1327 5177827587 : ELSE IF ( imax .EQ. -1 ) THEN
1328 2122240439 : loops = tail - imin
1329 : END IF
1330 :
1331 : !Comparer betement 2 segments
1332 19895265686 : DO iloop =0, loops
1333 17705437139 : C = this%particles(flavor)%list(scanning,C_)
1334 17705437139 : Cdag = this%particles(flavor)%list(scanning,Cdag_)
1335 17705437139 : itmax = MAX(TscanMin, Cdag)
1336 17705437139 : itmin = MIN(TscanMax,C)
1337 :
1338 17705437139 : IF ( itmin .GT. itmax ) THEN ! si egal alors overla de 0
1339 5492571781 : totalC = totalC + itmin
1340 5492571781 : totalCdag = totalCdag + itmax
1341 : END IF
1342 17705437139 : scanning = scanning + 1
1343 25201444557 : IF ( scanning .EQ. tp1 ) THEN
1344 9903763964 : scanning = 1
1345 9903763964 : IF ( itmin .EQ. TScanMax ) EXIT
1346 4597585093 : TscanMin = TscanMin - beta
1347 4597585093 : TscanMax = TscanMax - beta
1348 : END IF
1349 : END DO
1350 :
1351 : ! Regarder apres le segment
1352 7496007418 : IF ( (itmin .NE. TscanMax) ) THEN
1353 410163046 : C = this%particles(flavor)%list(scanning,C_)
1354 410163046 : Cdag = this%particles(flavor)%list(scanning,Cdag_)
1355 410163046 : itmax = MAX(TscanMin, Cdag)
1356 410163046 : itmin = MIN(TscanMax,C)
1357 :
1358 410163046 : IF ( itmin .GT. itmax ) THEN ! si egal alors overla de 0
1359 268889390 : totalC = totalC + itmin
1360 268889390 : totalCdag = totalCdag + itmax
1361 : END IF
1362 : END IF
1363 5883068527 : ELSE IF ( this%particles(flavor)%list(0,C_) .EQ. 0.d0 ) THEN ! full orbital
1364 6336333 : totalC = Tmax
1365 6336333 : totalCdag = Tmin
1366 : END IF
1367 : !#ifdef CTQMC_CHECK
1368 13379075945 : IF ( this%doCheck .EQV. .TRUE. ) &
1369 0 : CALL ImpurityOperator_checkOverlap(this, Tmin, Tmax,totalC-totalCdag,flavor)
1370 : !#endif
1371 13379075945 : ImpurityOperator_overlapSegFlav = totalC - totalCdag
1372 :
1373 13379075945 : END FUNCTION ImpurityOperator_overlapSegFlav
1374 : !!***
1375 :
1376 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_overlapFlavor
1377 : !! NAME
1378 : !! ImpurityOperator_overlapFlavor
1379 : !!
1380 : !! FUNCTION
1381 : !! Returns the overlap of flavor with the others
1382 : !!
1383 : !! COPYRIGHT
1384 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
1385 : !! This file is distributed under the terms of the
1386 : !! GNU General Public License, see ~abinit/COPYING
1387 : !! or http://www.gnu.org/copyleft/gpl.txt .
1388 : !!
1389 : !! INPUTS
1390 : !! this=ImpurityOperator
1391 : !! flavor=the one we want
1392 : !!
1393 : !! OUTPUT
1394 : !! ImpurityOperator_overlapFlavor=result
1395 : !!
1396 : !! SIDE EFFECTS
1397 : !!
1398 : !! NOTES
1399 : !!
1400 : !! SOURCE
1401 :
1402 228580 : DOUBLE PRECISION FUNCTION ImpurityOperator_overlapFlavor(this,flavor)
1403 :
1404 : !Arguments ------------------------------------
1405 : TYPE(ImpurityOperator), INTENT(IN) :: this
1406 : INTEGER, OPTIONAL, INTENT(IN) :: flavor
1407 : !Local variables ------------------------------
1408 : INTEGER :: otherFlavor
1409 : DOUBLE PRECISION :: overlap
1410 : DOUBLE PRECISION :: totalOverlap
1411 :
1412 228580 : totalOverlap = 0.d0
1413 2498940 : DO otherFlavor = 1, this%flavors
1414 2270360 : IF ( otherFlavor .EQ. flavor ) CYCLE
1415 2041780 : overlap = this%overlaps(otherFlavor,flavor)
1416 : totalOverlap = totalOverlap &
1417 2498940 : + overlap * this%mat_U(otherFlavor,flavor)
1418 : END DO
1419 :
1420 228580 : ImpurityOperator_overlapFlavor = totalOverlap
1421 :
1422 228580 : END FUNCTION ImpurityOperator_overlapflavor
1423 : !!***
1424 :
1425 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_overlapSwap
1426 : !! NAME
1427 : !! ImpurityOperator_overlapSwap
1428 : !!
1429 : !! FUNCTION
1430 : !! compute the overlap of flavor1 with the configuration of flavor2
1431 : !!
1432 : !! COPYRIGHT
1433 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
1434 : !! This file is distributed under the terms of the
1435 : !! GNU General Public License, see ~abinit/COPYING
1436 : !! or http://www.gnu.org/copyleft/gpl.txt .
1437 : !!
1438 : !! INPUTS
1439 : !! this=ImpurityOperator
1440 : !! flavor1=interaction value
1441 : !! flavor2=configuration
1442 : !!
1443 : !! OUTPUT
1444 : !! ImpurityOperator_overlapSwap=new overlap
1445 : !!
1446 : !! SIDE EFFECTS
1447 : !!
1448 : !! NOTES
1449 : !!
1450 : !! SOURCE
1451 :
1452 228580 : DOUBLE PRECISION FUNCTION ImpurityOperator_overlapSwap(this,flavor1,flavor2)
1453 :
1454 : !Arguments ------------------------------------
1455 : TYPE(ImpurityOperator), INTENT(IN) :: this
1456 : INTEGER , INTENT(IN) :: flavor1
1457 : INTEGER , INTENT(IN) :: flavor2
1458 : !Local variables ------------------------------
1459 : INTEGER :: otherFlavor
1460 : DOUBLE PRECISION :: overlap
1461 : DOUBLE PRECISION :: totalOverlap
1462 :
1463 228580 : totalOverlap = 0.d0
1464 : ! Calcul l'overlap de flavor1 en utilisant la configuration de flavor2
1465 2498940 : DO otherFlavor = 1, this%flavors
1466 2498940 : IF ( otherFlavor .EQ. flavor2 ) THEN
1467 : CYCLE
1468 2041780 : ELSE IF ( otherFlavor .EQ. flavor1 ) THEN
1469 228580 : overlap = this%overlaps(otherFlavor,flavor2)
1470 : totalOverlap = totalOverlap &
1471 228580 : + overlap * this%mat_U(otherFlavor,flavor2)
1472 : ELSE
1473 1813200 : overlap = this%overlaps(otherFlavor,flavor2)
1474 : totalOverlap = totalOverlap &
1475 1813200 : + overlap * this%mat_U(otherFlavor,flavor1)
1476 : END IF
1477 : END DO
1478 :
1479 228580 : ImpurityOperator_overlapSwap = totalOverlap
1480 :
1481 228580 : END FUNCTION ImpurityOperator_overlapSwap
1482 : !!***
1483 :
1484 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_swap
1485 : !! NAME
1486 : !! ImpurityOperator_swap
1487 : !!
1488 : !! FUNCTION
1489 : !! Swap to flavors
1490 : !!
1491 : !! COPYRIGHT
1492 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
1493 : !! This file is distributed under the terms of the
1494 : !! GNU General Public License, see ~abinit/COPYING
1495 : !! or http://www.gnu.org/copyleft/gpl.txt .
1496 : !!
1497 : !! INPUTS
1498 : !! this=ImpurtiyOperator
1499 : !! flavor1=to swap
1500 : !! flavor2=to swap
1501 : !!
1502 : !! OUTPUT
1503 : !!
1504 : !! SIDE EFFECTS
1505 : !!
1506 : !! NOTES
1507 : !!
1508 : !! SOURCE
1509 :
1510 95797 : SUBROUTINE ImpurityOperator_swap(this,flavor1, flavor2)
1511 :
1512 : !Arguments ------------------------------------
1513 : TYPE(ImpurityOperator), INTENT(INOUT) :: this
1514 : INTEGER , INTENT(IN ) :: flavor1
1515 : INTEGER , INTENT(IN ) :: flavor2
1516 : !Local variables ------------------------------
1517 : INTEGER :: iflavor
1518 : DOUBLE PRECISION :: overlap_tmp
1519 :
1520 986059 : DO iflavor = 1, this%flavors
1521 986059 : IF ( iflavor .NE. flavor1 .AND. iflavor .NE. flavor2) THEN
1522 698668 : overlap_tmp = this%overlaps(iflavor,flavor1)
1523 698668 : this%overlaps(iflavor,flavor1) = this%overlaps(iflavor,flavor2)
1524 698668 : this%overlaps(flavor1,iflavor) = this%overlaps(iflavor,flavor2)
1525 698668 : this%overlaps(iflavor,flavor2) = overlap_tmp
1526 698668 : this%overlaps(flavor2,iflavor) = overlap_tmp
1527 : END IF
1528 : END DO
1529 :
1530 : !CALL ListCdagC_print(this%particles(flavor1),233)
1531 : !CALL ListCdagC_print(this%particles(flavor2),233)
1532 95797 : CALL ListCdagC_assign(this%list_swap, this%particles(flavor1)) !list_swap = particle
1533 95797 : this%particles(flavor1) = this%particles(flavor2)
1534 95797 : this%particles(flavor2) = this%list_swap
1535 : !CALL ListCdagC_swap(this%particles(flavor1),this%particles(flavor2))
1536 : !CALL ListCdagC_print(this%particles(flavor1),233)
1537 : !CALL ListCdagC_print(this%particles(flavor2),233)
1538 :
1539 95797 : END SUBROUTINE ImpurityOperator_swap
1540 : !!***
1541 :
1542 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_overlapIJ
1543 : !! NAME
1544 : !! ImpurityOperator_overlapIJ
1545 : !!
1546 : !! FUNCTION
1547 : !! Compute overlap between two flavors
1548 : !!
1549 : !! COPYRIGHT
1550 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
1551 : !! This file is distributed under the terms of the
1552 : !! GNU General Public License, see ~abinit/COPYING
1553 : !! or http://www.gnu.org/copyleft/gpl.txt .
1554 : !!
1555 : !! INPUTS
1556 : !! this=ImpurityOperator
1557 : !! i=first flavor
1558 : !! j=second flavor
1559 : !!
1560 : !! OUTPUT
1561 : !! ImpurityOperator_overlapIJ=result
1562 : !!
1563 : !! SIDE EFFECTS
1564 : !!
1565 : !! NOTES
1566 : !!
1567 : !! SOURCE
1568 :
1569 108071 : DOUBLE PRECISION FUNCTION ImpurityOperator_overlapIJ(this,i,j)
1570 :
1571 : !Arguments ------------------------------------
1572 : TYPE(ImpurityOperator), INTENT(INOUT) :: this
1573 : INTEGER , INTENT(IN) :: i
1574 : INTEGER , INTENT(IN) :: j
1575 : !Local variables ------------------------------
1576 : ! TYPE(ListCdagC) , POINTER :: particle1 => NULL()
1577 : ! DOUBLE PRECISION, DIMENSION(:,:), POINTER :: list1 => NULL()
1578 : INTEGER :: tail1
1579 : DOUBLE PRECISION, DIMENSION(1:2) :: CdagC_1
1580 : INTEGER :: isegment
1581 :
1582 : ! particle1 => this%particles(i)
1583 : ! list1 => particle1%list
1584 108071 : tail1 = this%particles(i)%tail
1585 :
1586 108071 : ImpurityOperator_overlapIJ = 0.d0
1587 108071 : IF ( tail1 .EQ. 0 .AND. this%particles(i)%list(0,C_) .EQ. 0.d0 ) THEN ! FULL
1588 : ! CALL CdagC_init(CdagC_1,0.d0,this%beta)
1589 36 : CdagC_1(Cdag_) = 0.d0
1590 36 : CdagC_1(C_ ) = this%beta
1591 :
1592 36 : ImpurityOperator_overlapIJ = ImpurityOperator_overlapSegFlav(this,CdagC_1,j)
1593 108035 : ELSE IF ( tail1 .GT. 0) THEN
1594 61242 : this%activeFlavor = i
1595 334402 : DO isegment = 1, tail1
1596 819480 : CdagC_1(:) = this%particles(i)%list(isegment,1:2)
1597 : ImpurityOperator_overlapIJ = ImpurityOperator_overlapIJ &
1598 334402 : + ImpurityOperator_overlapSegFlav(this,CdagC_1,j)
1599 : END DO
1600 : END IF
1601 :
1602 108071 : END FUNCTION ImpurityOperator_overlapIJ
1603 : !!***
1604 :
1605 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_measDE
1606 : !! NAME
1607 : !! ImpurityOperator_measDE
1608 : !!
1609 : !! FUNCTION
1610 : !! measure double occupancy and interaction energy
1611 : !!
1612 : !! COPYRIGHT
1613 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
1614 : !! This file is distributed under the terms of the
1615 : !! GNU General Public License, see ~abinit/COPYING
1616 : !! or http://www.gnu.org/copyleft/gpl.txt .
1617 : !!
1618 : !! INPUTS
1619 : !! this=ImpurityOperator
1620 : !!
1621 : !! OUTPUT
1622 : !! DE=array accumulating duoble occupancy and energy
1623 : !!
1624 : !! SIDE EFFECTS
1625 : !!
1626 : !! NOTES
1627 : !!
1628 : !! SOURCE
1629 :
1630 78610000 : SUBROUTINE ImpurityOperator_measDE(this,DE)
1631 :
1632 : !Arguments ------------------------------------
1633 : TYPE(ImpurityOperator), INTENT(IN) :: this
1634 : DOUBLE PRECISION, DIMENSION(:,:), INTENT(INOUT) :: DE
1635 : !Local variables ------------------------------
1636 : DOUBLE PRECISION :: localD
1637 : DOUBLE PRECISION :: totalE
1638 : INTEGER :: iflavor1
1639 : INTEGER :: iflavor2
1640 : INTEGER :: flavors
1641 :
1642 78610000 : IF ( .NOT. ALLOCATED(this%particles) ) &
1643 0 : CALL ERROR("ImpurityOperator_measD : no particle set ")
1644 :
1645 78610000 : totalE = 0.d0
1646 78610000 : flavors = this%flavors
1647 1100990000 : DO iflavor1 = 1, flavors
1648 7468780000 : DO iflavor2 = iflavor1+1, flavors
1649 : !localD = ImpurityOperator_overlapIJ(this,iflavor1,iflavor2)
1650 6367790000 : localD = this%overlaps(iflavor2,iflavor1)
1651 6367790000 : DE(iflavor2,iflavor1) = DE(iflavor2,iflavor1) + localD
1652 7390170000 : totalE = totalE + localD * real(this%mat_U(iflavor1,iflavor2))
1653 : END DO
1654 : END DO
1655 :
1656 78610000 : DE(1,1) = DE(1,1) + totalE
1657 :
1658 78610000 : END SUBROUTINE ImpurityOperator_measDE
1659 : !!***
1660 :
1661 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_measDEComplex
1662 : !! NAME
1663 : !! ImpurityOperator_measDEComplex
1664 : !!
1665 : !! FUNCTION
1666 : !! measure double occupancy and interaction energy
1667 : !!
1668 : !! COPYRIGHT
1669 : !! Copyright (C) 2013-2025 ABINIT group (J. Bieder)
1670 : !! This file is distributed under the terms of the
1671 : !! GNU General Public License, see ~abinit/COPYING
1672 : !! or http://www.gnu.org/copyleft/gpl.txt .
1673 : !!
1674 : !! INPUTS
1675 : !! this=ImpurityOperator
1676 : !!
1677 : !! OUTPUT
1678 : !! DE=array accumulating duoble occupancy and energy
1679 : !!
1680 : !! SIDE EFFECTS
1681 : !!
1682 : !! NOTES
1683 : !!
1684 : !! SOURCE
1685 :
1686 0 : SUBROUTINE ImpurityOperator_measDEComplex(this,DE)
1687 :
1688 : !Arguments ------------------------------------
1689 : TYPE(ImpurityOperator), INTENT(IN) :: this
1690 : COMPLEX(KIND=8), DIMENSION(:,:), INTENT(INOUT) :: DE
1691 : !Local variables ------------------------------
1692 : COMPLEX(KIND=8) :: localD
1693 : COMPLEX(KIND=8) :: totalE
1694 : INTEGER :: iflavor1
1695 : INTEGER :: iflavor2
1696 : INTEGER :: flavors
1697 :
1698 0 : IF ( .NOT. ALLOCATED(this%particles) ) &
1699 0 : CALL ERROR("ImpurityOperator_measD : no particle set ")
1700 :
1701 0 : totalE = 0.d0
1702 0 : flavors = this%flavors
1703 0 : DO iflavor1 = 1, flavors
1704 0 : DO iflavor2 = iflavor1+1, flavors
1705 : !localD = ImpurityOperator_overlapIJ(this,iflavor1,iflavor2)
1706 0 : localD = cmplx(this%overlaps(iflavor2,iflavor1),0.d0,kind=8)
1707 0 : DE(iflavor2,iflavor1) = DE(iflavor2,iflavor1) + localD
1708 0 : totalE = totalE + localD * this%mat_U(iflavor1,iflavor2)
1709 : END DO
1710 : END DO
1711 :
1712 0 : DE(1,1) = DE(1,1) + totalE
1713 :
1714 0 : END SUBROUTINE ImpurityOperator_measDEComplex
1715 : !!***
1716 :
1717 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_cleanOverlaps
1718 : !! NAME
1719 : !! ImpurityOperator_cleanOverlaps
1720 : !!
1721 : !! FUNCTION
1722 : !! Compute from scratch all overlaps
1723 : !!
1724 : !! COPYRIGHT
1725 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
1726 : !! This file is distributed under the terms of the
1727 : !! GNU General Public License, see ~abinit/COPYING
1728 : !! or http://www.gnu.org/copyleft/gpl.txt .
1729 : !!
1730 : !! INPUTS
1731 : !! this=ImpurityOperator
1732 : !!
1733 : !! OUTPUT
1734 : !!
1735 : !! SIDE EFFECTS
1736 : !!
1737 : !! NOTES
1738 : !!
1739 : !! SOURCE
1740 :
1741 2049 : SUBROUTINE ImpurityOperator_cleanOverlaps(this)
1742 :
1743 : !Arguments ------------------------------------
1744 : TYPE(ImpurityOperator), INTENT(INOUT) :: this
1745 : !Local variables ------------------------------
1746 : INTEGER :: iflavor1
1747 : INTEGER :: iflavor2
1748 : INTEGER :: flavors
1749 :
1750 2049 : IF ( .NOT. ALLOCATED(this%particles) ) &
1751 0 : CALL ERROR("ImpurityOperator_cleanOverlap : no particle set ")
1752 :
1753 2049 : flavors = this%flavors
1754 22935 : DO iflavor1 = 1, flavors
1755 131006 : DO iflavor2 = iflavor1+1, flavors
1756 128957 : this%overlaps(iflavor2,iflavor1) = ImpurityOperator_overlapIJ(this,iflavor1,iflavor2)
1757 : END DO
1758 : END DO
1759 :
1760 2049 : END SUBROUTINE ImpurityOperator_cleanOverlaps
1761 : !!***
1762 :
1763 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_measN
1764 : !! NAME
1765 : !! ImpurityOperator_measN
1766 : !!
1767 : !! FUNCTION
1768 : !! measure the number of electrons on flavor flavor
1769 : !!
1770 : !! COPYRIGHT
1771 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
1772 : !! This file is distributed under the terms of the
1773 : !! GNU General Public License, see ~abinit/COPYING
1774 : !! or http://www.gnu.org/copyleft/gpl.txt .
1775 : !!
1776 : !! INPUTS
1777 : !! this=ImpurityOperator
1778 : !! flavor=the flavor
1779 : !!
1780 : !! OUTPUT
1781 : !! ImpurityOperator_measN=number of electrons
1782 : !!
1783 : !! SIDE EFFECTS
1784 : !!
1785 : !! NOTES
1786 : !!
1787 : !! SOURCE
1788 :
1789 159198506 : DOUBLE PRECISION FUNCTION ImpurityOperator_measN(this,flavor)
1790 :
1791 : !Arguments ------------------------------------
1792 : TYPE(ImpurityOperator), INTENT(IN) :: this
1793 : INTEGER, OPTIONAL, INTENT(IN) :: flavor
1794 : !Local variables ------------------------------
1795 : DOUBLE PRECISION :: totalCdag
1796 : DOUBLE PRECISION :: totalC
1797 : INTEGER :: scanning
1798 : INTEGER :: aF
1799 :
1800 159198506 : IF ( PRESENT(flavor) ) THEN
1801 228580 : aF = flavor
1802 : ELSE
1803 158969926 : aF = this%activeFlavor
1804 : END IF
1805 :
1806 159198506 : IF ( aF .LE. 0 ) &
1807 0 : CALL ERROR("ImpurityOperator_measN : no active flavor ")
1808 :
1809 159198506 : totalC = (this%particles(aF)%list(0,Cdag_) - this%particles(aF)%list(0,C_) + this%beta) * .5d0
1810 159198506 : totalCdag = 0.d0
1811 :
1812 715683726 : DO scanning = 1, this%particles(aF)%tail
1813 556485220 : totalCdag = totalCdag + this%particles(aF)%list(scanning,Cdag_)
1814 715683726 : totalC = totalC + this%particles(aF)%list(scanning,C_ )
1815 : END DO
1816 :
1817 159198506 : ImpurityOperator_measN = totalC - totalCdag
1818 :
1819 159198506 : END FUNCTION ImpurityOperator_measN
1820 : !!***
1821 :
1822 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_destroy
1823 : !! NAME
1824 : !! ImpurityOperator_destroy
1825 : !!
1826 : !! FUNCTION
1827 : !! destroy and deallocate
1828 : !!
1829 : !! COPYRIGHT
1830 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
1831 : !! This file is distributed under the terms of the
1832 : !! GNU General Public License, see ~abinit/COPYING
1833 : !! or http://www.gnu.org/copyleft/gpl.txt .
1834 : !!
1835 : !! INPUTS
1836 : !! this=ImpurityOperator
1837 : !!
1838 : !! OUTPUT
1839 : !!
1840 : !! SIDE EFFECTS
1841 : !!
1842 : !! NOTES
1843 : !!
1844 : !! SOURCE
1845 :
1846 102 : SUBROUTINE ImpurityOperator_destroy(this)
1847 :
1848 : !Arguments ------------------------------------
1849 : TYPE(ImpurityOperator), INTENT(INOUT) :: this
1850 : !Local variables ------------------------------
1851 : INTEGER :: IT
1852 :
1853 102 : IF ( ALLOCATED(this%particles) ) THEN
1854 1178 : DO IT = 1, this%flavors
1855 1178 : CALL ListCdagC_destroy(this%particles(IT))
1856 : END DO
1857 1178 : DT_FREE(this%particles)
1858 : ENDIF
1859 102 : CALL ListCdagC_destroy(this%list_swap)
1860 102 : FREEIF(this%mat_U)
1861 102 : FREEIF(this%Magmommat_orb)
1862 102 : FREEIF(this%Magmommat_spin)
1863 102 : FREEIF(this%Magmommat_tot)
1864 102 : FREEIF(this%overlaps)
1865 102 : FREEIF(this%updates)
1866 102 : this%activeFlavor = 0
1867 102 : this%flavors = 0
1868 102 : this%beta = 0.d0
1869 102 : END SUBROUTINE ImpurityOperator_destroy
1870 : !!***
1871 :
1872 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_getErrorOverlap
1873 : !! NAME
1874 : !! ImpurityOperator_getErrorOverlap
1875 : !!
1876 : !! FUNCTION
1877 : !! compute error on the overlap (numerical accumulation)
1878 : !!
1879 : !! COPYRIGHT
1880 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
1881 : !! This file is distributed under the terms of the
1882 : !! GNU General Public License, see ~abinit/COPYING
1883 : !! or http://www.gnu.org/copyleft/gpl.txt .
1884 : !!
1885 : !! INPUTS
1886 : !! this=ImpurityOperator
1887 : !!
1888 : !! OUTPUT
1889 : !! DE=save the error
1890 : !!
1891 : !! SIDE EFFECTS
1892 : !!
1893 : !! NOTES
1894 : !!
1895 : !! SOURCE
1896 :
1897 0 : SUBROUTINE ImpurityOperator_getErrorOverlap(this,DE)
1898 :
1899 : !Arguments ------------------------------------
1900 : TYPE(ImpurityOperator), INTENT(INOUT) :: this
1901 : DOUBLE PRECISION, DIMENSION(:,:), INTENT(INOUT) :: DE
1902 : !Local variables ------------------------------
1903 : DOUBLE PRECISION :: localD1
1904 : DOUBLE PRECISION :: localD2
1905 : DOUBLE PRECISION :: totalE1
1906 : DOUBLE PRECISION :: totalE2
1907 : INTEGER :: iflavor1
1908 : INTEGER :: iflavor2
1909 : INTEGER :: flavors
1910 :
1911 0 : IF ( .NOT. ALLOCATED(this%particles) ) &
1912 0 : CALL ERROR("ImpurityOperator_getErrorOverlap : no particle set ")
1913 :
1914 0 : totalE1 = 0.d0
1915 0 : totalE2 = 0.d0
1916 0 : flavors = this%flavors
1917 0 : DO iflavor1 = 1, flavors
1918 0 : DO iflavor2 = iflavor1+1, flavors
1919 0 : localD1 = ImpurityOperator_overlapIJ(this,iflavor1,iflavor2)
1920 0 : localD2 = this%overlaps(iflavor2,iflavor1)
1921 0 : totalE1 = totalE1 + localD1 * this%mat_U(iflavor1,iflavor2)
1922 0 : totalE2 = totalE2 + localD2 * this%mat_U(iflavor1,iflavor2)
1923 : END DO
1924 : END DO
1925 :
1926 0 : DE(2,2) = ABS(totalE1 - totalE2)
1927 :
1928 0 : END SUBROUTINE ImpurityOperator_getErrorOverlap
1929 :
1930 : !!***
1931 : !#ifdef CTQMC_CHECK
1932 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_doCheck
1933 : !! NAME
1934 : !! ImpurityOperator_doCheck
1935 : !!
1936 : !! FUNCTION
1937 : !! set the check mechanism
1938 : !!
1939 : !! COPYRIGHT
1940 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
1941 : !! This file is distributed under the terms of the
1942 : !! GNU General Public License, see ~abinit/COPYING
1943 : !! or http://www.gnu.org/copyleft/gpl.txt .
1944 : !!
1945 : !! INPUTS
1946 : !! this=ImpurityOperator
1947 : !! opt_check=1||3 do check
1948 : !!
1949 : !! OUTPUT
1950 : !!
1951 : !! SIDE EFFECTS
1952 : !!
1953 : !! NOTES
1954 : !!
1955 : !! SOURCE
1956 :
1957 49 : SUBROUTINE ImpurityOperator_doCheck(this,opt_check)
1958 :
1959 : !Arguments ------------------------------------
1960 : TYPE(ImpurityOperator) , INTENT(INOUT) :: this
1961 : INTEGER , INTENT(IN ) :: opt_check
1962 :
1963 49 : IF ( opt_check .EQ. 1 .OR. opt_check .EQ. 3 ) &
1964 0 : this%doCheck = .TRUE.
1965 49 : END SUBROUTINE ImpurityOperator_doCheck
1966 : !!***
1967 :
1968 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_checkOverlap
1969 : !! NAME
1970 : !! ImpurityOperator_checkOverlap
1971 : !!
1972 : !! FUNCTION
1973 : !! check the calculation of the overlap (very very slow routine)
1974 : !! between Tmin and Tmax (c+ and c)
1975 : !!
1976 : !! COPYRIGHT
1977 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
1978 : !! This file is distributed under the terms of the
1979 : !! GNU General Public License, see ~abinit/COPYING
1980 : !! or http://www.gnu.org/copyleft/gpl.txt .
1981 : !!
1982 : !! INPUTS
1983 : !! this=ImpurityOperator
1984 : !! Tmin=c+
1985 : !! Tmax=c
1986 : !! iOverlap=input overlap (fast calculation)
1987 : !! iflavor=active flavor
1988 : !!
1989 : !! OUTPUT
1990 : !!
1991 : !! SIDE EFFECTS
1992 : !!
1993 : !! NOTES
1994 : !!
1995 : !! SOURCE
1996 :
1997 0 : SUBROUTINE ImpurityOperator_checkOverlap(this, Tmin, Tmax, iOverlap, iflavor)
1998 :
1999 : !Arguments ------------------------------------
2000 : TYPE(ImpurityOperator), INTENT(INOUT) :: this
2001 : DOUBLE PRECISION , INTENT(IN ) :: Tmin
2002 : DOUBLE PRECISION , INTENT(IN ) :: Tmax
2003 : DOUBLE PRECISION , INTENT(IN ) :: iOverlap
2004 : INTEGER , INTENT(IN ) :: iflavor
2005 : !Local variables ------------------------------
2006 : INTEGER, PARAMETER :: size=10000000
2007 : INTEGER :: imin
2008 : INTEGER :: imax
2009 : INTEGER :: imaxbeta
2010 : INTEGER :: isegment
2011 : INTEGER :: tail
2012 : INTEGER(1), DIMENSION(1:size,1:2) :: checktab
2013 : CHARACTER(LEN=4) :: a
2014 : DOUBLE PRECISION :: dt
2015 : DOUBLE PRECISION :: inv_dt
2016 : DOUBLE PRECISION :: overlap
2017 : DOUBLE PRECISION :: erreur
2018 : DOUBLE PRECISION :: weight
2019 : INTEGER :: try
2020 :
2021 0 : checktab = INT(0,1)
2022 0 : overlap = 0.d0
2023 :
2024 0 : dt = this%beta / DBLE((size-1))
2025 0 : inv_dt = 1.d0 / dt
2026 0 : imin = INT(Tmin / dt + 0.5d0) + 1
2027 0 : imax = INT(Tmax / dt + 0.5d0) + 1
2028 0 : MODCYCLE(imax, size, imaxbeta)
2029 :
2030 0 : tail = this%particles(iflavor)%tail
2031 :
2032 0 : DO try = imin, MIN(imax,size)
2033 0 : checktab(try,1)=INT(1,1)!IBSET(checktab(try,1),0)
2034 : END DO
2035 :
2036 0 : IF ( imax .NE. imaxbeta ) THEN
2037 0 : DO try = 1, imaxbeta
2038 0 : checktab(try,1)=INT(1,1)!IBSET(checktab(try,1),0)
2039 : END DO
2040 : END IF
2041 :
2042 0 : IF ( tail .NE. 0 ) THEN
2043 0 : DO isegment=1, tail
2044 0 : imin = INT(this%particles(iflavor)%list(isegment,Cdag_)* inv_dt + 0.5d0) + 1
2045 0 : imax = INT(this%particles(iflavor)%list(isegment,C_ )* inv_dt + 0.5d0) + 1
2046 0 : MODCYCLE(imax, size, imaxbeta)
2047 0 : DO try = imin, MIN(imax,size)
2048 0 : checktab(try,2)=INT(1,1)!IBSET(checktab(try,2),0)
2049 : END DO
2050 0 : IF ( imax .NE. imaxbeta ) THEN
2051 0 : DO try = 1, imaxbeta
2052 0 : checktab(try,2)=INT(1,1)!IBSET(checktab(try,2),0)
2053 : END DO
2054 : END IF
2055 : END DO
2056 0 : ELSE IF ( this%particles(iflavor)%list(0,C_) .EQ. 0.d0 ) THEN
2057 0 : DO try = 1, size
2058 0 : checktab(try,2)=INT(1,1)!IBSET(checktab(try,2),0)
2059 : END DO
2060 : END IF
2061 :
2062 0 : DO isegment = 1, size
2063 0 : IF ( IAND(checktab(isegment,1),checktab(isegment,2)) .EQ. INT(1,1) ) &
2064 0 : overlap = overlap + 1.d0
2065 : END DO
2066 :
2067 0 : overlap = overlap * dt
2068 :
2069 0 : IF ( iOverlap .EQ. 0.d0 ) THEN
2070 0 : erreur = ABS(overlap)
2071 : ELSE
2072 0 : erreur = ABS(overlap - iOverlap)
2073 : END IF
2074 0 : weight = ABS(2.d0 * DBLE(tail) * dt - iOverlap)
2075 0 : IF ( erreur .GT. weight ) THEN
2076 0 : WRITE(a,'(I4)') INT(erreur*100.d0)
2077 0 : CALL WARN("ImpurityOperator_checkOverlap : "//a//"% ")
2078 : END IF
2079 0 : IF ( iOverlap .LE. (2.d0 * DBLE(tail) * dt) ) &
2080 0 : this%meanError = this%meanError + 1.d0
2081 0 : this%checkNumber = this%checkNumber + 1.d0 !weight
2082 :
2083 0 : END SUBROUTINE ImpurityOperator_checkOverlap
2084 : !!***
2085 :
2086 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_getError
2087 : !! NAME
2088 : !! ImpurityOperator_getErro
2089 : !!
2090 : !! FUNCTION
2091 : !! get error on computing the overlap
2092 : !!
2093 : !! COPYRIGHT
2094 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
2095 : !! This file is distributed under the terms of the
2096 : !! GNU General Public License, see ~abinit/COPYING
2097 : !! or http://www.gnu.org/copyleft/gpl.txt .
2098 : !!
2099 : !! INPUTS
2100 : !! this=ImpurityOperator
2101 : !!
2102 : !! OUTPUT
2103 : !! ImpurityOperator_getError=percentage error
2104 : !!
2105 : !! SIDE EFFECTS
2106 : !!
2107 : !! NOTES
2108 : !!
2109 : !! SOURCE
2110 :
2111 0 : DOUBLE PRECISION FUNCTION ImpurityOperator_getError(this)
2112 :
2113 : !Arguments ------------------------------------
2114 : TYPE(ImpurityOperator), INTENT(IN) :: this
2115 : !Local variables ------------------------------
2116 : ! DOUBLE PRECISION :: tolerance
2117 : DOUBLE PRECISION :: error
2118 :
2119 0 : IF ( this%doCheck .EQV. .TRUE. ) THEN
2120 0 : error = ABS(this%meanError/this%checkNumber)
2121 : ! tolerance = ABS(this%tolerance/this%checkNumber)
2122 0 : ImpurityOperator_getError = error
2123 : ELSE
2124 : ImpurityOperator_getError = 0.d0
2125 : END IF
2126 0 : END FUNCTION ImpurityOperator_getError
2127 : !!***
2128 : !#endif
2129 :
2130 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_printLatex
2131 : !! NAME
2132 : !! ImpurityOperator_printLatex
2133 : !!
2134 : !! FUNCTION
2135 : !! print in a latex format all the configuration
2136 : !!
2137 : !! COPYRIGHT
2138 : !! Copyright (C) 2013-2026 ABINIT group (J. Bieder)
2139 : !! This file is distributed under the terms of the
2140 : !! GNU General Public License, see ~abinit/COPYING
2141 : !! or http://www.gnu.org/copyleft/gpl.txt .
2142 : !!
2143 : !! INPUTS
2144 : !! this=ImpurityOperator
2145 : !! ostream=file stream
2146 : !! isweep=current sweep number
2147 : !!
2148 : !! OUTPUT
2149 : !!
2150 : !! SIDE EFFECTS
2151 : !!
2152 : !! NOTES
2153 : !!
2154 : !! SOURCE
2155 :
2156 0 : SUBROUTINE ImpurityOperator_printLatex(this, ostream, isweep)
2157 :
2158 : !Arguments ------------------------------------
2159 : TYPE(ImpurityOperator), INTENT(IN) :: this
2160 : INTEGER , INTENT(IN) :: ostream
2161 : INTEGER , INTENT(IN) :: isweep
2162 : !Local variables ------------------------------
2163 : INTEGER :: flavors
2164 : INTEGER :: iflavor
2165 : INTEGER :: tail
2166 : INTEGER :: it
2167 : DOUBLE PRECISION :: C
2168 : DOUBLE PRECISION :: Cdag
2169 : INTEGER :: ordo
2170 : INTEGER :: y
2171 : INTEGER :: lines
2172 : INTEGER :: letters
2173 : DOUBLE PRECISION :: length
2174 :
2175 0 : flavors = this%flavors
2176 :
2177 0 : WRITE(ostream,'(A13)') "\begin{frame}"
2178 0 : WRITE(ostream,'(2x,A14)') "\begin{figure}"
2179 0 : WRITE(ostream,'(4x,A28)') "\setlength{\unitlength}{1mm}"
2180 0 : WRITE(ostream,'(4x,A23)') "\begin{picture}(104,90)"
2181 0 : WRITE(ostream,'(6x,A29,I6,A2)') "\put(52,00){\makebox(0,0)[c]{",isweep,"}}"
2182 0 : y = INT(90.d0/DBLE(flavors+1))
2183 0 : DO iflavor = 1, flavors
2184 0 : tail = this%particles(iflavor)%tail
2185 0 : ordo = iflavor * y
2186 0 : lines = ordo - 1
2187 0 : letters = ordo - 5
2188 0 : WRITE(ostream,'(6x,A6,I2)') "%ligne", iflavor
2189 0 : WRITE(ostream,'(6x,A41,I2,A16)') "\linethickness{0.5pt}\color{black}\put(2,",lines,"){\line(0,1){2}}"
2190 0 : WRITE(ostream,'(6x,A7,I2,A24)') "\put(2,",letters,"){\makebox(0,0)[c]{$0$}}"
2191 0 : WRITE(ostream,'(6x,A7,I2,A18)') "\put(2,",ordo,"){\line(1,0){100}}"
2192 0 : WRITE(ostream,'(6x,A9,I2,A16)') "\put(102,",lines,"){\line(0,1){2}}"
2193 0 : WRITE(ostream,'(6x,A9,I2,A28)') "\put(102,",letters,"){\makebox(0,0)[c]{$\beta$}}"
2194 0 : DO it = 1, tail
2195 0 : Cdag = 2.d0+(this%particles(iflavor)%list(it,Cdag_)/this%beta*100.d0)
2196 0 : C = 2.d0+(this%particles(iflavor)%list(it,C_ )/this%beta*100.d0)
2197 0 : length = C - Cdag
2198 0 : IF ( this%particles(iflavor)%list(it,C_) .LE. this%beta ) THEN
2199 0 : WRITE(ostream,'(8x,A9,I2)') "%segments", it
2200 : WRITE(ostream,'(8x,A37,F5.1,A1,I2,A13,F5.1,A2)') &
2201 0 : "\linethickness{2pt}\color{black}\put(",Cdag,",",ordo,"){\line(1,0){",length,"}}"
2202 0 : WRITE(ostream,'(8x,A5)') "%Cdag"
2203 0 : WRITE(ostream,'(8x,A12)') "\color{blue}"
2204 0 : WRITE(ostream,'(8x,A5,F5.1,A1,I2,A14)') "\put(",Cdag,",",ordo,"){\circle*{1}}"
2205 0 : WRITE(ostream,'(8x,A2)') "%C"
2206 0 : WRITE(ostream,'(8x,A11)') "\color{red}"
2207 0 : WRITE(ostream,'(8x,A5,F5.1,A1,I2,A14)') "\put(",C,",",ordo,"){\circle*{1}}"
2208 : ELSE
2209 0 : WRITE(ostream,'(8x,A9,I2)') "%segments", it
2210 : WRITE(ostream,'(8x,A37,F5.1,A1,I2,A13,F5.1,A2)') &
2211 0 : "\linethickness{2pt}\color{black}\put(",Cdag,",",ordo,"){\line(1,0){",102.d0-Cdag,"}}"
2212 0 : WRITE(ostream,'(8x,A7,I2,A13,F5.1,A2)') "\put(2,",ordo,"){\line(1,0){",C-102.d0,"}}"
2213 0 : WRITE(ostream,'(8x,A5)') "%Cdag"
2214 0 : WRITE(ostream,'(8x,A12)') "\color{blue}"
2215 0 : WRITE(ostream,'(8x,A5,F5.1,A1,I2,A14)') "\put(",Cdag,",",ordo,"){\circle*{1}}"
2216 0 : WRITE(ostream,'(8x,A2)') "%C"
2217 0 : WRITE(ostream,'(8x,A11)') "\color{red}"
2218 0 : WRITE(ostream,'(8x,A5,F5.1,A1,I2,A14)') "\put(",C-100.d0,",",ordo,"){\circle*{1}}"
2219 : END IF
2220 : END DO
2221 0 : IF ( tail .EQ. 0 .AND. this%particles(iflavor)%list(0,C_) .EQ. 0.d0 ) THEN
2222 0 : WRITE(ostream,'(8x,A9,I2)') "%segments", it
2223 0 : WRITE(ostream,'(8x,A39,I2,A18)') "\linethickness{2pt}\color{black}\put(2,",ordo,"){\line(1,0){100}}"
2224 : END IF
2225 : END DO
2226 0 : WRITE(ostream,'(4x,A13)') "\end{picture}"
2227 0 : WRITE(ostream,'(2x,A12)') "\end{figure}"
2228 0 : WRITE(ostream,'(2x,A17)') "\transduration{0}"
2229 0 : WRITE(ostream,'(A11)') "\end{frame}"
2230 0 : END SUBROUTINE ImpurityOperator_printLatex
2231 : !!***
2232 :
2233 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_occup_histo_time
2234 : !! NAME
2235 : !! ImpurityOperator_occup_histo_time
2236 : !!
2237 : !! SUBROUTINE
2238 : !! Compute histogrammes of occupations.
2239 : !!
2240 : !! COPYRIGHT
2241 : !! Copyright (C) 2013-2026 ABINIT group (B. Amadon, F. Gendron)
2242 : !! This file is distributed under the terms of the
2243 : !! GNU General Public License, see ~abinit/COPYING
2244 : !! or http://www.gnu.org/copyleft/gpl.txt .
2245 : !!
2246 : !! INPUTS
2247 : !! this=ImpurityOperator
2248 : !! histo=histogramme of occupations
2249 : !!
2250 : !! OUTPUT
2251 : !! ImpurityOperator_occup_histo_time=number of electrons
2252 : !!
2253 : !! SIDE EFFECTS
2254 : !!
2255 : !! NOTES
2256 : !!
2257 : !! SOURCE
2258 :
2259 3030000 : SUBROUTINE ImpurityOperator_occup_histo_time(this,histo,occupconfig,suscep,ntau,chi,chicharge,ntot,opt_histo,nspinor)
2260 :
2261 : !Arguments ------------------------------------
2262 : TYPE(ImpurityOperator), INTENT(IN) :: this
2263 : DOUBLE PRECISION, DIMENSION(:), INTENT(OUT) :: histo
2264 : DOUBLE PRECISION, DIMENSION(:), INTENT(OUT) :: occupconfig
2265 : DOUBLE PRECISION, DIMENSION(:,:), INTENT(OUT) :: suscep
2266 : INTEGER, INTENT(IN) :: ntau
2267 : DOUBLE PRECISION, DIMENSION(:,:), INTENT(OUT) :: chi
2268 : DOUBLE PRECISION, DIMENSION(:,:), INTENT(OUT) :: chicharge
2269 : DOUBLE PRECISION, DIMENSION(:), INTENT(OUT) :: ntot
2270 : !Local variables ------------------------------
2271 : DOUBLE PRECISION :: tau
2272 : INTEGER :: scanning, opt_histo,nspinor
2273 : INTEGER :: iflavor, itau,jtau,kdeltatau,noccup,iconfig,sumh,nmeas
2274 : INTEGER :: iflavor1, iflavor2
2275 3030000 : INTEGER, ALLOCATABLE, DIMENSION(:,:) :: occup
2276 3030000 : INTEGER, ALLOCATABLE, DIMENSION(:) :: occuptot
2277 3030000 : INTEGER, ALLOCATABLE, DIMENSION(:,:) :: spinup,spindn
2278 3030000 : INTEGER, ALLOCATABLE, DIMENSION(:) :: occupconfig_loc
2279 3030000 : DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: histo_loc
2280 : ! DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: histo_loc_config
2281 3030000 : DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: magmommat_orb
2282 3030000 : DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: magmommat_spin
2283 3030000 : DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: magmommat_tot
2284 3030000 : DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: mu_tmp
2285 : !-------------------------------------------------------------
2286 :
2287 :
2288 9090000 : MALLOC(occuptot,(1:ntau))
2289 9090000 : MALLOC(spinup,(1:3,1:ntau))
2290 6060000 : MALLOC(spindn,(1:3,1:ntau))
2291 12120000 : MALLOC(occup,(1:this%flavors,1:ntau))
2292 9090000 : MALLOC(occupconfig_loc,(2**this%flavors))
2293 9090000 : MALLOC(histo_loc,(1:this%flavors+1))
2294 49646550000 : occupconfig_loc=0
2295 : nmeas=0
2296 :
2297 154530000 : do itau=1,ntau
2298 151500000 : tau=float(itau-1)/float(ntau)*this%beta
2299 151500000 : occuptot(itau)=0
2300 606000000 : spinup(:,itau)=0
2301 606000000 : spindn(:,itau)=0
2302 : ! write(6,*) "tau",tau
2303 : iconfig=0
2304 2272500000 : do iflavor = 1, this%flavors
2305 2121000000 : occup(iflavor,itau)=0
2306 3809123900 : do scanning = 1, this%particles(iflavor)%tail
2307 : ! write(6,*) itau,iflavor,scanning
2308 : ! write(6,*) "tau",tau,this%particles(iflavor)%list(scanning,Cdag_),this%particles(iflavor)%list(scanning,C_)
2309 : ! write(6,*) "Hello Fred 2",tau,iflavor,this%particles(iflavor)%list(scanning,C_)-this%particles(iflavor)%list(scanning,Cdag_),this%beta
2310 :
2311 3809123900 : if(this%particles(iflavor)%list(scanning,C_)>this%beta.and.tau<this%particles(iflavor)%list(scanning,Cdag_)) then
2312 :
2313 129001423 : if(tau<(this%particles(iflavor)%list(scanning,C_)-this%beta).and.&
2314 : & tau>(this%particles(iflavor)%list(scanning,Cdag_)-this%beta)) then
2315 25001657 : occup(iflavor,itau)=occup(iflavor,itau)+1
2316 : endif
2317 :
2318 : else
2319 :
2320 1559122477 : if(tau<this%particles(iflavor)%list(scanning,C_).and.tau>this%particles(iflavor)%list(scanning,Cdag_)) then
2321 125750275 : occup(iflavor,itau)=occup(iflavor,itau)+1
2322 : endif
2323 :
2324 : endif
2325 :
2326 : enddo
2327 :
2328 : !full orbital
2329 2121000000 : if ( this%particles(iflavor)%list(0,C_) .eq. 0.d0 ) then
2330 : !write(6,*) "Yes",this%particles(iflavor)%list(0,C_)
2331 690500 : occup(iflavor,itau)=occup(iflavor,itau)+1
2332 : endif
2333 :
2334 2121000000 : occuptot(itau)= occuptot(itau) + occup(iflavor,itau)
2335 2121000000 : if(nspinor .eq. 1) then
2336 2121000000 : if(iflavor<this%flavors/2+1) THEN
2337 1060500000 : spinup(1,itau)= spinup(1,itau) + occup(iflavor,itau)
2338 1060500000 : if(iflavor==1.or.iflavor==2.or.iflavor==4.or.iflavor==6.or.iflavor==7.or.iflavor==9) THEN
2339 757500000 : spinup(2,itau)= spinup(2,itau) + occup(iflavor,itau)
2340 : else
2341 303000000 : spinup(3,itau)= spinup(3,itau) + occup(iflavor,itau)
2342 : !if(spinup(3,itau)>4) THEN
2343 : ! write(6,*) "Error",spinup(:,itau),occup(:,itau)
2344 : ! if(iflavor==1.or.iflavor==2.or.iflavor==4) THEN
2345 : ! write(6,*) iflavor,occup(iflavor,itau)
2346 : ! endif
2347 : ! stop
2348 : !endif
2349 : endif
2350 : else
2351 1060500000 : spindn(1,itau)= spindn(1,itau) + occup(iflavor,itau)
2352 1060500000 : if(iflavor==1.or.iflavor==2.or.iflavor==4.or.iflavor==6.or.iflavor==7.or.iflavor==9) THEN
2353 151500000 : spindn(2,itau)= spindn(2,itau) + occup(iflavor,itau)
2354 : else
2355 909000000 : spindn(3,itau)= spindn(3,itau) + occup(iflavor,itau)
2356 : !if(spindn(3,itau)>4) THEN
2357 : ! write(6,*) "Error spin",spindn(:,itau),occup(:,itau)
2358 : ! write(6,*) "Error occup",occup(:,itau)
2359 : ! if(iflavor==1.or.iflavor==2.or.iflavor==4) THEN
2360 : ! write(6,*) iflavor,occup(iflavor,itau)
2361 : ! endif
2362 : ! stop
2363 : !endif
2364 : endif
2365 : endif
2366 : else
2367 : !spin-orbit case (here only useful for chi_charge and f-elements)
2368 0 : if(iflavor < 7) then
2369 : !mj=5/2
2370 0 : spinup(2,itau) = spinup(2,itau) + occup(iflavor,itau)
2371 : !if(iflavor ==1.or.iflavor==2.or.iflavor==3.or.iflavor==4) then
2372 : ! spinup(2,itau) = spinup(2,itau) + occup(iflavor,itau)
2373 : !else
2374 : ! spinup(3,itau) = spinup(3,itau) + occup(iflavor,itau)
2375 : !end if
2376 : else
2377 : !mj=7/2
2378 0 : spinup(3,itau) = spindn(3,itau) + occup(iflavor,itau)
2379 : end if
2380 : end if
2381 :
2382 : ! === Construct index of configuration in base 10
2383 2272500000 : iconfig=iconfig+2**(iflavor-1)*occup(iflavor,itau)
2384 :
2385 : enddo
2386 :
2387 : ! === After the loop over flavor, iconfig has a meaning and can be used
2388 151500000 : occupconfig_loc(iconfig+1)= occupconfig_loc(iconfig+1)+1
2389 3030000 : nmeas=nmeas+1
2390 :
2391 : enddo
2392 :
2393 48480000 : histo_loc=0
2394 154530000 : do itau=1,ntau
2395 154530000 : histo_loc(occuptot(itau)+1)=histo_loc(occuptot(itau)+1)+1
2396 : enddo
2397 :
2398 : ! write(6,*)
2399 : ! write(6,*) "=== Histogram of occupations ===="
2400 48480000 : do noccup=1,this%flavors+1
2401 45450000 : histo_loc(noccup)=histo_loc(noccup)/float(ntau)*100.0
2402 : ! write(6,*) noccup-1, histo_loc(noccup)
2403 48480000 : histo(noccup)= histo(noccup) + histo_loc(noccup)
2404 : enddo
2405 : ! write(6,*) "================================="
2406 : ! write(6,*)
2407 :
2408 : ! write(6,*) "================================="
2409 3030000 : sumh=zero
2410 49646550000 : do iconfig=1,2**(this%flavors)
2411 : ! occupconfig_loc(iconfig)=occupconfig_loc(iconfig)/float(ntau)*100.0
2412 49643520000 : occupconfig(iconfig)=occupconfig(iconfig)+float(occupconfig_loc(iconfig))/float(ntau)*100.0
2413 : ! write(6,*) "one step",float(occupconfig_loc(iconfig))/float(ntau)*100.0
2414 49646550000 : sumh=sumh+occupconfig_loc(iconfig)
2415 : enddo
2416 : ! write(6,*) "sumh",sumh,ntau,nmeas
2417 :
2418 : !============================================================
2419 : ! Susceptibility Section
2420 : !============================================================
2421 3030000 : if(opt_histo .gt. 1) then
2422 0 : if(nspinor .eq. 1) then
2423 : ! == Scalar Spin Susceptibility
2424 0 : do itau=1,ntau
2425 : !tau=float(itau-1)/float(ntau)*this%beta
2426 : ! write(7735,*) float(itau-1)/float(ntau)*this%beta,spinup(itau),spindn(itau),(spinup(itau)-spindn(itau))**2
2427 : ! write(7736,*) float(itau-1)/float(ntau)*this%beta,(spinup(1,itau)-spindn(1,itau)),(spinup(2,itau)-spindn(2,itau)),(spinup(3,itau)-spindn(3,itau))
2428 0 : do jtau=1,ntau
2429 : !tauj=float(jtau-1)/float(ntau)*this%beta
2430 0 : kdeltatau=jtau-itau+1
2431 0 : if(jtau<itau) kdeltatau=kdeltatau+ntau
2432 0 : if(kdeltatau> ntau) write(std_out,*) "Warning kdeltatau"
2433 0 : suscep(1,kdeltatau)=suscep(1,kdeltatau)+float((spinup(1,jtau)-spindn(1,jtau)))*float((spinup(1,itau)-spindn(1,itau)))
2434 0 : suscep(2,kdeltatau)=suscep(2,kdeltatau)+float((spinup(2,jtau)-spindn(2,jtau)))*float((spinup(2,itau)-spindn(2,itau)))
2435 0 : suscep(3,kdeltatau)=suscep(3,kdeltatau)+float((spinup(3,jtau)-spindn(3,jtau)))*float((spinup(3,itau)-spindn(3,itau)))
2436 : ! write(6,*) "Su",suscep(kdeltatau),spinup(tau)-spindn(jtau),spinup(itau)-spindn(itau)
2437 : ! write(6,*) "Su",itau,jtau,kdeltatau
2438 : enddo
2439 : !write(7735,*) float(itau-1)/float(ntau)*this%beta,spinup(itau),spindn(itau),(spinup(itau)-spindn(itau))**2
2440 : !write(7736,*) float(itau-1)/float(ntau)*this%beta,(spinup(itau)-spindn(itau))**2
2441 : !write(7737,*) float(itau-1)/float(ntau)*this%beta,suscep(1)
2442 : enddo
2443 :
2444 : else
2445 : ! == Spin Orbit Susceptibility
2446 0 : MALLOC(magmommat_orb,(1:this%flavors,1:this%flavors))
2447 0 : magmommat_orb=this%Magmommat_orb
2448 0 : MALLOC(magmommat_spin,(1:this%flavors,1:this%flavors))
2449 0 : magmommat_spin=this%Magmommat_spin
2450 0 : MALLOC(magmommat_tot,(1:this%flavors,1:this%flavors))
2451 0 : magmommat_tot=this%Magmommat_tot
2452 0 : MALLOC(mu_tmp,(1:3,1:ntau))
2453 :
2454 : ! == Product of occupation matrix with magnetic moment matrix
2455 0 : do itau=1,ntau
2456 0 : mu_tmp(:,itau)=0
2457 0 : do iflavor1=1,this%flavors
2458 0 : do iflavor2=1,this%flavors
2459 0 : if(iflavor1==iflavor2) then
2460 0 : mu_tmp(1,itau) = mu_tmp(1,itau) + magmommat_tot(iflavor1,iflavor2)*occup(iflavor1,itau)
2461 0 : mu_tmp(2,itau) = mu_tmp(2,itau) + magmommat_orb(iflavor1,iflavor2)*occup(iflavor1,itau)
2462 0 : mu_tmp(3,itau) = mu_tmp(3,itau) + magmommat_spin(iflavor1,iflavor2)*occup(iflavor1,itau)
2463 : !write(6,*) itau, magmommat(iflavor1,iflavor2), mu_tmp(:,itau)/ntau
2464 : end if
2465 : end do
2466 : end do
2467 : end do
2468 :
2469 : ! == Correlation function of mu_tmp for magnetic susceptibility with SOC (Approach 1)
2470 0 : do itau=1,ntau
2471 0 : do jtau=1,ntau
2472 0 : kdeltatau=jtau-itau+1
2473 0 : if(jtau<itau) kdeltatau=kdeltatau+ntau
2474 0 : if(kdeltatau> ntau) write(std_out,*) "Warning kdeltatau"
2475 0 : chi(1,kdeltatau) = chi(1,kdeltatau) + (mu_tmp(1,itau))*(mu_tmp(1,jtau))
2476 0 : chi(2,kdeltatau) = chi(2,kdeltatau) + (mu_tmp(2,itau))*(mu_tmp(2,jtau))
2477 0 : chi(3,kdeltatau) = chi(3,kdeltatau) + (mu_tmp(3,itau))*(mu_tmp(3,jtau))
2478 : end do
2479 : end do
2480 :
2481 0 : FREE(mu_tmp)
2482 0 : FREE(magmommat_orb)
2483 0 : FREE(magmommat_spin)
2484 0 : FREE(magmommat_tot)
2485 : endif
2486 : endif
2487 :
2488 3030000 : if(opt_histo .gt. 2) then
2489 0 : if(nspinor .eq. 1) then
2490 : ! == Scalar Charge Susceptibility
2491 :
2492 0 : do itau = 1,ntau
2493 0 : ntot(1) = ntot(1) + occuptot(itau)
2494 0 : ntot(2) = ntot(2) + float(spinup(2,itau)+spindn(2,itau))
2495 0 : ntot(3) = ntot(3) + float(spinup(3,itau)+spindn(3,itau))
2496 : enddo
2497 :
2498 0 : do itau=1,ntau
2499 0 : do jtau=1,ntau
2500 0 : kdeltatau=jtau-itau+1
2501 0 : if(jtau<itau) kdeltatau=kdeltatau+ntau
2502 0 : if(kdeltatau> ntau) write(std_out,*) "Warning kdeltatau"
2503 0 : chicharge(1,kdeltatau)=chicharge(1,kdeltatau)+float((spinup(1,jtau)+spindn(1,jtau)))*float((spinup(1,itau)+spindn(1,itau)))
2504 0 : chicharge(2,kdeltatau)=chicharge(2,kdeltatau)+float((spinup(2,jtau)+spindn(2,jtau)))*float((spinup(2,itau)+spindn(2,itau)))
2505 0 : chicharge(3,kdeltatau)=chicharge(3,kdeltatau)+float((spinup(3,jtau)+spindn(3,jtau)))*float((spinup(3,itau)+spindn(3,itau)))
2506 : enddo
2507 : enddo
2508 :
2509 : else
2510 : ! == Spin-orbit Charge Susceptibility
2511 : ! ntot(1) = Full occuptation, ntot(2) = mj_5/2, ntot(3) = mj_7/2
2512 0 : do itau = 1,ntau
2513 0 : ntot(1) = ntot(1) + occuptot(itau)
2514 0 : ntot(2) = ntot(2) + float(spinup(2,itau))
2515 0 : ntot(3) = ntot(3) + float(spinup(3,itau))
2516 : enddo
2517 :
2518 0 : do itau=1,ntau
2519 0 : do jtau=1,ntau
2520 0 : kdeltatau=jtau-itau+1
2521 0 : if(jtau<itau) kdeltatau=kdeltatau+ntau
2522 0 : if(kdeltatau> ntau) write(std_out,*) "Warning kdeltatau"
2523 0 : chicharge(1,kdeltatau)=chicharge(1,kdeltatau)+float(occuptot(jtau))*float(occuptot(itau))
2524 0 : chicharge(2,kdeltatau)=chicharge(2,kdeltatau)+float(spinup(2,jtau))*float(spindn(2,itau))
2525 0 : chicharge(3,kdeltatau)=chicharge(3,kdeltatau)+float(spinup(3,jtau))*float(spinup(3,itau))
2526 : enddo
2527 : enddo
2528 : end if
2529 : endif
2530 :
2531 3030000 : FREE(occup)
2532 3030000 : FREE(occupconfig_loc)
2533 3030000 : FREE(histo_loc)
2534 3030000 : FREE(occuptot)
2535 3030000 : FREE(spinup)
2536 3030000 : FREE(spindn)
2537 :
2538 :
2539 3030000 : END SUBROUTINE ImpurityOperator_occup_histo_time
2540 : !!***
2541 :
2542 : !!****f* ABINIT/m_ImpurityOperator/ImpurityOperator_setMagmommat
2543 : !! NAME
2544 : !! ImpurityOperator_setMagmommat
2545 : !!
2546 : !! FUNCTION
2547 : !! Set directly the Magnetic moment this
2548 : !!
2549 : !! COPYRIGHT
2550 : !! Copyright (C) 2013-2026 ABINIT group (F. Gendron)
2551 : !! This file is distributed under the terms of the
2552 : !! GNU General Public License, see ~abinit/COPYING
2553 : !! or http://www.gnu.org/copyleft/gpl.txt .
2554 : !!
2555 : !! INPUTS
2556 : !! this=ImpurtityOperator
2557 : !! matU=interaction this
2558 : !!
2559 : !! OUTPUT
2560 : !!
2561 : !! SIDE EFFECTS
2562 : !!
2563 : !! NOTES
2564 : !!
2565 : !! SOURCE
2566 :
2567 49 : SUBROUTINE ImpurityOperator_setMagmommat(this, Magmom_orb, Magmom_spin, Magmom_tot)
2568 :
2569 : !Arguments ------------------------------------
2570 : TYPE(ImpurityOperator), INTENT(INOUT) :: this
2571 : DOUBLE PRECISION, DIMENSION(:,:), INTENT(IN ) :: Magmom_orb
2572 : DOUBLE PRECISION, DIMENSION(:,:), INTENT(IN ) :: Magmom_spin
2573 : DOUBLE PRECISION, DIMENSION(:,:), INTENT(IN ) :: Magmom_tot
2574 : !Local-----------------------------------------
2575 : INTEGER :: iflavor1
2576 : INTEGER :: iflavor2
2577 :
2578 : !debug
2579 : ! write(6,*) "Inside Impurity_set Magmommat"
2580 : !
2581 : ! do iflavor1=1,10
2582 : ! do iflavor2=1,10
2583 : ! if(iflavor1==iflavor2) THEN
2584 : ! write(6,*) iflavor1, iflavor2, Magmom(iflavor1,iflavor2)
2585 : ! end if
2586 : ! end do
2587 : ! end do
2588 :
2589 567 : DO iflavor1 = 1, this%flavors
2590 6363 : DO iflavor2 = 1, this%flavors
2591 5796 : this%Magmommat_orb(iflavor1,iflavor2) = Magmom_orb(iflavor1,iflavor2)
2592 5796 : this%Magmommat_spin(iflavor1,iflavor2) = Magmom_spin(iflavor1,iflavor2)
2593 6314 : this%Magmommat_tot(iflavor1,iflavor2) = Magmom_tot(iflavor1,iflavor2)
2594 : END DO
2595 : END DO
2596 :
2597 49 : END SUBROUTINE ImpurityOperator_setMagmommat
2598 : !!***
2599 0 : END MODULE m_ImpurityOperator
2600 : !!***
|
