Commit 07a490f6 authored by Florian Goth's avatar Florian Goth
Browse files

all the ramifications...

parent af048a62
Pipeline #6563 passed with stage
in 1 minute
......@@ -391,11 +391,11 @@
! Here comes the S_z rep part (non-default)
if (nf == 2) X = -1.d0 ! This induces the asymmetry to the other spin sector
Op_Vneg(nc,nf,2)%P(1) = I
Op_Vneg(nc,nf,2)%O(1,1) = cmplx(1.d0, 0.d0, kind(0.D0))
Op_Vneg(nc,nf,2)%g = X*SQRT(CMPLX(DTAU*ham_U/2.d0, 0.D0, kind(0.D0))) ! Note the sign, usually
Op_Vneg(nc,nf,2)%alpha = cmplx(0.d0, 0.d0, kind(0.D0)) ! Note the alpha
Op_Vneg(nc,nf,2)%type = 2
Op_V(nc,nf,2)%P(1) = I
Op_V(nc,nf,2)%O(1,1) = cmplx(1.d0, 0.d0, kind(0.D0))
Op_V(nc,nf,2)%g = X*SQRT(CMPLX(DTAU*ham_U/2.d0, 0.D0, kind(0.D0))) ! Note the sign
Op_V(nc,nf,2)%alpha = cmplx(0.d0, 0.d0, kind(0.D0)) ! Note the alpha
Op_V(nc,nf,2)%type = 2
Call Op_set( Op_V(nc,nf,2) )
Enddo
......
......@@ -191,9 +191,10 @@ Contains
Complex (Kind=Kind(0.d0)), Intent(Inout) :: Phase
Integer, Intent(IN) :: N_SUN
Integer, dimension(:,:,:), Intent(In) :: Nsigma
Type (Operator), dimension(:,:), Intent(In) :: Op_V
Type (Operator), dimension(:,:, :), Intent(In) :: Op_V
Real (Kind=Kind(0.d0)) :: angle
Complex (Kind=Kind(0.d0)) :: coeff
Integer :: rep
Integer :: n, nf, nt, ns
......@@ -202,9 +203,12 @@ Contains
do nt = 1,size(nsigma,2)
coeff = 0.D0
do ns = 1,size(nsigma,3)
coeff = coeff + sqrt(splits(chosensplitting)%Vcoeffs(ns)) * Phi(nsigma(n,nt,ns),Op_V(n,nf)%type)
rep = 1
if (DBLE(splits(chosensplitting)%Vcoeffs(ns)) < 0) rep = 2
coeff = coeff + Op_V(n,nf, rep)%g * Op_V(n,nf, rep)%alpha * sqrt(splits(chosensplitting)%Vcoeffs(ns)) &
& * Phi(nsigma(n,nt,ns),Op_V(n,nf, rep)%type)
enddo
angle = Aimag(Op_V(n,nf)%g * Op_V(n,nf)%alpha * coeff)
angle = Aimag(coeff)
Phase = Phase*CMPLX(cos(angle),sin(angle), Kind(0.D0))
enddo
enddo
......
......@@ -166,18 +166,20 @@
Integer, INTENT(IN) :: NT
!Locals
Integer :: nf, n, ns
Integer :: nf, n, ns, rep
Complex (Kind=Kind(0.D0)), allocatable, Dimension(:, :) :: HLP4
Complex (Kind=Kind(0.D0)) :: X
Allocate(HLP4(Ndim, Ndim))
do ns = splits(chosensplitting)%nrVStages, 1, -1
rep = 1
if (DBLE(splits(chosensplitting)%Vcoeffs(ns)) < 0) rep = 2
Do nf = 1,N_FL
Call Hop_mod_mmthr(Ain(:,:,nf),HLP4,nf, ns)
Do n = 1,Size(Op_V,1)
X = sqrt(splits(chosensplitting)%Vcoeffs(ns)) * Phi(nsigma(n,nt, ns),Op_V(n,nf)%type)
Call Op_mmultR(HLP4,Op_V(n,nf),X,Ndim)
X = sqrt(splits(chosensplitting)%Vcoeffs(ns)) * Phi(nsigma(n,nt, ns),Op_V(n,nf, rep)%type)
Call Op_mmultR(HLP4,Op_V(n,nf, rep),X,Ndim)
ENDDO
Call ZLACPY('A', Ndim, Ndim, HLP4, Ndim, Ain(1,1, nf), Ndim)
Enddo
......@@ -201,19 +203,21 @@
Integer, INTENT(IN) :: NT
! Locals
Integer :: nf, n, ns
Integer :: nf, n, ns, rep
Complex (Kind=Kind(0.D0)), allocatable, Dimension(:, :) :: HLP4
Complex (Kind=Kind(0.D0)) :: X
Allocate(HLP4(Ndim, Ndim))
do ns = splits(chosensplitting)%nrVStages,1, -1
rep = 1
if (DBLE(splits(chosensplitting)%Vcoeffs(ns)) < 0) rep = 2
do nf = 1,N_FL
!Call MMULT(HLP4,Ain(:,:,nf),Exp_T_M1(:,:,nf) )
Call Hop_mod_mmthl_m1(Ain(:,:,nf),HLP4,nf, ns)
Do n =1,Size(Op_V,1)
X = - sqrt(splits(chosensplitting)%Vcoeffs(ns)) * Phi(nsigma(n,nt, ns),Op_V(n,nf)%type)
Call Op_mmultL(HLP4,Op_V(n,nf),X,Ndim)
X = - sqrt(splits(chosensplitting)%Vcoeffs(ns)) * Phi(nsigma(n,nt, ns),Op_V(n,nf, rep)%type)
Call Op_mmultL(HLP4,Op_V(n,nf, rep),X,Ndim)
Enddo
Call ZLACPY('A', Ndim, Ndim, HLP4, Ndim, Ain(1,1, nf), Ndim)
enddo
......
......@@ -54,7 +54,7 @@
! Local ::
Complex (Kind=Kind(0.d0)) :: Mat(Op_dim,Op_Dim), Delta(Op_dim,N_FL)
Complex (Kind=Kind(0.d0)) :: Ratio(N_FL), Ratiotot, Z1
Integer :: ns_new, ns_old, n,m,nf, i
Integer :: ns_new, ns_old, n,m,nf, i, rep
Complex (Kind=Kind(0.d0)) :: Z, D_mat, myexp, s1, s2, tmpz
Real (Kind=Kind(0.d0)) :: Weight
......@@ -65,12 +65,13 @@
Complex (Kind=Kind(0.D0)), Dimension(:, :), Allocatable :: Zarr, grarr
Complex (Kind=Kind(0.D0)), Dimension(:), Allocatable :: sxv, syu
if ( abs(OP_V(n_op,1)%g) < 1.D-6 ) return
rep = 1
if( DBLE(splits(chosensplitting)%Vcoeffs(pkg)) < 0 ) rep = 2
if ( abs(OP_V(n_op,1, rep)%g) < 1.D-6 ) return
! Compute the ratio
nf = 1
ns_old = nsigma(n_op,nt, pkg)
If ( Op_V(n_op,nf)%type == 1) then
If ( Op_V(n_op,nf, rep)%type == 1) then
if ( Propose_S0 ) then
Weight = 1.d0 - 1.d0/(1.d0+S0(n_op,nt, pkg))
If ( Weight < ranf_wrap() ) Return
......@@ -80,14 +81,14 @@
ns_new = flipspin(ns_old) !NFLIPL(Ns_old,nranf(3))
endif
Do nf = 1,N_FL
tmpz = sqrt(splits(chosensplitting)%Vcoeffs(pkg)) * Op_V(n_op,nf)%g
Z1 = tmpz * (Phi(ns_new,Op_V(n_op,nf)%type) - Phi(ns_old,Op_V(n_op,nf)%type))
Do m = 1,Op_V(n_op,nf)%N_non_zero
myexp = exp( Z1* Op_V(n_op,nf)%E(m) )
tmpz = sqrt(splits(chosensplitting)%Vcoeffs(pkg)) * Op_V(n_op,nf, rep)%g
Z1 = tmpz * (Phi(ns_new,Op_V(n_op,nf, rep)%type) - Phi(ns_old,Op_V(n_op,nf, rep)%type))
Do m = 1,Op_V(n_op,nf, rep)%N_non_zero
myexp = exp( Z1* Op_V(n_op,nf, rep)%E(m) )
Z = myexp - 1.d0
Delta(m,nf) = Z
do n = 1,Op_V(n_op,nf)%N_non_zero
Mat(n,m) = - Z * GR( Op_V(n_op,nf)%P(n), Op_V(n_op,nf)%P(m),nf )
do n = 1,Op_V(n_op,nf, rep)%N_non_zero
Mat(n,m) = - Z * GR( Op_V(n_op,nf, rep)%P(n), Op_V(n_op,nf, rep)%P(m),nf )
Enddo
Mat(m,m) = myexp + Mat(m,m)
Enddo
......@@ -105,12 +106,12 @@
else
D_mat = Det(Mat,Size(Mat,1))
endif
Ratio(nf) = D_Mat * exp( Z1*Op_V(n_op,nf)%alpha )
Ratio(nf) = D_Mat * exp( Z1*Op_V(n_op,nf, rep)%alpha )
Enddo
Ratiotot = Product(Ratio)
nf = 1
Ratiotot = (Ratiotot**dble(N_SUN)) * Gaml(ns_new, Op_V(n_op,nf)%type)/Gaml(ns_old, Op_V(n_op,nf)%type)
Ratiotot = (Ratiotot**dble(N_SUN)) * Gaml(ns_new, Op_V(n_op,nf, rep)%type)/Gaml(ns_old, Op_V(n_op,nf, rep)%type)
if ( .not. Propose_S0 ) &
& Ratiotot = Ratiotot * real(S0(n_op,nt, pkg), kind(0.D0)) ! Just to be safe since S0 seems to be user supplied
......@@ -129,23 +130,23 @@
beta = 0.D0
call zlaset('N', Ndim, Op_dim, beta, beta, u, size(u, 1))
call zlaset('N', Ndim, Op_dim, beta, beta, v, size(v, 1))
do n = 1,Op_V(n_op,nf)%N_non_zero
u( Op_V(n_op,nf)%P(n), n) = Delta(n,nf)
do n = 1,Op_V(n_op,nf, rep)%N_non_zero
u( Op_V(n_op,nf, rep)%P(n), n) = Delta(n,nf)
do i = 1,Ndim
v(i,n) = - GR( Op_V(n_op,nf)%P(n), i, nf )
v(i,n) = - GR( Op_V(n_op,nf, rep)%P(n), i, nf )
enddo
v(Op_V(n_op,nf)%P(n), n) = 1.d0 - GR( Op_V(n_op,nf)%P(n), Op_V(n_op,nf)%P(n), nf)
v(Op_V(n_op,nf, rep)%P(n), n) = 1.d0 - GR( Op_V(n_op,nf, rep)%P(n), Op_V(n_op,nf, rep)%P(n), nf)
enddo
call zlaset('N', Ndim, Op_dim, beta, beta, x_v, size(x_v, 1))
call zlaset('N', Ndim, Op_dim, beta, beta, y_v, size(y_v, 1))
i = Op_V(n_op,nf)%P(1)
i = Op_V(n_op,nf, rep)%P(1)
x_v(i, 1) = u(i, 1)/(1.d0 + v(i,1)*u(i,1) )
call zcopy(Ndim, v(:, 1), 1, y_v(:, 1), 1)
do n = 2,Op_V(n_op,nf)%N_non_zero
do n = 2,Op_V(n_op,nf, rep)%N_non_zero
call zcopy(Ndim, u(:, n), 1, x_v(:, n), 1)
call zcopy(Ndim, v(:, n), 1, y_v(:, n), 1)
Z = 1.d0 + u( Op_V(n_op,nf)%P(n), n)*v(Op_V(n_op,nf)%P(n),n)
Z = 1.d0 + u( Op_V(n_op,nf, rep)%P(n), n)*v(Op_V(n_op,nf, rep)%P(n), n)
alpha = -1.D0
Allocate(syu(n), sxv(n))
call zgemv('T', NDim, n-1, alpha, y_v, Ndim, u(1,n), 1, beta , syu, 1)
......@@ -161,8 +162,8 @@
Deallocate(syu, sxv)
enddo
Allocate (Zarr(Op_dim,Op_dim), grarr(NDim, Op_dim))
Zarr = x_v(Op_V(n_op,nf)%P, :)
grarr = gr(:, Op_V(n_op,nf)%P, nf)
Zarr = x_v(Op_V(n_op, nf, rep)%P, :)
grarr = gr(:, Op_V(n_op, nf, rep)%P, nf)
alpha = 1.D0
CALL ZGEMM('N', 'N', NDim, Op_Dim, Op_Dim, alpha, grarr, size(grarr,1), Zarr, size(Zarr,1), beta, xp_v, size(xp_v,1))
Deallocate(Zarr, grarr)
......
......@@ -67,26 +67,28 @@
! Local
Complex (Kind=Kind(0.d0)) :: Mat_TMP(Ndim,Ndim)
Integer :: nf, N_Type, n, pkg
Integer :: nf, N_Type, n, pkg, rep
Complex (Kind=Kind(0.d0)) :: spin
do pkg = 1, splits(chosensplitting)%nrPkgs
if (pkg <= splits(chosensplitting)%nrVstages) then
rep = 1
if(DBLE(splits(chosensplitting)%Vcoeffs(pkg)) < 0 ) rep = 2
Do n = size(Op_V,1), 1, -1
N_type = 2
nf = 1
spin = sqrt(splits(chosensplitting)%Vcoeffs(pkg)) * Phi(nsigma(n,ntau, pkg),Op_V(n,nf)%type)
spin = sqrt(splits(chosensplitting)%Vcoeffs(pkg)) * Phi(nsigma(n,ntau, pkg),Op_V(n,nf, rep)%type)
do nf = 1,N_FL
Call Op_Wrapdo( Gr(:,:,nf), Op_V(n,nf), spin, Ndim, N_Type)
Call Op_Wrapdo( Gr(:,:,nf), Op_V(n,nf, rep), spin, Ndim, N_Type)
enddo
!Write(6,*) 'Upgrade : ', ntau,n
Call upgrade(GR,n,ntau, pkg, PHASE,Op_V(n,1)%N_non_zero)
Call upgrade(GR,n,ntau, pkg, PHASE, Op_V(n,1, rep)%N_non_zero)
! The spin has changed after the upgrade!
nf = 1
spin = sqrt(splits(chosensplitting)%Vcoeffs(pkg)) * Phi(nsigma(n,ntau, pkg),Op_V(n,nf)%type)
spin = sqrt(splits(chosensplitting)%Vcoeffs(pkg)) * Phi(nsigma(n,ntau, pkg),Op_V(n,nf, rep)%type)
N_type = 1
do nf = 1,N_FL
Call Op_Wrapdo( Gr(:,:,nf), Op_V(n,nf), spin, Ndim, N_Type )
Call Op_Wrapdo( Gr(:,:,nf), Op_V(n,nf, rep), spin, Ndim, N_Type)
enddo
enddo
endif
......
......@@ -65,7 +65,7 @@
INTEGER, INTENT(IN) :: NTAU
!Local
Integer :: nf, N_Type, NTAU1, n, pkg
Integer :: nf, N_Type, NTAU1, n, pkg, rep
Complex (Kind=Kind(0.d0)) :: Mat_TMP(Ndim,Ndim)
Complex (Kind=Kind(0.d0)) :: spin
......@@ -79,17 +79,19 @@
!CALL MMULT ( GR(:,:,nf), MAT_TMP , Exp_T_M1(:,:,nf) )
Enddo
if (pkg <= splits(chosensplitting)%nrVstages) then
rep = 1
if (DBLE(splits(chosensplitting)%Vcoeffs(pkg)) < 0) rep = 2
Do n = 1,Size(Op_V,1)
Do nf = 1, N_FL
spin = sqrt(splits(chosensplitting)%Vcoeffs(pkg)) * Phi(nsigma(n,ntau1, pkg),Op_V(n,nf)%type)
spin = sqrt(splits(chosensplitting)%Vcoeffs(pkg)) * Phi(nsigma(n,ntau1, pkg),Op_V(n,nf, rep)%type)
N_type = 1
Call Op_Wrapup(Gr(:,:,nf),Op_V(n,nf), spin,Ndim,N_Type)
Call Op_Wrapup(Gr(:,:,nf), Op_V(n,nf, rep), spin,Ndim,N_Type)
enddo
nf = 1
Call Upgrade(GR,N,ntau1, pkg, PHASE,Op_V(n,nf)%N_non_Zero)
Call Upgrade(GR,N,ntau1, pkg, PHASE,Op_V(n,nf, rep)%N_non_Zero)
do nf = 1, N_FL
N_type = 2
Call Op_Wrapup(Gr(:,:,nf),Op_V(n,nf), spin,Ndim,N_Type)
Call Op_Wrapup(Gr(:,:,nf),Op_V(n,nf, rep), spin,Ndim,N_Type)
enddo
Enddo
endif
......
......@@ -103,7 +103,7 @@
! Working space.
COMPLEX (Kind=Kind(0.d0)), allocatable, dimension(:, :) :: TMP, TMP1
COMPLEX (Kind=Kind(0.d0)) :: Z_ONE
Integer :: NT, NCON, n, nf, pkg
Integer :: NT, NCON, n, nf, pkg, rep
Complex (Kind=Kind(0.d0)) :: X
NCON = 0 ! Test for UDV :::: 0: Off, 1: On.
......@@ -114,9 +114,11 @@
DO NT = NTAU1, NTAU+1 , -1
do pkg = 1, splits(chosensplitting)%nrPkgs
if (pkg <= splits(chosensplitting)%nrVstages) then
rep = 1
if (DBLE(splits(chosensplitting)%Vcoeffs(pkg)) < 0) rep = 2
Do n = Size(Op_V,1),1,-1
X = sqrt(splits(chosensplitting)%Vcoeffs(pkg)) * Phi(nsigma(n,nt, pkg),Op_V(n,nf)%type)
Call Op_mmultL(TMP,Op_V(n,nf),X,Ndim)
X = sqrt(splits(chosensplitting)%Vcoeffs(pkg)) * Phi(nsigma(n,nt, pkg),Op_V(n,nf, rep)%type)
Call Op_mmultL(TMP, Op_V(n,nf,rep), X, Ndim)
enddo ! n
endif
!CALL MMULT( TMP1,Tmp,Exp_T(:,:,nf) )
......
......@@ -101,7 +101,7 @@
! Working space.
Complex (Kind=Kind(0.d0)) :: Z_ONE
COMPLEX (Kind=Kind(0.d0)), allocatable, dimension(:, :) :: TMP, TMP1
Integer :: NT, NCON, n, nf, pkg
Integer :: NT, NCON, n, nf, pkg, rep ! rep denotes representation: SU2-> 1 M_z -> 2
Complex (Kind=Kind(0.d0)) :: X
NCON = 0 ! Test for UDV :::: 0: Off, 1: On.
......@@ -115,9 +115,11 @@
Call Hop_mod_mmthr(TMP,TMP1,nf, pkg)
TMP = TMP1
if (pkg <= splits(chosensplitting)%nrVstages) then
rep = 1
if (DBLE(splits(chosensplitting)%Vcoeffs(pkg)) < 0) rep = 2
Do n = 1,Size(Op_V,1)
X = sqrt(splits(chosensplitting)%Vcoeffs(pkg)) * Phi(nsigma(n,nt, pkg),Op_V(n,nf)%type)
Call Op_mmultR(TMP,Op_V(n,nf),X,Ndim)
X = sqrt(splits(chosensplitting)%Vcoeffs(pkg)) * Phi(nsigma(n,nt, pkg),Op_V(n, nf, rep)%type)
Call Op_mmultR(TMP,Op_V(n,nf,rep),X,Ndim)
ENDDO ! n
endif
enddo ! pkg
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment