Qulib

Simple functions for doing quantum things.
Gabriel T. Landi

(QT^2) group

Contributors: Jader P. dos Santos, Artur Lacerda, Michael Kewming, Anthony Kiely, Steve Campbell, Giacomo Guarnieri, Marcelo Janovitch.

Print["Qulib is now Melt! Visit the new page at https://melt1.notion.site"]
Print["This version of qulib will remain available, but will no longer be updated."]

General purpose functions

Silly but useful functions

mf: visualizing matrices

(* Prints in matrix form but does not alter definition *)
Clear[mf];
mf[A_]:=(Print[MatrixForm@Chop@A];A)
mf::usage = "mf[A] will print the matrix in a pretty way using Mathematica's MatrixForm[] function. The printed version also chops any small numbers.";

Example usage

(* I normally use it like this *)
A = {{1,2},{3,4}}//mf;

ψ = (1/(Sqrt[2])){1,1}//mf;

(* But one can also use it as *)
A = {{1,2},{3,4}};
mf[A];

cf: FullSimplify assuming variables are real and positive

(* FullSimplifty + ComplexExpand (to get rid of "Conjugate"s) *)
Clear[cf];
(*cf[expr_]:=FullSimplify@ComplexExpand@expr;*)
cf[expr_]:=FullSimplify[expr,Thread[DeleteDuplicates@Cases[Normal@expr,_Symbol,∞]>0]]

cf::usage = "cf[expr] performs a FullSimplify on the expression, assuming that all symbols are real and positive.";

Example usage

(* Mathematica doesn't know when a symbol is real *)
x = {Cos[θ],Sin[θ]};
x\[Conjugate].x
FullSimplify[%]

x\[Conjugate].x//cf

(* The function does not always works the way it is intended to *)
Clear[x]
(Sqrt[Cos[x]])//cf

out: Outer products

(* Outer product |v⟩⟨u| between two vectors *)
(* Properly conjugates *)
Clear[out];
out[v_,u_]:=Outer[Times,v,Conjugate[u]];
out::usage = "Outer product: out[v,u] = |v⟩⟨u|";

Example usage

ψ = (1/(Sqrt[2])){1,I}//mf;
out[ψ,ψ]//mf;

(* The second argument is complex conjugated *)

ℂ: commutator

ℂ[A,B] = [A,B]
ℂ[A,B,-1] = {A,B} (anti-commutator)

(* ℂ writes as esc+dsC+esc *)
Clear[ℂ];
ℂ[A_,B_]:=A.B-B.A;
ℂ[A_,B_,ζ_]:=A.B-ζ B.A

ℂ::usage = "ℂ[A,B] = [A,B] = A.B-B.A. More generally ℂ[A,B,ζ] = A.B + ζ B.A. Use ζ = -1 for anti-commutator";

Example usage

A = {{1,2},{3,4}};
B = {{5,4},{3,2}};
ℂ[A,B]//mf;

ℂ[A,B,-1]//mf;

ChopCheck:  for checking the results of matrix calculations

(* Quick way of checking what are the distinct entries of a matrix or tensor *)
Clear[ChopCheck];
ChopCheck[A_,tol_:(10^(-10))]:=DeleteDuplicates@Flatten@Chop[A,tol]

ChopCheck::usage = "ChopCheck[A] gives 0 when the matrix is 0, to a tolerance of (10^(-10)). I usually do ChopCheck[A-B] whenever I want to check numerically that A = B";

Example usage

Verify that A = SΛS† indeed is the correct diagonalization of a matrix A.

A = (({{2, 1, 0}, {1, 5, -3}, {0, -3, 2.}}));
{Λ,S} = Eigsys[A]

A-S.DiagonalMatrix[Λ].S\[ConjugateTranspose]//ChopCheck

range, linspace and logspace

- range[] you specify the stepsize. 
- linspace[] you specify the number of points . 
- logspace[] is the same, but in logscale (base 10) .

linspace/logspace were copied from python/Matlab
range[] is exactly like the native Range[] function in Mathematica. See below for an explanation.

(* Use just like Range[] function *)
Clear[range];
range[xi_,xf_,df_:1]:=N@Rationalize@Range[xi,xf,df]; 
range::usage = "Same input/output as Range, but avoids a subtle floating point issue of the latter.";

(* Stolen from python/Matlab *)
Clear[linspace]
linspace[dd1_,dd2_,n_:100]:=With[{d1=N@dd1,d2=N@dd2},If[n==1,{d1},d1+(d2-d1)/(n-1) Range[0,n-1]]];
linspace::usage = "linspace[a,b,npts] yields npts linearly interpolated between a (inclusive) and b (inclusive).";

Clear[logspace];
logspace[dd1_,dd2_,n_:100]:=10^linspace[dd1,dd2,n];
logspace::usage = "Same as linspace, but in log scale. logscale[2,5,50] will give 50 pts between (10^2) and (10^5)";

Example usage

range[0,1,0.1]

range[0,3]

linspace[0,3,20]

logspace[0,10,10]

logspace[2,5,4]

logspace[2,5,6]

Reason for using range instead of Range

Mathematica's  Range[] function looks normal:

Range[0,1,0.1]

But actually it has weird floating point imprecisions.

Range[0,1,0.1]//InputForm

This may lead to weird things such as

Position[Range[0,1,0.1],0.6]

Position[Range[0,1,0.1],0.7]

It cannot find “0.7” in the list because the actual number is 0.7000000000000001 (although Mathematica is printing 0.7). 
This is super annoying. 

The function range corrects this:

range[0,1,0.1]//InputForm

PartitionIn: partition a list into x sublists, with proper paddings at the end

Clear[PartitionIn];
PartitionIn[list_,x_,pad_:""]:=Partition[list,Ceiling[Length[list]/x],Ceiling[Length[list]/x],1,pad]

PartitionIn::usage = "PartitionIn[list,x] partitions list into x sublists, possibly with paddings at the end.";

Example usage

Mathematica’s Partition[] splits a list into sublists of pre-defined lengths. 
But sometimes we want to partition a list into a pre-defined number of sublists instead, with possible paddings at the end.

list = Range[1,19]

Partition[list,3,3,1," "]

(* This splits the list into exactly 3 sublists *)
PartitionIn[list,3]

PrettyTiming: Prints time in a pretty way

AbsoluteTiming[] with pretty formatting.

Clear[PrettyTiming];
SetAttributes[PrettyTiming,HoldAll];
PrettyTiming[computation_]:=Module[{t1,t2,output,time,h,m,s},
t1 = UnixTime[];
output=ReleaseHold[computation];
t2 = UnixTime[];
time = t2-t1;
 h = Floor[time/3600];
m = Floor[Mod[time,3600]/60];
s = Round@Mod[time,60];
Print[ToString[h]<>"h : "<>ToString[m]<>"m : "<>ToString[s]<>"s"];
(*Print[PrettyTime[t2-t1]];*)
Return[output]];

PrettyTiming::usage = "PrettyTiming[computation] uses Mathematica's AbsoluteTiming[] to time a computation, but prints the result in a prettier form.";

Example usage

(* This is how one would time a computation in Mathematica *)
AbsoluteTiming[Do[1,{(10^9)}]]

(* PrettyTiming does the same, but prints the time (instead of outputing it) and does so with a pretty format *)
PrettyTiming[Do[1,{5 (10^8)}]]

(* Time a calculation of the variance of random variables *)

PrettyTiming[Variance@RandomVariate[BetaDistribution[2,3],(10^8)]]

do & table with Progress Monitor and Timing

Usage is exactly like Do[] & Table[]
But prints progress, as well as times the entire process.

Clear[do];
SetAttributes[do,HoldAll];
do[computation_,iterators__]:=Module[{iters = {iterators}[[All,1]],symb,list,i,d },
symb = ToString/@iters;
d=Length@symb;
list = Flatten[Table[iters,iterators],Length[iters]-1];

PrettyTiming@Monitor[Do[computation,iterators],
Check[
StringJoin@Table[{symb[[i]]," = ", ToString@StandardForm[iters[[i]]],"\n"},{i,d}]
ProgressIndicator[Position[list,Table[iters[[i]],{i,d}]][[1,1]],{1,Length@list}]
," "]
]
]

Clear[table];
SetAttributes[table,HoldAll];
table[computation_,iterators__]:=Module[{iters = {iterators}[[All,1]],symb,list,i,d },
symb = ToString/@iters;
d=Length@symb;
list = Flatten[Table[iters,iterators],Length[iters]-1];

PrettyTiming@Monitor[Table[computation,iterators],
Check[
StringJoin@Table[{symb[[i]]," = ", ToString@StandardForm[iters[[i]]],"\n"},{i,d}]
ProgressIndicator[Position[list,Table[iters[[i]],{i,d}]][[1,1]],{1,Length@list}]
," "]
]
]

Examples

do[ Pause[0.2],{i,10},{j,20}]

table[ Pause[0.4];i+j,{i,5},{j,5}]

Simulated driven qubit dynamics for several initial conditions.
Compute populations at final time t = 10

Clear[H,θs,ψ,ψ0];
H[t_]:= (1/2)σz + Cos[t] σx
θs = linspace[0,π,20];
pops=table[
ψ0 = {Cos[θ],Sin[θ]};
((Abs[UnitaryDynamics[H,0.005,50,ψ0,True] [[2]]])^2)
,{θ,θs}]

Use do if you want to store the results (e.g. in an Association)

pops = Association[];
do[
ψ0 = {Cos[θ],Sin[θ]};
pops[θ]=((Abs[UnitaryDynamics[H,0.005,50,ψ0,True] [[2]]])^2)
,{θ,θs}]

pops

Benchmark with Mathematica’s built-in Table: no penalty in execution speed.

AbsoluteTiming[Table[
ψ0 = {Cos[θ],Sin[θ]};
((Abs[UnitaryDynamics[H,0.005,50,ψ0,True] [[2]]])^2)
,{θ,θs}];]

nest and nestList with monitor

Taken from https://mathematica.stackexchange.com/questions/132003/progress-indicator-for-nestlist

Clear[nest];
nest[f_,init_,n_]:=Module[{it=0},PrintTemporary[ProgressIndicator[Dynamic[it/n]] Dynamic[ToString@Round[ 100 it/n]<>"%"]];
Nest[(it++;f[#])&,init,n]]

Clear[nestList];
nestList[f_,init_,n_]:=Module[{it=0},PrintTemporary[ProgressIndicator[Dynamic[it/n]] Dynamic[ToString@Round[ 100 it/n]<>"%"]];
NestList[(it++;f[#])&,init,n]]

Examples

Clear[f];
f[x_]:=(Pause[1];x+1);
nestListWithMonitor[f,1,5]

makeGIF

Syntax is similar to Animate[], but exports the animation as a GIF. 
But there are 2 additional arguments: filename and the desired duration (in seconds)
Default fps = 20, but can be changed by passing an additional argument.

File is exported to the default directory, which can be located by typing “Directory[]”
If you want to set the directory to be the same as our notebook directory, type “Set Directory[NotebookDirectory[]]”

Clear[makeGIF];
SetAttributes[makeGIF,HoldAll];
makeGIF[thing_,iterator_,filename_,duration_,fps_:20]:=Module[{ i0,if,Δ,δ,frames,numberOfframes},

numberOfframes = duration fps;
i0 = iterator[[2]];
if = iterator[[3]];
δ = If[Length@iterator==4,iterator[[4]],1];
Δ =  (((if-i0))/numberOfframes) ;   
If[IntegerQ[δ],Δ=Ceiling[Δ]];

If[Length@iterator==3,
frames = table[thing,Evaluate@Append[iterator, Δ]],
frames = table[thing,Evaluate@ReplacePart[iterator,4-> Δ]]
];
If[Length@frames < 0.8 numberOfframes,
Print["Could not match the desired framerate & duration. Reducing framerate to "<>ToString[((((duration/(Length@frames))))^(-1))//Round]<>" fps"];
Print["Requires a longer list"]
];

Print["Exporting "<>filename<>".gif (can take a while...)"];
Export[filename <>".gif",frames,"DisplayDurations"->(duration/(Length@frames))] ;
Animate[frames[[i]],{i,1,Length@frames,1}]
]

Example usage

Syntax is similar to Animate

Animate[Plot[Sin[a+x],{x,0,10}],{a,0,10}]

makeGIF[Plot[Sin[a+x],{x,0,10}],{a,0,10,1.},"myGIF",10]

Linear algebra

kron: compact Kronecker products which correctly handles vectors

Mathematica’s KroneckerProduct handles vectors in a weird way.

Clear[kron];
kron[mats__?MatrixQ]:=KroneckerProduct[mats];
kron[vecs__?VectorQ]:=Flatten@KroneckerProduct[vecs];

kron::usage ="kron[A,B,C...] = A ⊗ B ⊗ C ⊗ .... For matrices, it is exactly like the native KroneckerProduct[] from Mathematica. For vectors, kron[u,v] produces the proper |u⟩ ⊗ |v⟩."

(* 𝕀 ⊗ 𝕀 ⊗ 𝕀 ⊗ 𝕀 ⊗ A ⊗ 𝕀 ⊗ 𝕀 ⊗ 𝕀 ⊗ 𝕀 *)

Clear[KronEye];
KronEye[A_,𝒩_,j_]:=kron[Eye[((Length[A])^(j-1))],A,Eye[((Length[A])^(𝒩-j))]]

KronEye::usage = "KronEye[A,𝒩,j] = (𝕀 ⊗ ... 𝕀 ⊗ A ⊗ 𝕀 ... ⊗ 𝕀, with A at site j and 𝒩 sites in total.";

Example usage

(* For matrices, kron[A,B] is just a compact notation of KroneckerProduct[A,B] *)
A = {{1,2},{3,4}};
B = {{0,1},{1,0}};
kron[A,B]//mf;

kron[A,A,A]//mf;

(* For vectors, Mathematica is weirrrd *)

v0 = {1,0};
v1 = {0,1};
KroneckerProduct[v0,v1]//mf;

(* kron[] saves the day *)
kron[v0,v1]//mf;

(* Pauli matrix for site 2 of a spin chain with 4 sites *)
σx = (({{0, 1}, {1, 0}}));
KronEye[σx,4,2]//mf;

Proj & Basis: projection matrices and basis elements

Clear[Proj];
Proj[n_,i_]:=SparseArray[{{i,i}->1},{n,n}];
Proj[n_,i_,j_]:=SparseArray[{{i,j}->1},{n,n}];

Proj[{n_,m_},i_]:=SparseArray[{{i,i}->1},{n,m}];
Proj[{n_,m_},i_,j_]:=SparseArray[{{i,j}->1},{n,m}];


Proj::usage = "Proj[n,i,j] yields a n×n matrix with element (i,j) equal 1. Proj[n,i] = Proj[n,i,i].";

Clear[Basis];
Basis[n_,i_]:=SparseArray[{i->1},n]
Basis[n_,ilist_?ArrayQ]:=Total@Table[Basis[n,i],{i,ilist}]

Basis::usage = "Basis[n,i] = (0,...,0,1,0,...,0) with 1 at position i. Basis[n,{i1,i2,...}] yields the same, but with 1's at positions i1,i2,...";

Example usage

Proj[4,1]//mf;

Proj[4,2]//mf;

Proj[4,1,2]//mf;

Basis[4,1]//mf;

Basis[4,2]//mf;

Basis[4,{1,2}]//mf;

Useful matrices

Eye  = Identity for symbolics. 
NEye = Identity for numerics. 

toeplitzMatrix = just a toeplitz matrix, with a more flexible syntax than Mathematica’s ToeplitzMatrix[]. 
StiffnessMatrix =hopping matrix of the tight-binding model.
CirculantMatrix = same, but with periodic boundary conditions.

Clear[Eye,NEye];
Eye[n_]:=SparseArray[{{i_,i_}->1},{n,n}];
Eye::usage = "Eye[n] is the n×n identity matrix as a sparse array. Same as NEye, but the 1s in the diagonal are integers";

NEye[n_]:=SparseArray[{{i_,i_}->1.},{n,n},0.];
Eye::usage = "NEye[n] is the n×n identity matrix as a sparse array. Same as Eye, but the 1.0s in the diagonal are in floating point.";

Clear[toeplitzMatrix];
toeplitzMatrix[a_,k_,L_]:=If[L==1,If[k==1,{{a}},{{0}}],SparseArray[{Band[{1,k}]->a,Band[{k,1}]->a},{L,L}]]

toeplitzMatrix::usage = "toeplitzMatrix[a,k,L] yields a L×L symmetric matrix with elements a along the kth diagonal (k=1 is the diagonal and k=2 is the first off-diagonal).";

Clear[StiffnessMatrix,CirculantMatrix];
StiffnessMatrix[n_]:=toeplitzMatrix[-1,2,n];
CirculantMatrix[n_]:=toeplitzMatrix[-1,2,n]+toeplitzMatrix[-1,-1,n];

StiffnessMatrix::usage = "StiffnessMatrix[n]: hopping matrix of the tight-binding model with open boundary conditions";
CirculantMatrix::usage = "CirculantMatrix[n]: hopping matrix of the tight-binding model with periodic boundary conditions";

Clear[FirstDerivative];
FirstDerivative[n_,Δx_:1,boundary_:None]:=
If[boundary===None,
(1/(2Δx))SparseArray[{
Band[{1,2}]->1,
Band[{2,1}]->-1
},{n,n}],
(1/(2Δx))SparseArray[{
{i_,j_}/;j==i+1&&i!=1->1,
{i_,j_}/;j==i-1&&i!=n->-1,
{1,2}->2,
{1,1}->-2,
{n,n}->2,
{n,n-1}->-2
},{n,n}]];

Clear[SecondDerivative]
SecondDerivative[n_,Δx_:1,boundary_:None]:=
If[boundary===None,
(1/((Δx)^2))(2Eye[n]+StiffnessMatrix[n])]

Example usage:

Eye[3]//mf;

(* The distinction is silly, but for doing numerics it is useful to use NEye *)
NEye[3]//mf;

toeplitzMatrix[a,1,5]//mf;

toeplitzMatrix[a,2,5]//mf;

(* Also works with 1D matrices *)
toeplitzMatrix[a,1,1]

StiffnessMatrix[6]//mf;

CirculantMatrix[6]//mf;

Boxcar function

A unit box from a to b:
Width b-a := 2δ, centered at c = (a+b)/2

Boxcar(a,b) = θ(x-a)θ(b-x)
	        = θ(x-a) - θ(x-b)
                  = π((1/(2δ))(x-c)
                  = θ((δ^2)-(((x-c))^2))

Here θ = HeavisideTheta and π = HeavisidePi

Clear[Boxcar];
Boxcar[a_,b_][x_]:=UnitStep[x-a]-UnitStep[x-b]

Boxcar[a_,b_,smooth_][x_]:=If[Abs[smooth]<(10^(-14)),Boxcar[a,b][x],(1/2)(Tanh[((x-a)/smooth)]-Tanh[((x-b)/smooth)] )]

Boxcar::usage = "Boxcar[a,b][x] returns a boxcar function from a to b";

Example usage

Plot[Boxcar[3,7][x],{x,2,8},Exclusions->None]

(* Different ways of implementing a boxcar, centered in c, of total width δ *)
c = 2;
δ = 0.15;
a = c-δ;
b = c+δ;
Plot[{
HeavisideTheta[x-a]-HeavisideTheta[x-b],
HeavisideTheta[x-a]HeavisideTheta[b-x],
HeavisidePi[(1/(2δ))(x-c)],
HeavisideTheta[(δ^2)-(((x-c))^2)]
},{x,1,3},Exclusions->None,PlotStyle->Automatic]

Manipulate[Plot[Boxcar[a,b,smooth][x],{x,-2,2}],{{a,0},-1,1},{{b,1},0,2},{{smooth,0.1},0.01,0.2}]

Eigstuff & Ground-state: sorts eigenvalues and correctly orders eigenvectors

This function “fixes” some weird outputs of Mathematica’s eigensystem functions. 
- Order eigenvalues by smaller in number, not magnitude: 1st eigenvalue is ground-state. 
- Output eigenvectors as a matrix, not a list of lists.

Clear[Eigvals,Eigvecs,Eigsys];

(*Eigvals[A_,neigs_:"all",Δ_:(10^5)]:=Reverse@Eigenvalues[A + Δ NEye@Length@A,If[neigs=="all",Length@A,-neigs]]-Δ;*)
Eigvals[A_,neigs_:"all",Δ_:(10^5)]:=If[neigs==="all",
Sort@Eigenvalues[N@A],
Reverse@Eigenvalues[A + Δ NEye@Length@A,-neigs]-Δ];

(*Eigvecs[A_,neigs_:"all",Δ_:(10^5)]:=Transpose[(Reverse@Eigenvectors[A + Δ NEye@Length@A,If[neigs=="all",Length@A,-neigs]])];*)
Eigvecs[A_,neigs_:"all",Δ_:(10^5)]:=
Module[{tmp,e,v,ord},
If[neigs=="all",(
{e,v}=Eigensystem[A];
ord=Ordering[e];
Transpose[v[[ord]]]
),
(
{e,v}=Eigensystem[A + Δ NEye@Length@A,-neigs];
 Transpose@Reverse@v
)
]
]

(*Eigsys[A_, neigs_:"all",Δ_:(10^5)]:=Module[{tmp},
tmp=Eigensystem[A + Δ NEye@Length@A,If[neigs=="all",Length@A,-neigs]];
 {Reverse@First@tmp-Δ,Transpose@Reverse@Last@tmp}
];*)

Clear[Eigsys];
Eigsys[A_, neigs_:"all",Δ_:(10^5)]:=Module[{tmp,e,v,ord},

If[neigs=="all",(
{e,v}=Eigensystem[A];
ord=Ordering[e];
{e[[ord]],Transpose[v[[ord]]]}
),
(
{e,v}=Eigensystem[A + Δ NEye@Length@A,-neigs];
 {Reverse@e-Δ,Transpose@Reverse@v}
)
]
]

Clear[GroundState];
GroundState[H_]:=Eigvecs[H,1][[All,1]]

GroundState[H_,n_]:=Eigvecs[H,n][[All,-1]];

Example usage

(* Eigenvalues of a spin 3/2 Hamiltonian *)
LoadArbitrarySpinMatrices[3/2];
H = Sz + 0.3 Sx.Sx//mf;

(* Mathematica orders eigenvalues by magnitude. The ground-state in this case is actually -1.30398 *)
Eigenvalues[H]

(* Eigvals order in the natural way *)
Eigvals[H]

(* Suppose one wishes only the first two eigenvalues. Here is what Mathematica yields: *)
Eigenvalues[H,2]

(* The ordering is weird because it is ordered by absolute value. For Eigvals the ordering is consistent with ground states: *)
Eigvals[H,2]

(* Diagonalization is traditionally written as H = S.ℰ.(S^(-1)), with eigenvectors being the columns of S. *)
(* Mathematica returns eigenvectors as the rows *)

{ℰ,S}=Eigensystem[H];
S\[Transpose].DiagonalMatrix[ℰ].Inverse[S\[Transpose]]//mf;

(* Eigsys and Eigvecs return eigenvectors as the columns of S *)
{ℰ,S}=Eigsys[H];
S.DiagonalMatrix[ℰ].S\[ConjugateTranspose]//mf;

S

Eigvecs[H]

expect: operator average ⟨O⟩, handling pure and mixed states in equal footing

(* y can be a ket or a density matrix *)
Clear[expect];
expect[A_,y_]:=If[Length@Dimensions@y==2,Tr[A.y],y\[Conjugate].A.y];

expect::usage = "expect[A,y] computes ⟨A⟩ in the state y, which can be either a ket or a density matrix";

(* Checks if H commutes with y, and y can be a pure state *)
Clear[checkCommute]
checkCommute[H_,y_]:=Module[{ρ},
ρ = If[Length@Dimensions@y==2,y,Outer[Times,y,Conjugate[y]]];
If[Norm[H.ρ-ρ.H]>(10^(-10)),False,True]
]

Example usage

ψ = (1/(Sqrt[2])){1,1};
expect[σx,ψ]

(* Or use a density matrix *)
ρ = out[ψ,ψ];
expect[σx,ρ]

DirectSum

Clear[DirectSum]
DirectSum[mats__]:=Module[{m=List@mats,tab, diag,a},
tab= Table[a[i],{i,Length@m}];
diag=DiagonalMatrix[Table[a[i],{i,Length@m}]];
diag/.Thread[tab->m]//ArrayFlatten
]

DirectSum::usage = "DirectSum[A,B,...] yields a diagonal block matrix diag(A,B,...)";

Example usage

LoadPauliMatrices[]
DirectSum[σx,σz]//mf;

DirectSum[σx,σy,σz]//mf;

Alternative implementation from klgr in StackExchange

Based on https://mathematica.stackexchange.com/questions/19778/how-to-form-a-block-diagonal-matrix-from-a-list-of-matrices/19780#19780

DirectSum2=With[{r=MapIndexed[#2[[1]] {1,1}->#&,#,1]},SparseArray`SparseBlockMatrix[r]]&;

DirectSum2[{σx,σy,σz}]//mf;

KPM: Kernel Polynomial Method

https://journals.aps.org/rmp/abstract/10.1103/RevModPhys.78.275
https://journals.aps.org/prl/pdf/10.1103/PhysRevLett.124.100602


This is an approximate method to compute general spectral functions of the form 

g(E,O)=(∑_( k)) δ(E-(Subscript[E, k])) ⟨k|O|k⟩

where O is an observable and H|k⟩ = (Subscript[E, k])|k⟩ are eigenvalues/eigenvectors of a certain Hamiltonian H.
Examples: 

Global DOS:  g(E) = (∑_( k))δ(E-(Subscript[E, k])).  Simply use O = 1
Local  DOS/work distribution : |ψ(E)((|)^2) = (∑_( k)) δ(E-(Subscript[E, k])) |⟨(Subscript[E, k])|ψ⟩((|)^2) . Use O=|ψ⟩⟨ψ|

The KPM method approximates g(E,O).
We must first rescale the Hamiltonian so that the spectrum lies in [-1,1]

(OverTilde[H]) = 

g(E,O) ≈ (1/(π(Sqrt[1-(E^2)])))((Subscript[g, 0])(Subscript[μ, 0])+2 (∑_( m=1)^( N)) (Subscript[g, m])(Subscript[μ, m])(Subscript[T, m])(E))

where (Subscript[T, m])(x) are Chebyshev polynomials, 

(Subscript[g, m ])= (((N-m+1) cos(((π m)/(N+1))) + sin(((π m)/(N+1))) cot((π/(N+1))))/(N+1))  
is the Jackson smoothing Kernel (Eq. (71) of the RMP above)

and 

(Subscript[μ, m]) = ∫ dE g(E,O) (Subscript[T, m])(E) = (1/ν)tr{(Subscript[T, m])(H) O}

Solve[{a e1+b==-1,a ed+b==1},{a,b}]//Simplify

Clear[RescaleHamiltonian];
RescaleHamiltonian[H_]:=Module[{e1,ed},
e1 = Eigvals[H,1][[1]];
ed = Eigvals[H,-1][[1]];

{e1,ed,((e1+ed)/(e1-ed))Eye[Length@H] + ((2 H)/(ed-e1)) }
]

Clear[KPM,KPMfunc];
KPM[H_,Mcheb_,R_,𝒪_:"1"]:=Module[{h,𝕆,gs,rs,νs,μs,e1,ed,d=Length@H},
{e1,ed,h}=RescaleHamiltonian[H];

gs = Table[(1/(Mcheb+1))((Mcheb-m+1)Cos[((π m)/(Mcheb+1.))] + Sin[((π m)/(Mcheb+1))] Cot[(π/(Mcheb+1))] ),{m,0,Mcheb}]; 

𝕆 = SparseArray@If[𝒪 ==="1",Eye[d],𝒪];

rs = Normalize/@(RandomVariate[NormalDistribution[0,1],{R,d}]+I RandomVariate[NormalDistribution[0,1],{R,d}]);
νs = Table[With[{v01= {r,h.r}},NestList[{#[[2]],2 h.#[[2]]-#[[1]]}&,v01,Mcheb][[All,2]]],{r,rs}] ;
μs = Prepend[Table[(d/R)Total@Table[rs[[i]]\[Conjugate].𝕆.νs[[i,m]],{i,Length@rs}],{m,1,Mcheb}],1]; 

{e1,ed,gs,μs}
]

KPMfunc[{e1_,ed_,gs_,μs_},ℰ_]:=With[{ϵ=((e1+ed)/(e1-ed)) + ((2 ℰ)/(ed-e1))}, (1/(π(Sqrt[1-(ϵ^2)])))(gs[[1]] μs[[1]] + 2 Total@Table[gs[[m+1]] μs[[m+1]] ChebyshevT[m,ϵ],{m,1,Length@μs-1}])]

Example usage

h = TightBindingHamiltonian[10];
dos = With[{ϵs = Eigvals[h],σ=0.03},Total@Table[(1/(Sqrt[2π (σ^2)]))Exp[((-(((ϵ-ϵs[[i]]))^2))/(2(σ^2)))],{i,Length@ϵs}]];
kpm=KPM[h,100,25];
kpm[[1;;2]]

Plot[{Re@KPMfunc[kpm,ϵ],dos},{ϵ,-0.9,2.8}]//Quiet

Random approximations to the trace

RandomTraceApproximation[R_,H_]:=Module[{rs},
rs = RandomVariate[NormalDistribution[0,1],{R,Length@H}]+I RandomVariate[NormalDistribution[0,1],{R,Length@H}];

{Tr[H],((Length@H)/R)Total@Table[((r\[Conjugate].H.r)/(r\[Conjugate].r)),{r,rs}]}//Chop

]

h = RandomReal[{-3,3},{7,7}];
h = h + h\[Transpose];
h = RescaleHamiltonian[h];
RandomTraceApproximation[100,h]

h = RandomReal[{-3,3},{7,7}];
h = h + h\[Transpose];
h = RescaleHamiltonian[h];
th = 2 MatrixPower[h,2]-Eye[Length@h];
RandomTraceApproximation[100,th]

Ex: XXZ with staggered field

Based on https://arxiv.org/pdf/2103.16601.pdf

Clear[Δ,h,H,ψ0,XXZstag]
LoadSpinChainMatrices[L=7];
Δ = 0.55;
h = 1.0;
a=2.0;
ω0 = 8.0;
XXZstag[Δ_,h_] :=Module[{H,e0},
H=Sum[sx[i].sx[i+1]+sy[i].sy[i+1] + Δ sz[i].sz[i+1],{i,1,L-1}]+h Sum[sz[i],{i,1,L,2}];
e0 = Eigvals[H,1][[1]];
H-e0 NEye[Length@H]]

H = XXZstag[Δ,h];
ψ0 = Eigvecs[H,1]//Flatten;
f = Function[{t,ψ},-I (H + a Sin[ω0 t] sz[4]).ψ];
ψ=RK4t[f,ψ0,0.005,100 π/ω0][[-1,2]];

P = Module[{ϵ,v},
{ϵ,v} = Eigsys[H];
Table[{ϵ[[k]],((Abs[v[[All,k]]\[Conjugate].ψ])^2)},{k,Length@ϵ}]]//Quiet//Chop;

SeedRandom[1];
PrettyTiming[kpm0=KPM[H,200,1000,out[ψ,ψ]];
kpm[[1;;2]]]
PrettyTiming[kpm=KPM[H,220,1000,out[ψ,ψ]];
kpm[[1;;2]]]

Show[
ListPlot[Rest@P,Filling->Axis,PlotMarkers->Automatic,PlotStyle->Red,PlotRange->All],
Plot[0.03 Re@KPMfunc[kpm,ϵ],{ϵ,0.1,20}],
Plot[0.03 Re@KPMfunc[kpm0,ϵ],{ϵ,0.1,20},PlotStyle->Directive[green,Dashed,Opacity[0.5]]],
ImageSize->600
]

“Load” useful operators (Pauli matrices, fermionic and bosonic operators, &c.)

"Load" functions load into your system a set of matrices related to the problem at hand (qubits, fermions, bosons, etc.).

LoadPauliMatrices: Pauli matrices for a single qubit

Clear[LoadPauliMatrices];
LoadPauliMatrices[]:=Module[{},
Clear[σ0,σx,σy,σz,σp,σm,GMAT];
σ0 = {{1,0},{0,1}};
σx = {{0,1},{1,0}};
σy = {{0,-I},{I,0}};
σz = {{1,0},{0,-1}};
σp = {{0,1},{0,0}}(*(σx + I σy)/2*);
σm = {{0,0},{1,0}}(*(σx - I σy)/2*);
(*nn = σp.σm; *)

GMAT[θ_,ϕ_] := MatrixExp[-I ϕ σz/2].MatrixExp[-I θ σy/2];

"Matrices loaded: σ0 (=1), σx, σy, σz, σp, σm, GMAT[θ,ϕ]"
];

LoadPauliMatrices[]

Example usage

LoadPauliMatrices[]

σx//mf;

(* Matrix diagonalizing an arbitrary direction in Bloch's sphere *)
GMAT//mf;

GMAT\[ConjugateTranspose].GMAT//cf//mf;

sigmaN = Sin[θ] Cos[ϕ] σx + Sin[θ] Sin[ϕ] σy + Cos[θ] σz;
G\[ConjugateTranspose].sigmaN.G//cf//mf;

LoadSpinChainMatrices: Pauli matrices for a spin chain

Use LoadSpinChainMatrices[N,"a"] for symbolics

LoadSpinChainMatrices[𝒩_,type_:"n"]:=Module[{one,σ0,σx,σy,σz,σp,σm},

(* 2 x 2 Pauli matrices *)
one = If[type=="n",1.0,1];
σ0 = SparseArray[one{{1,0},{0,1}}];
σx = SparseArray[one{{0,1},{1,0}}];
σy = SparseArray[one{{0,-I},{I,0}}];
σz =SparseArray[ one{{1,0},{0,-1}}];
σp =(σx + I σy)/2;
σm = (σx - I σy)/2;

Clear[eye,sp,sm,sx,sy,sz,c,cd];
eye = one Eye[(2^𝒩)];

If[𝒩>1,
Do[
eyeL = one Eye[(2^(i-1))];
eyeR = one Eye[(2^(𝒩-i))];
(* Spin matrices of site i *)
sx[i] = kron[eyeL,σx,eyeR];
sy[i] = kron[eyeL,σy,eyeR];
sz[i] = kron[eyeL,σz,eyeR];
sp[i] = kron[eyeL,σp,eyeR];
sm[i] = sp[i]\[Transpose];

(* Fermionic operators using the Jordan Wigner transformation *)
c[i] = kron@@Join[Table[(-σz),{j,1,i-1}],{σm},Table[σ0,{j,i+1,𝒩}]];
cd[i] = c[i]\[ConjugateTranspose];

,{i,1,𝒩}],
(
sx[1] = σx;
sy[1] =σy;
sz[1] = σz;
sp[1] = σp;
sm[1] = σm;
c[1] = σm;
cd[1] = σp;)];

"Matrices loaded: σ0 (=1), σx, σy, σz, σp, σm, eye, sm, sp, sx, sy, sz, c, cd"

];

LoadFermionicOperators: Fermionic operators & majoranas

Majorana definitions: 

(Subscript[Γ, 2n-1]) = (Subscript[c, n])+(Subscript[c, n]^†)
(Subscript[Γ, 2n])     = i ((Subscript[c, n]^†)-(Subscript[c, n]))

{(Subscript[Γ, i]),(Subscript[Γ, j])} = 2 (Subscript[δ, ij])

Relation to fermionic operators: 

(Subscript[Γ, 1])(Subscript[Γ, 2])=-(Subscript[Γ, 2])(Subscript[Γ, 1]) = i(cc† - c†c)     ->    (Subscript[iΓ, 1])(Subscript[Γ, 2])=2 c†c -1    ->    c†c = (i/2)(Subscript[Γ, 1])(Subscript[Γ, 2])+(1/2)

For nearest neighbors: 

(Subscript[Γ, 2])(Subscript[Γ, 3]) = i ((Subscript[c, 1]^†)(Subscript[c, 2]^†)-(Subscript[c, 1])(Subscript[c, 2])) + i ((Subscript[c, 1]^†)(Subscript[c, 2])+(Subscript[c, 2]^†)(Subscript[c, 1]))  =  i (Subscript[σ, x]^1)(Subscript[σ, x]^2)

(Subscript[Γ, 1])(Subscript[Γ, 4]) = i ((Subscript[c, 1]^†)(Subscript[c, 2]^†)-(Subscript[c, 1])(Subscript[c, 2])) - i ((Subscript[c, 1]^†)(Subscript[c, 2])+(Subscript[c, 2]^†)(Subscript[c, 1]))  = -i (Subscript[σ, y]^1)(Subscript[σ, y]^2)

Thus

(Subscript[σ, x]^1)(Subscript[σ, x]^2)+(Subscript[σ, y]^1)(Subscript[σ, y]^2) = -i ((Subscript[Γ, 2])(Subscript[Γ, 3])-(Subscript[Γ, 1])(Subscript[Γ, 4]))

Clear[LoadFermionicOperators];
LoadFermionicOperators[𝒩_,ord_:"local",type_:"n"]:=Module[{},

LoadSpinChainMatrices[𝒩,type];
Clear[sp,sm,sx,sy,sz];
Clear[Γ];
If[ord=="local",
Do[
Γ[2n-1] = c[n] + cd[n];
Γ[2n]= I (cd[n]-c[n]),
{n,1,𝒩}],
Do[
Γ[n] = c[n] + cd[n];
Γ[𝒩+n]= I (cd[n]-c[n]),
{n,1,𝒩}]
];

Clear[sp,sm,sx,sy,sz];
"Matrices loaded: eye, c, cd, Γ"
]

Example usage

LoadSpinChainMatrices[3]

LoadedMatrices

σx//mf;

sx[1]//mf;

sx[2]//mf;

(* Fermionic operators *)
c[3]//mf;

(* Now there are no more floating points *)
LoadSpinChainMatrices[3,"a"]
sx[2]//mf;

LoadArbitrarySpinMatrices: Spin S operators

LoadArbitrarySpinMatrices[S_,type_:"n"]:=Module[{it,srange,tmp},

it=If[type=="a",1,1.0];
srange = Range[S,-S,-it];

Clear[Sz,Sp,Sm,Sx,Sy,S0];

Sz= SparseArray@DiagonalMatrix[srange];
Sp = SparseArray@Table[(Sqrt[(S-s)(S+s+1)])KroneckerDelta[r,s+1],{r,srange},{s,srange}];
Sm = Sp\[Transpose];
Sx = (Sp+Sm)/2;
Sy = (Sp-Sm)/(2I);

S0 =Eye[2S+1];


"Matrices loaded: S0 (=1), Sx, Sy, Sz, Sp, Sm"

];

Example usage

(* Spin 1 particle *)
LoadArbitrarySpinMatrices[1]

Sx//mf;

(* Spin 5/2 particle; symbolics *)
LoadArbitrarySpinMatrices[5/2,"a"]

Sx//mf;

LoadBosonicOperators: Bosonic operators

N is the size of the matrix: Fock space goes from |0⟩ to |N-1⟩.

LoadBosonicOperators[𝒩_,type_:"n"]:=Module[{one,tmp,n,m},
one = If[type=="a",1,1.0];
Clear[𝕀,a,X,P(*,CoherentState*)];
𝕀= Eye[𝒩];
a=one DiagonalMatrix[SparseArray[Table[(Sqrt[n]),{n,1,𝒩-1}]],1];
𝕏 = (1/(Sqrt[2]))(a\[ConjugateTranspose]+a);
ℙ = (I/(Sqrt[2]))(a\[ConjugateTranspose]-a);
CoherentState[α_]:=Exp[-((Abs[α])^2)/2] Table[((α^n)/(Sqrt[n!])),{n,0,𝒩-1}];
ThermalState[n0_]:=DiagonalMatrix@Table[(n0^n) (((1+n0))^(-1-n)),{n,0,𝒩-1}];
"Matrices loaded: 𝕀 (=1), a, 𝕏, ℙ, CoherentState[α], ThermalState[n0]"
]

Example usage

LoadBosonicOperators[10,"a"]

a//mf;

LoadBosonicOperators[10]
a\[ConjugateTranspose]//mf;

Alternative versions of simple numerics

Trapz: Cheap & crappy numerical integration

Silly trapezoidal rule for function integration.

Clear[Trapz];
Trapz[fs_,Δx_]:=((Δx)/2)(fs[[1]] + 2 Total[fs[[2;;-2]]] + fs[[-1]]);

Trapz::usage = "Trapz[fs,Δx] integrates the list fs using the trapezoidal rule, with step Δx";

Example usage

NIntegrate[((Sin[x])^3),{x,0,0.7}]

Δx = 0.01;
list = ((Sin[range[0,0.7,Δx]])^3);
Trapz[list,Δx]

Δx = 0.005;
list = ((Sin[range[0,0.7,Δx]])^3);
Trapz[list,Δx]

Δx = 0.001;
list = ((Sin[range[0,0.7,Δx]])^3);
Trapz[list,Δx]

BracketRoot & FindAllRoots: pre-bracketing roots within a given interval:

Brackets the roots of f(x). 
Very useful function in root finding.

Output is a list of intervals [(Subscript[a, i]),(Subscript[b, i])], such that f(x) is guaranteed to have a root inside.

Clear[BracketRoot];
BracketRoot[f_,xmin_,xmax_,npts_:1000]:=Module[{xrange,tab,par,roots,pos,xtab,x},
xrange=linspace[xmin,xmax,npts];
tab = f/@xrange;
par = {Range[1,Length@tab-1],Most[tab] Rest[tab]}\[Transpose];
pos =Select[par,#[[2]]≤ 0.0&][[All,1]];
Table[{xrange[[p]],xrange[[p+1]]},{p,pos}]
]

BracketRoot::usage = "BracketRoot[f,xmin,xmax] tries to bracket all roots of f(x) within the interval [xmin,xmax].";

Clear[FindAllRoots];
FindAllRoots[f_,xmin_,xmax_,npts_:1000]:=Module[{x,xtab},
xtab = BracketRoot[f,xmin,xmax,npts];
Table[x/.FindRoot[f[x],{x,xt[[1]],xt[[2]]}],{xt,xtab}]
]

FindAllRoots::usage = "FindAllRoots[f,xmin,xmax] finds all roots of f(x) within the interval [xmin,xmax].";

Example usage

This is a function with roots at x = 0 and x ≈ 0.43. 
Using Mathematica’s FindRoot, one may get one root or the other, depending on where you start.
This is a big pain.

Clear[f];
f[x_] := x(Sqrt[1-4 (x^2)])-(x/2);
Plot[f[x],{x,-0.1,1/2},GridLines->{None,{0}}]

FindRoot[f[x],{x,0.1}]
FindRoot[f[x],{x,0.3}]

It is move convenient to bracket the roots before. 
i.e., one first determines intervals [(Subscript[a, i]),(Subscript[b, i])], inside which there is guaranteed to be a root.

brac=BracketRoot[f,0,1/2,100]

The actual position of the roots can now be determined using FindRoot and supplying the intervals as initial guesses.

FindRoot[f[x],{x,brac[[1,1]],brac[[1,2]]}]

FindRoot[f[x],{x,brac[[2,1]],brac[[2,2]]}]

FindAllRoots[] does that automatically: first brackets, then finds roots.

MultipleRoots[f,0,1/2,100]

LegendreGauss: numerical integration in a sphere

For functions that depend only on θ: 

(∫_0^π) f(θ) sin(θ) dθ = (∑_( i )) (Subscript[w, i])f((Subscript[p, i]))

For functions of θ,ϕ:

(∫_0^(2π))dϕ (∫_0^π)sin(θ) dθ f(θ,ϕ) = (∑_( i )) (Subscript[w, i])f((Subscript[θ, i]),(Subscript[ϕ, i]))

Clear[LegendreGauss];
LegendreGauss[n_,prec_]:=Block[{roots,p,x,w},
roots=Solve[LegendreP[n,x]==0,x];
p=N[π/4(x+1)/.roots,prec];
w=(π/4)N[2(1-(x^2))/((((n+1)LegendreP[n+1,x]))^2)/.roots,prec];
{Join[p,p+π/2],Join[w Sin[p],w Sin[p+π/2]]}
];

LegendreGauss[nθ_,nϕ_,prec_]:=Block[{pθ,wθ,pϕ,wϕ,p,w},
{pθ,wθ} = LegendreGauss[nθ,prec];
pϕ = linspace[0,2π,nϕ];
wϕ = ConstantArray[((2π)/( nϕ-1)),{nϕ}];  
p = Tuples[{pθ,pϕ}];
w = Times@@#&/@Tuples[{wθ,wϕ}];
{p,w}
]

LegendreGauss::usage = "Generates grid of (points,weights) for numerical integration in a sphere.";

Example usage

For integration of a function that only depends on θ:

(* Output is a list of (points,weights) *)
{p,w} = LegendreGauss[10,MachinePrecision]

(* Weird function *)
f[θ_]:=((Cos[θ])^3.3) (θ^2);
NIntegrate[f[θ] Sin[θ],{θ,0,π}]
f[p].w

For integration over the sphere (θ,ϕ), the syntax is the same, except that the points are now given as tuples ((Subscript[θ, i]),(Subscript[ϕ, i])). 
The correspondence is thus 

(∫_0^(2π))dϕ (∫_0^π)sin(θ) dθ f(θ,ϕ) = (∑_( i )) (Subscript[w, i])f((Subscript[θ, i]),(Subscript[ϕ, i]))

(* Integration on θ,ϕ *)
{p,w}=ThetaPhiQuadrature[10,10,MachinePrecision];

Clear[f]
f[{θ_,ϕ_}]:=((Cos[θ])^2) (θ^2)((Sin[ϕ])^2.2);
NIntegrate[f[{θ,ϕ}] Sin[θ],{θ,0,π},{ϕ,0,2π}]
(f[#]&/@p).w

Precision can be increased by increasing the number of points. 
Or one can also change MachinePrecision to another number

LegendreGauss[10,30]

RK4: manual Runge-Kutta 4, for silly things

Based on: https://en.wikipedia.org/wiki/Runge%E2%80%93Kutta_methods

RK4:   input is a time-independent function f(x). 
RK4t: f(t,x)

Clear[RK4,RK4t];
(* For time-indeendent RHS f(y) *)
RK4[f_,y0_,Δt_,tf_,onlyLastOutput_:False]:=Module[{F},
(* input function f[y] *)
F[y_]:=Block[{k1,k2,k3,k4},
k1 = f[y];
k2 = f[y + Δt k1/2];
k3 = f[y + Δt k2/2];
k4 = f[y+Δt k3];
y + ((Δt)/6)(k1+2k2+2k3+k4)
];
(*If[onlyLastOutput===False,
Transpose[{Range[0,tf,Δt],NestList[F,y0,Round[tf/Δt]]}],
Nest[F,y0,Round[tf/Δt]]
]
*)
If[onlyLastOutput===False,
Transpose[{Range[0,tf,Δt],nestList[F,y0,Round[tf/Δt]]}],
nest[F,y0,Round[tf/Δt]]
]
]

(* for a time-dependent RHS f(t,y) -> y' *)
RK4t[f_,y0_,Δt_,tf_,onlyLastOutput_:False]:=Module[{F},
(* input function f[t, y] *)
F[{t_,y_}]:=Block[{k1,k2,k3,k4},
k1 = f[t,y];
k2 = f[t+Δt/2,y + Δt k1/2];
k3 = f[t+Δt/2,y + Δt k2/2];
k4 = f[t+Δt,y+Δt k3];
{t+Δt,y + ((Δt)/6)(k1+2k2+2k3+k4)}
];
(*If[onlyLastOutput===False,
NestList[F,{0,y0},Round[tf/Δt]],
Nest[F,{0,y0},Round[tf/Δt]][[2]]
]*)

If[onlyLastOutput===False,
nestList[F,{0,y0},Round[tf/Δt]],
nest[F,{0,y0},Round[tf/Δt]][[2]]
]

]

Example usage

Time-independent qubit dynamics
(This is just for illustrative purposes; see function UnitaryDynamics[] below for a properly quantum, implementation)

H = (1/2)σz+σx;
ψ0 = (1/(Sqrt[2])){1,1};

Clear[f];
f[ψ_]:=-I H.ψ;
ψ=RK4[f,ψ0,0.01,10];
ListLinePlot[{ψ[[All,1]],((Abs[ψ[[All,2,2]]])^2)}\[Transpose]]

The output is in general a list (t,(Subscript[x, t]))

ψ=RK4[f,ψ0,0.01,0.02]

Optional last argument returns only the last output

ψ=RK4[f,ψ0,0.01,10,True]

Schrodinger equation for a driven qubit

ψ0 = (1/(Sqrt[2])){1,1};
Clear[f];
f[t_,y_]:=With[{H=(1/2)σz + Cos[t] σx}, -I H.y]

ψ=RK4t[f,ψ0,0.001,10];
ListLinePlot[{ψ[[All,1]],((Abs[ψ[[All,2,2]]])^2)}\[Transpose]]

Compare with Mathematica’s built in function

sol2 = NDSolveValue[{psi'[t]==-I  (({{(1/2), Cos[t]}, {Cos[t], -(1/2)}})).psi[t],psi[0]==ψ0},psi,{t,0,10}];

Show[
ListLinePlot[{ψ[[All,1]],((Abs[ψ[[All,2,2]]])^2)}\[Transpose]],
Plot[((Abs[sol2[t][[2]]])^2),{t,0,10},PlotStyle->Directive[Black,Dashed]]]

Unitary that generates a process from 0 to τ

Clear[f];
f[t_,y_]:=With[{H=(1/2)σz + Cos[t] σx}, -I H.y]
τ = 10.0;
U0 = NEye[2];
U=RK4t[f,U0,0.01,10,True]//mf;

U\[ConjugateTranspose].U//mf;

RK4 for Schrödinger’s equation

Clear[H,f,Δt];
f[t_,y_]:=-I H y;
((RK4t[f,y,Δt,Δt,True])/y)//Expand

((RK4[-I H #&,y,Δt,Δt,True])/y)//Expand

Gram-Chalier-Edgeworth approximation of nearly Gaussian probability distributions

GramChalierEdgeworth[cumulants_]:=Module[{d = Length@cumulants,μ,σ,κlist,Bn},
μ = cumulants[[1]];
σ = (Sqrt[cumulants[[2]]]);
κlist = Join[{0,0},cumulants[[3;;-1]]];
Bn = Table[Sum[BellY[n,k,κlist],{k,1,n}],{n,3,d}];

Function[(1/(Sqrt[2π (σ^2)]))Exp[-((((#-μ))^2)/(2(σ^2)))] (1 + Sum[(1/(n!(σ^n)))Bn[[n-2]] (2^(-n/2))HermiteH[n,((#-μ)/(σ (Sqrt[2])))],{n,3,d}])]

(*(1/(Sqrt[2π (σ^2)]))Exp[-((((x-μ))^2)/(2(σ^2)))] (1 + Sum[(1/(n!(σ^n)))Bn[[n-2]] (2^(-n/2))HermiteH[n,((x-μ)/(σ (Sqrt[2])))],{n,3,d}])
*)]

Example

p=JohnsonDistribution["SB", -2,1.2,1.1,1.5];
Plot[PDF[p,x],{x,0,3}]

cumulants = Table[Cumulant[p,n],{n,1,30}]

papprox= GramChalierEdgeworth[cumulants[[1;;30]]];
Plot[{PDF[p,x],papprox[x]},{x,1.3,3},PlotStyle->{Directive[Black,Dashed],Red,Blue}]

SillySample: sample (inefficiently) from any probability distribution

(* The Ps do not have to be normalised *)
Clear[SillySample];
SillySample[xs_?VectorQ,Ps_?VectorQ,nsamp_:1]:=If[nsamp===1,RandomChoice[Ps->xs],RandomChoice[Ps->xs,nsamp]]
SillySample[P_?MatrixQ,nsamp_:1]:=SillySample[P[[All,1]],P[[All,2]],nsamp]

Example usage

Possible input syntax, with xs, Ps being vectors and nsamp being a number.

SillySample[xs,Ps]
SillySample[{xs,Ps}ᵀ]
SillySample[{xs,Ps}ᵀ,nsamp]
SillySample[xs,Ps,nsamp]

Sample the equilibrium distribution of a classical anharmonic oscillator

m = 1;
ω = 1;
Ω = 1.;
T = 1;
xs = range[-5,5,0.02];
Ps = Table[Exp[-((1/2)m (ω^2)(x^2)+(1/4)Ω (x^4))],{x,xs}];

samp = SillySample[xs,Ps,(10^4)];
Histogram[samp,{-5,5,0.02},"PDF"]

Compare with the exact distribution

Z = NIntegrate[Exp[-((1/2)m (ω^2)(x^2)+(1/4)Ω (x^4))],{x,-∞,∞}];

Show[
Histogram[samp,{-5,5,0.02},"PDF"],
Plot[(1/Z)Exp[-((1/2)m (ω^2)(x^2)+(1/4)Ω (x^4))],{x,-5,5},PlotStyle->Black]]

Multidimensional distributions: Sample both x and p

Clear[prob];
prob[{x_,p_}]:=Exp[-(((p^2)/(2m))+(1/2)m (ω^2)(x^2)+(1/4)Ω (x^4))];
xs = range[-10,10,0.1];
ps = range[-10,10,0.1];
xps = Tuples[{xs,ps}];
Ps = prob[#]&/@xps;
samp = SillySample[xps,Ps,(10^4)];
Histogram3D[samp]

Comparison with built in samplers

Clear[x,P];

rand1 = RandomVariate[ExponentialDistribution[1],(10^4)];
xs = range[0,20,0.02];
rand2 = SillySample[xs,Exp[-xs],(10^4)];
Histogram[{rand2,rand1}]

PairedHistogram[rand1,rand2]

TwoPointCorrelation: computes (1/N)(∑_( i =1)^( N -h)) ((Subscript[x, i])-μ)((Subscript[x, i+1])-μ)

This is analogous to Mathematica’s CovarianceFunction, but somehow is much faster.

Clear[TwoPointCorrelation];
TwoPointCorrelation[data_,hmax_,dt_:None,steps_:1]:=Module[{𝒩=Length@data,ave = Mean[data],vec1,M,corr},
vec1 = data[[1;;𝒩-hmax]];
M = Table[data[[1+i;;𝒩-hmax+i]],{i,1,hmax,steps}];
corr=(1/𝒩)(M.vec1-(ave^2));
If[dt===None,corr,{dt Range[1, hmax,steps],corr}\[Transpose]]
]

FourierWithFreqs & PowerSpectrum: Computes the FFT and the power spectrum with the actual frequencies in the horizontal axis

Clear[FourierWithFreqs];
FourierWithFreqs[x_,dt_,transform_:Fourier]:=Module[{d,xf,ωs,ωs2,hamm},
d = Length@x;
If[OddQ[d],d=d-1];
hamm = Table[(1/2)(1.0-Cos[((2π j)/d)]),{j,0,d-1}];
xf = transform[x[[1;;d]] hamm];
ωs = Range[0,d/2] ((2π)/(d dt));
ωs2 = -Reverse@Drop[Drop[ωs,1],{-1}];
{Join[ωs2,ωs],Join[xf[[(d/2)+2;;d]],xf[[1;;(d/2)+1]]]}\[Transpose]
]

Clear[PowerSpectrum];
PowerSpectrum[x_,dt_,averaging_:1,overlap_:0.3]:=Module[{d,xf,ωs,hamm,S,k,xs,Ss},
d = Length@x;
If[OddQ[d],d=d-1];

k=If[averaging==1,d,((2d)/(2averaging-1))//Floor]; 
If[OddQ[k],k=k-1];

(*hamm = Table[(1/2)(1.0-Cos[((2π j)/k)]),{j,0,k-1}]; *)

ωs = Range[1,k/2] ((2π)/(k dt)); 
ωs = Join[-Reverse@Drop[ωs,{-1}],ωs];

xs  = Partition[x,k,Floor[overlap k]];

xf = Table[Fourier[(*hamm*)(xx[[1;;k]]-Mean[xx])],{xx,xs}]; 
S = Mean@Table[dt ((Abs[xxf])^2),{xxf,xf}];      

{ωs,Join[S[[(k/2)+2;;k]],S[[2;;(k/2)+1]]]}\[Transpose]  
]

Example usage

dt = 0.01;
𝒩 = 10000;
data = Table[Sin[n dt] + Sin[3 n dt],{n,1,𝒩}] + RandomReal[{-0.1,0.1},𝒩];
ListLinePlot[data,AspectRatio->1/6,ImageSize->800]

ListLinePlot[PowerSpectrum[data,dt],PlotRange->{{-5,5},All}]

Comparison with Mathematica’s PowerSpectralDensity

proc=ARMAProcess[1,{.5},{.3},1];
data=RandomFunction[proc,{500}];

sd=PowerSpectralDensity[data,w];
sd2 = PowerSpectrum[data["Values"],1,1];

Show[
Plot[{sd},{w,-π,π},PlotRange->All],
ListLinePlot[sd2,PlotStyle->{Red},PlotRange->All],
AspectRatio->1/5,ImageSize->800,
PlotRange->{{-1.5,1.5},All}
]

butter: Butterworth Filter

Based on https://mathematica.stackexchange.com/questions/46500/data-filtering-using-butterworth-filter

Clear[butter];
butter[data_,ωc_,dt_:1,order_:2]:=Module[{f,b},
f=RecurrenceFilter[ToDiscreteTimeModel[ButterworthFilterModel[{"Lowpass",order,ωc }],dt],data];
b=RecurrenceFilter[ToDiscreteTimeModel[ButterworthFilterModel[{"Lowpass",order,ωc }],dt],Reverse[data]];
(f+Reverse[b])/2
]

Example usage

dt = 0.01;
ts = range[0,50,dt];
data = Table[Sin[0.3 t] + 0.2 Sin[0.6 t],{t,ts}]+0.2 RandomReal[{0,1},Length@ts];
filt = butter[data,2,dt];
ListLinePlot[{data,filt}]

DistributionFromData: builds a distribution P(x), from a set of outcomes ((Subscript[X, 1]),(Subscript[X, 2]),...)

Clear[DistributionFromData];
DistributionFromData[data_,ΔΔx_:Automatic]:=Module[{Δx,max,min,d,x,p},
min = Min@data;
max = Max@data;
d = Length@data;
Δx=Which[
NumberQ[ΔΔx],ΔΔx,
matchString["discrete",ΔΔx] &&Not[ Head[data[[1]]]===Real],First@DeleteCases[Sort@Differences@Sort@Y,0],
True,10((max-min)/d)];

x = N@Range[min,max,Δx];
p=((BinCounts[data, {min,max+Δx,Δx}])/(d  ))//N;    

{x,p}\[Transpose]
]

Example usage

(* Generate samples *)
dist = NegativeBinomialDistribution[2,0.2];
n = 4;
nsamp=(10^5);
Y = (1/n)Total@RandomVariate[dist,{n,nsamp}];
Histogram[Y,{0.25},"PDF"]

(* Build distribution *)
(* Option "discrete" causes functions to look for the appropriate Δx *)
P = DistributionFromData[Y,"discrete"];
Show[
Histogram[Y,{0.25},"Probability"],
ListLinePlot[P,InterpolationOrder->0]]

(* Same, but for a distribution with support over the entire real axis *)
dist = GammaDistribution[2.0,0.5];
n = 5;
nsamp=(10^5);
Y = (1/n)Total@RandomVariate[dist,{n,nsamp}];
Histogram[Y,{0.015},"PDF"]

P = DistributionFromData[Y,Δx];

(* Build distribution with a specific choice of Δx *)
Δx=0.25;
P = DistributionFromData[Y,Δx];
Show[
Histogram[Y,(*{Δx}*){Min@Y,Max@Y,Δx},"Probability"],
ListLinePlot[P,InterpolationOrder->0]]

Quantum theory, information & thermodynamics

Important Hamiltonians,  unitary dynamics

Tight-binding Hamiltonian

Clear[TightBindingHamiltonian];
TightBindingHamiltonian[L_,V_:1,J_:1]:=J StiffnessMatrix[L] + Which[
ArrayQ[V],DiagonalMatrix@SparseArray[Flatten[Table[V,{Ceiling[L/Length@V]}]][[1;;L]]],
True,toeplitzMatrix[V,1,L]
];

Clear[TightBindingHamiltonianPBC];
TightBindingHamiltonianPBC[L_,V_:1,J_:1]:=J CirculantMatrix[L] + Which[
ArrayQ[V],DiagonalMatrix@SparseArray[Flatten[Table[V,{Ceiling[L/Length@V]}]][[1;;L]]],
True,toeplitzMatrix[V,1,L]
];

Example usage

TightBindingHamiltonian[3]//mf;

TightBindingHamiltonian[3,ϵ0]//mf;

TightBindingHamiltonian[3,{ϵ1,ϵ2,ϵ3}]//mf;

TightBindingHamiltonian[4,{ϵ1,ϵ2}]//mf;

TightBindingHamiltonian[3,ϵ,j]//mf;

TightBindingHamiltonianPBC[4,{ϵ1,ϵ2},J]//mf;

Majorana representation of quadratic fermionic models

Majorana operators are defined as 

(Subscript[Γ, n]^1) = (Subscript[c, n])+(Subscript[c, n]^†)
(Subscript[Γ, n]^2)     = i ((Subscript[c, n]^†)-(Subscript[c, n]))

Hamiltonian: 
H = (∑_( n,m)) (Subscript[h, nm])(Subscript[c, n]^†)(Subscript[c, m]) + (1/2)((Subscript[G, nm])(Subscript[c, n]^†)(Subscript[c, m]^†)+ (Subscript[G, mn]^( * )) (Subscript[c, n])(Subscript[c, m]))  = (1/4) Γ† 𝒯 Γ + (1/2)tr(h)

Ordering the operators as Γ = ((Subscript[Γ, 1]^1),...,(Subscript[Γ, L]^1),(Subscript[Γ, 1]^2),...,(Subscript[Γ, L]^2)) yields

 𝒯=(Subscript[σ, z]) ⊗ (((G+G†))/2)   -  (Subscript[σ, y])⊗ h -(Subscript[σ, x])⊗ i(((G-G†)/2)) =(({{((G+G†)/2), i h - (i/2)(G-G†)}, {-i h - (i/2)(G-G†), -(((G+G†)/2))}}))  
 
The function below uses instead the “local” ordering  Γ = ((Subscript[Γ, 1]^1),(Subscript[Γ, 1]^2),...,(Subscript[Γ, L]^1),(Subscript[Γ, L]^2)), so that  𝒯 becomes 

𝒯= (((G+G†))/2) ⊗ (Subscript[σ, z])  - h ⊗ (Subscript[σ, y]) - i(((G-G†)/2))⊗(Subscript[σ, x])

Clear[MajoranaHamiltonian];
MajoranaHamiltonian[h_,G_:0,ord_:"global"]:=
If[ord==="local",If[MatrixQ[h],-kron[h,(({{0, -I}, {I, 0}}))],0] +If[MatrixQ[G],- I kron[((G-G\[ConjugateTranspose])/2),(({{0, 1}, {1, 0}}))],0] +If[MatrixQ[G], kron[((G+G\[ConjugateTranspose])/2),(({{1, 0}, {0, -1}}))],0] ,
If[MatrixQ[h],-kron[(({{0, -I}, {I, 0}})),h],0] +If[MatrixQ[G],- I kron[{{0,1},{1,0}},(G-G\[ConjugateTranspose])/2],0] +If[MatrixQ[G], kron[{{1,0},{0,-1}},(G+G\[ConjugateTranspose])/2],0]  ] 

Clear[MajoranaTightBinding];
MajoranaTightBinding[V_,L_,ord_:"global"]:=MajoranaHamiltonian[TightBindingHamiltonian[L,V],0,ord]

Clear[MajoranaXY];
MajoranaXY[L_,h0_,κ_]:=Module[{Δ},
Δ=h0 Eye[L]+ SparseArray[{Band[{1,2}]->((1-κ)/2)(*Jy*),Band[{2,1}]->((1+κ)/2)(*Jx*)},{L,L}] ;
I ArrayFlatten[(({{0, -Δ}, {Δ\[ConjugateTranspose], 0}}))]]

Example usage

L = 3;
A = RandomReal[{-1,1},{L,L}];
A = A + A\[Transpose];
B = RandomReal[{-1,1},{L,L}];
B = B - B\[Transpose]//mf;

LoadFermionicOperators[L,"global"];
H1 = Sum[A[[n,m]] cd[n].c[m] + (1/2)B[[n,m]] (cd[n].cd[m]-c[n].c[m]),{n,L},{m,L}]//mf;

h2 = MajoranaHamiltonian[A,B,"global"];
H2 =(1/2)Tr[A] Eye[8]+ (1/4)Sum[h2[[k,l]] Γ[k].Γ[l],{k,2L},{l,2L}]//mf;

H1-H2//mf;

L = 3;
A = RandomReal[{-1,1},{L,L}];
A = A + A\[Transpose];
B = RandomReal[{-1,1},{L,L}]+  0.7 I RandomReal[{-1,1},{L,L}];
(*B = B - B\[Transpose]//mf;*)

LoadFermionicOperators[L];
H1 = Sum[A[[n,m]] cd[n].c[m] + (1/2)(B[[n,m]]  cd[n].cd[m] +B[[n,m]]\[Conjugate] c[m].c[n]),{n,L},{m,L}]//mf;
(*H1-H1\[ConjugateTranspose]//mf;*)

(*MajoranaHamiltonian2[A_,B_:0]:=If[MatrixQ[A],-kron[A,σy],0] +If[MatrixQ[B],- I kron[((B-B\[ConjugateTranspose])/2),σx],0] +If[MatrixQ[B], kron[((B+B\[ConjugateTranspose])/2),σz],0]  *)
h2 = MajoranaHamiltonian[A,B];
H2 =(1/2)Tr[A] Eye[8]+(1/4)Sum[h2[[k,l]] Γ[k].Γ[l],{k,2L},{l,2L}]//mf;

H1-H2//mf;

Non-interacting Hamiltonians and quasi-periodic sequences

(* (Subscript[λ, c]) = 2 *)
Clear[aubryAndreHarper];
aubryAndreHarper[L_,ϕ_:0,α_:0]:=Table[((Cos[ 2.0π GoldenRatio n + ϕ])/(1-α Cos[2π GoldenRatio n + ϕ])),{n,1,L}];

Clear[fibonacciString];
fibonacciString[L_]:=Table[IntegerPart[(n+1)(1/(GoldenRatio^2))]-IntegerPart[n(1/(GoldenRatio^2))],{n,1,L}];

fibonacciString[L_,a_,b_]:=fibonacciString[L]/.{0->a,1->b}

Based on https://arxiv.org/pdf/1803.03609.pdf

sshHamiltonian[L_,τ0_,δτ_,ϵ_:1]:= Module[{hop = Table[τ0-(((-1))^j)δτ,{j,1,L-1}]},
- ϵ DiagonalMatrix[ConstantArray[ϵ,L]]  + DiagonalMatrix[hop,1] + DiagonalMatrix[hop,-1]//SparseArray
]

Example usage

h = TightBindingHamiltonian[100,2.1AubryAndreHarper[100]];
ψ = Eigvecs[h,1][[All,1]];
ListLinePlot[((Abs[ψ])^2),PlotRange->All]

UnitaryDynamics

Input can be a function H(t), or a list {H(0), H(dt), H(2dt),...}

Clear[UnitaryDynamics]
UnitaryDynamics[H_?ListQ,dt_,τ_,y0_:"id",onlyLastOutput_:False]:=Module[{ntrotter,ψ0,f,ψ,results},
ntrotter = Round[τ/dt];
ψ0 = If[y0==="id",Eye[Length@H[[0]]],y0];
ψ = ψ0;
If[onlyLastOutput===False,
Transpose[{Range[0,(Length[H]-1) dt,dt],Table[ψ=MatrixExp[-I h dt,ψ],{h,H}]}],
Do[ψ=MatrixExp[-I h dt,ψ],{h,H}]; ψ
]
]

UnitaryDynamics[H_,dt_,τ_,y0_:"id",onlyLastOutput_:False]:=Module[{ntrotter,ψ0,f,ψ},
ntrotter = Round[τ/dt];
ψ0 = If[y0==="id",Eye[Length@H[0]],y0];
If[y0==="id",
f[{t_,ψ_}]:={t+dt,MatrixExp[-I dt H[t]].ψ},
f[{t_,ψ_}]:={t+dt,MatrixExp[-I dt H[t],ψ]}];

If[onlyLastOutput===False,
NestList[f,{0,ψ0},ntrotter],
Nest[f,{0,ψ0},ntrotter][[2]]
]
]

Example usage

Input a function H(t)

Clear[H];
H[t_]:= (1/2)σz + Cos[t] σx
ψ0 = (1/(Sqrt[2])){1,1};
ψ=UnitaryDynamics[H,0.01,10,ψ0] ;
ListLinePlot[{ψ[[All,1]],((Abs[ψ[[All,2,2]]])^2)}\[Transpose]]

Input a pre-Trotterrized list

Hlist = Table[H[t],{t,0,10,0.01}];
ψ=UnitaryDynamics[Hlist,0.01,10,ψ0];
ListLinePlot[{ψ[[All,1]],((Abs[ψ[[All,2,2]]])^2)}\[Transpose]]

Unitary from 0 to τ

Clear[H];
H[t_]:= (1/2)σz + Cos[t] σx

U=UnitaryDynamics[H,0.01,10,"id",True] //mf;

U\[ConjugateTranspose].U//mf;

CounterDiabaticHamiltonian

Given a time-dependent Hamiltonian H(t)=(∑_( n)) (Subscript[E, n])(t) |(Subscript[ψ, n])(t)⟩⟨(Subscript[ψ, n])(t)|, computes the counter-diabatic Hamiltonian used in shortcuts to adiabaticity:

(Subscript[H, CD])(t) = i (∑_( n)) |(∂_t)(Subscript[ψ, n])⟩⟨(Subscript[ψ, n])|

Input: 
- H(t) as a function
- final time (Subscript[t, f])
- time step dt
Output: 
- {H(t), (Subscript[H, CD])} , with each given as a list evaluated at times 0,dt,2dt,...,(Subscript[t, f]).

Clear[CounterDiabaticHamiltonian];
CounterDiabaticHamiltonian[Hs_,tf_,dt_]:=Module[{Hbare,T,Vs,HCD,hcd,V},

Hbare = Table[Hs[t],{t,0,tf,dt}];
T = Length@Hbare;

Vs=Normal@Table[
V=Eigvecs[Hbare[[n]]];
(V\[Transpose] Exp[I Arg[V[[1]]]])\[Transpose]  (* fixes so that eigenvectors always have the same phases *)
,{n,T}];

HCD =  Table[
hcd=I(((Vs[[n+1]]-Vs[[n-1]])/(2dt))).Vs[[n]]\[ConjugateTranspose]; 
((hcd+hcd\[ConjugateTranspose])/2),{n,2,T-1}];

HCD=Join[{0 Hbare[[1]]},HCD,{0 Hbare[[1]]}];
{Hbare,HCD}

]

Example usage: Landau-Zener avoided crossing with a linear ramp

Clear[H];
τQ=10^1;
Δ0=-5.;
Δd=10.;
ω0=0.5;

H[t_] := (1/2)(ω0 σx+ (Δ0+Δd t/τQ) σz)
ψ0 = GroundState[H[0]];

(* Generate the Hamiltonians *)
{Hbare,HCD} = CounterDiabaticHamiltonian[H,τQ,dt=1/300];

(* Simulate unitary dynamics with the Bare Hamiltonian, and compute fidelity with ground state. *)
ψbare = UnitaryDynamicsTroterized[Hbare,ψ0,dt];
fidBare=Table[((Abs[GroundState[H[(n-1) dt]]\[Conjugate].ψbare[[n]]])^2),{n,1,Length@ψbare}];

(* Include counter-diabatic driving *)

ψCD = UnitaryDynamicsTroterized[Hbare + HCD,ψ0,dt];
fidCD=Table[((Abs[GroundState[H[(n-1) dt]]\[Conjugate].ψCD[[n]]])^2),{n,1,Length@ψCD}];

ListLinePlot[{fidBare,fidCD},DataRange->{0,τQ},PlotRangePadding->{None,0.05},PlotStyle->{{Thick,Red},{Thick,Black,Dashed}},FrameLabel->{"t","ℱ"},
PlotLegends->legend[{"Without CD","With CD"},{0.25,0.35}]
]

Original version of the code

CounterDiabaticHamiltonianOriginal[Hs_,tf_,dt_]:=
Module[
{timeinterval,ℋbares,vectors,e,v,ℋCD,ℋCDUpper,ℋCDLower,d = Length@Normal@Hs[0],vecs,dvecs,T,resultℋCD,orderi,orderedEi,orderedV,normV,val,vec,Eigenvals,Eigenvecs},

(*time interval*)
timeinterval=Table[j,{j,0,tf,dt}];
T=Length@timeinterval;

(*Bare Hamiltonians H0 and their ORDERED and normalized eigenvalues/eigenvectors*)
ℋbares=Table[Normal@Hs[tp],{tp,timeinterval}];
Eigenvecs=Range[T];
Do[Eigenvecs[[i]]=Eigvecs[ℋbares[[i]]]//Chop,{i,T}];

(*The following part removes the global phase fluctuations due to Mathematica Eigensystem*)
Do[
Do[
If[Eigenvecs[[i,j,1]]>0,Eigenvecs[[i,j]]=Eigenvecs[[i,j]],Eigenvecs[[i,j]]=-Eigenvecs[[i,j]]];
,{j,1,d}]
,{i,1,T}];

(*Conctruction of the time interpolated eigenvectors and their derivatives*)
vectors=Table[Interpolation[Table[{timeinterval[[i]],Eigenvecs[[i,j,k]]},{i,T}]],{j,1,d},{k,1,d}];
vecs=Table[Table[vectors[[j,k]][tp],{j,1,d},{k,1,d}],{tp,timeinterval}];
dvecs=Table[Table[vectors[[j,k]]'[tp],{j,1,d},{k,1,d}],{tp,timeinterval}];

(*Counterdiabatic Hamiltonian -- We enforce hermitianity since it is useful for the LMG model at high number of spins, where this property seems to break*)
ℋCD=Table[I*Sum[KETBRA[dvecs[[i,j]],vecs[[i,j]]]//Chop,{j,d}],{i,T}];
{Table[ℋbares[[i]]+((ℋCD[[i]]+ℋCD[[i]]\[ConjugateTranspose])/2),{i,T}],Table[((ℋCD[[i]]+ℋCD[[i]]\[ConjugateTranspose])/2),{i,T}]}
];

{Hbare2,HCD2}=CounterDiabaticHamiltonian[Function[t,(1/2)(ω0 PauliMatrix[1]+LinearRamp[t]* PauliMatrix[3])],0.1,dt];
{Hbare,HCD}=Chop@CounterDiabaticHamiltonianOriginal[Function[t,(1/2)(ω0 PauliMatrix[1]+LinearRamp[t]* PauliMatrix[3])],0.1,dt];

Hbare2[[10]]//mf;

Hbare[[10]]//mf;

Quantum information

PTr: partial trace

You list what you want to trace: PTr[ρ,{1,4,5}] traces out subsystems 1, 4  and 5

Syntax: 
- Most general syntax is PTr[ρ,{1,4,5}, {d1,d2,d3,d4,d5}]
  
 -   PTr[ρ,{1,4,5}, d] = PTr[ρ,{1,4,5},{d,d,d,d,d}]

  -  PTr[ρ,{1,4,5}] = PTr[ρ,{1,4,5},{2,2,2,2,2}] (assumes qubits)

Clear[PTr]
PTr[ρ_,list_,locdimlist_]:=Module[{i,eye,v,L,n,tups,tab,𝒩},
n = Length@locdimlist;
Do[eye[l] = Eye[locdimlist[[l]]],{l,n}];

Do[v[l,i] = {eye[l][[i]]}\[Transpose],{l,n},{i,locdimlist[[l]]}];
tups = Tuples@Table[Range[1,l],{l,locdimlist[[list]]}];
tab = Table[
kron@@Table[If[MemberQ[list,l],v[l,j[[Position[list,l][[1,1]]]]],eye[l]],{l,n}],{j,tups}];
Total@Table[(tab[[i]])\[Transpose].ρ.tab[[i]],{i,Length@tab}]
];

PTr[ρ_,list_,locdim_?NumberQ]:= PTr[ρ,list,ConstantArray[locdim,Log[locdim, Length@ρ]]]

PTr[ρ_,list_]:=PTr[ρ,list,2];

PTr::usage = "Computes the partial trace of ρ over a list of subsystems";

Example usage

(* ρ = |(Subscript[ψ, 1])⟩⟨(Subscript[ψ, 1])|⊗|(Subscript[ψ, 2])⟩⟨(Subscript[ψ, 2])| *)
ψ1 = {1,1}//Normalize;
ψ2 = {2,I}//Normalize;
ρ = kron[out[ψ1,ψ1],out[ψ2,ψ2]]//mf;

PTr[ρ,{2}]//mf;
out[ψ1,ψ1]//mf;

PTr[ρ,{1}]//mf;
out[ψ2,ψ2]//mf;

(* PTr assumes in principle local dimension is d = 2. *)
(* If the dimensions are homogenous, pass out an extra number *)
ψ1 = {1,1,3}//Normalize;
ψ2 = {2,I,-3I}//Normalize;
ρ = kron[out[ψ1,ψ1],out[ψ2,ψ2]];

PTr[ρ,{2},3]//mf;
out[ψ1,ψ1]//mf;

PTr[ρ,{1},3]//mf;
out[ψ2,ψ2]//mf;

(* If each sub-system has a different dimension, pass out a list of dimensions *)
ψ1 = {1,1}//Normalize;
ψ2 = {1,2,3,4,5}//Normalize;
ρ = kron[out[ψ1,ψ1],out[ψ2,ψ2]];

PTr[ρ,{2},{2,5}]//mf;
out[ψ1,ψ1]//mf;

PTr[ρ,{1},{2,5}]//mf;
out[ψ2,ψ2]//mf;

von Neumann & Rényi entropy

Clear[vonNeumann];
vonNeumann[ρ_,base_:E]:= Module[{eigs,func},
eigs = Eigenvalues[ρ];
func[x_]:= If[NumberQ[x]&&Re@x<(10^(-12)),0,-x Log[base,x]];
Chop@Sum[func[eigs[[i]]],{i,1,Length@eigs}]
]

vonNeumann::usage = "von Neumann entropy S(ρ)";

Renyi[ρ_,α_,base_:E]:= Module[{eigs,func},
Which[
α ==1.0,vonNeumann[ρ],
α ==∞,-Log[base,Max@Eigenvalues[ρ]],
True,(eigs = Eigenvalues[ρ];
(1/(1-α))Log[base,Sum[(((eigs[[i]]))^α),{i,1,Length@eigs}]])]//Chop
]

Renyi::usage = "Renyi entropy (Subscript[S, α])(ρ)";

Example usage

ρ = (({{0.3, 0.1}, {0.1, 0.7}}));
vonNeumann[ρ]
Renyi[ρ,3]

Renyi[ρ,1] (* returns von Neumann *)

Renyi[ρ,0]

Renyi[ρ,∞]

Kullback-Leibler & Rényi divergences: Quantum relative entropy

(* D(ρ||σ) *)
Clear[KullbackLeibler];
KullbackLeibler[ρ_?MatrixQ,σ_?MatrixQ]:=Module[{S1,S2,λ,Q,log},

S1 = vonNeumann[ρ];
{λ,Q} = Eigensystem[σ];
Q = Q\[Transpose]; 
log = DiagonalMatrix@Log[λ];
S2 = - Tr[Q\[ConjugateTranspose].ρ.Q.log];
-S1+S2//Chop
]

KullbackLeibler[p_?VectorQ,q_?VectorQ]:=Total@Table[If[Abs[p[[i]]]<(10^(-12)),0,p[[i]] Log[p[[i]]/q[[i]]]],{i,Length@p}]

(* (Subscript[D, α])(ρ||σ) *)
Clear[RenyiDivergence];
RenyiDivergence[ρ_?MatrixQ,σ_?MatrixQ,α_]:=Module[{S1,S2,λ,Q,log,m1},

If[Abs[α-1]<(10^(-12)),KullbackLeibler[ρ,σ],
m1 = MatrixPower[σ,((1-α)/(2α))];
-(1/(1-α))Log@Tr[MatrixPower[m1.ρ.m1,α]]]//Chop
]

Example usage

ρ = (({{0.3, 0.1}, {0.1, 0.7}}));
σ = (({{0.3, 0}, {0, 0.7}}));
KullbackLeibler[ρ,σ]

ρ = (({{0.3, 0}, {0, 0.7}}));
σ = (({{0.7, 0}, {0, 0.3}}));
KullbackLeibler[ρ,σ]

KullbackLeibler[ρ,ρ]

(* Also defined for vectors *)
p = {0.1,0.4,0.5};
q = {0.05,0.6,0.35};
KullbackLeibler[p,q]

Mutual Information

Usage is similar to partial trace function.

Clear[MutualInformation];
MutualInformation[ρ_,{A_,B_},locdimlist_]:=Module[{ρA,ρB,ρAB,n},
n= Length@locdimlist;(* Number of sub-systems in this case *)
ρA = PTr[ρ,Complement[Range[n],Flatten@{A}],locdimlist];
ρB = PTr[ρ,Complement[Range[n],Flatten@{B}],locdimlist];
ρAB = PTr[ρ,Complement[Range[n],Flatten@Join[Flatten@{A},Flatten@{B}]],locdimlist];
Chop[vonNeumann[ρA]+vonNeumann[ρB]-vonNeumann[ρAB],(10^(-12))]
];

(* When all subsystems have different dimensions *)
MutualInformation[ρ_,{A_,B_},locdim_?NumberQ]:= MutualInformation[ρ,{A,B},ConstantArray[locdim,Log[locdim, Length@ρ]]]

(* When all subsystems are qubits *)
MutualInformation[ρ_,{A_,B_}]:= MutualInformation[ρ,{A,B},ConstantArray[2,Log[2, Length@ρ]]]

Example usage

Usage is similar to partial trace function.

ψ = (1/(Sqrt[2])){1,0,0,1};
ρ = out[ψ,ψ];
MutualInformation[ρ,{1,2}]
MutualInformation[ρ,{1,2},2]
MutualInformation[ρ,{1,2},{2,2}]

(* 3 qubits *)
ψ = (1/(Sqrt[2])){1,0,0,1,0,0,1,0};
ρ = out[ψ,ψ];
MutualInformation[ρ,{1,2},2]
MutualInformation[ρ,{1,2},{2,2,2}]

Concurrence & Entanglement of Formation

R = (Sqrt[(Sqrt[ρ])((Subscript[σ, y])⊗(Subscript[σ, y]))(SuperStar[ρ])((Subscript[σ, y])⊗(Subscript[σ, y]))(Sqrt[ρ])])

Concurrence[ρ_]:=Module[{σy,ρt,ρsq,R,eigs},
σy = {{0,-I},{I,0}};
ρt = kron[σy,σy].ρ\[Conjugate].kron[σy,σy];
ρsq = MatrixPower[ρ,1/2];
R = MatrixPower[ρsq.ρt.ρsq,1/2];
eigs = Chop@Reverse@Sort@Eigenvalues[R];
Max[0,Re[eigs[[1]]-eigs[[2]]-eigs[[3]]-eigs[[4]]]]
];

EntanglementOfFormation[ρ_,b_:2]:=Module[{c,h},
h[x_]:=If[(x==0)||(x==1),0,-x Log[b,x]-(1-x)Log[b,1-x]];
c = Concurrence[ρ];
h[((1+(Sqrt[1-(c^2)]))/2)]
]

Example usage

ψ = (1/(Sqrt[2])){0,1,1,0};
ρ = (1-p) out[ψ,ψ]+p Eye[4]/4;
{ListLinePlot[Table[{p,Concurrence[ρ]},{p,0,1,0.02}]],
ListLinePlot[Table[{p,EntanglementOfFormation[ρ]},{p,0,1,0.02}]]}

Quantum Fidelity

Clear[QuantumFidelity];
QuantumFidelity[ρ_,σ_]:=((Tr[MatrixPower[MatrixPower[ρ,1/2].σ.MatrixPower[ρ,1/2],1/2]])^2)

Example usage

ρ = (({{0.3, 0}, {0, 0.7}}));
σ = (({{0.7, 0}, {0, 0.3}}));
QuantumFidelity[ρ,σ]

Relative Entropy of Coherence with respect to the eigenbasis of an operator X

Computes the relative entropy of coherence of a state ρ in the basis of an observable X

(Subscript[C, X])(ρ) = S((Subscript[Δ, X])(ρ)) - S(ρ)

where (Subscript[Δ, X]) is the maximally dephasing operation.

Clear[RelativeEntropyofCoherence];
RelativeEntropyofCoherence[ρ_,X_]:=Module[{v,V,Δρ},
V = Normalize/@Eigenvectors[X];
Δρ = Total@Table[out[v,v].ρ.out[v,v],{v,V}];
Chop[vonNeumann[Δρ]-vonNeumann[ρ],(10^(-12))]
];

Example usage

ρ = (({{0.3, 0.1}, {0.1, 0.7}}));
A = (({{1, 0}, {0, -1}}));
FullDephasing[ρ,A]//mf;

ρ = (({{0.3, 0.03+I 0.01}, {0.03-I 0.01, 0.7}}));

RelativeEntropyofCoherence[ρ,σz]

(* Is the same as *)
KullbackLeibler[ρ,FullDephasingMap[ρ,σz]]

RelativeEntropyofCoherence[ρ,σx]

FullDephasingMap[ρ,σx]//mf;

y-covariance (maybe buggy)

The y-covariance is defined as 

(Subscript[(Subscript[cov, y])(A,B), ρ]) = tr(A (ρ^y)B (ρ^(1-y)))-tr(Aρ) tr(Bρ)

Very often, it appears integrated over y, in the form 

(1/2)(∫_0^( 1))dy (Subscript[(Subscript[cov, y])(A,B), ρ]) 

To compute this, it is easier to diagonalize ρ before hand, and compute the integral by hand.

Integrate[(p^y)(q^(1-y)),{y,0,1}]
Integrate[(p^y)(p^(1-y)),{y,0,1}]

Clear[IntegratedCOVy];
IntegratedCOVy[A_,B_,ρ_,tol_:(10^(-11))]:=Module[{f,d=Length@ρ,ps,𝒪,At,Bt},
{ps,𝒪} = Eigensystem[N@ρ];
𝒪 = 𝒪\[Transpose];
(*ps = Abs[ps];*)

f=((DiagonalMatrix[ps]+Outer[Subtract,(1+tol)ps,ps] )/(Eye[d]+tol+Outer[Subtract,Log[ps],Log[ps]])); 

At = 𝒪\[ConjugateTranspose].A.𝒪;
Bt = 𝒪\[ConjugateTranspose].B.𝒪;
(1/2)(Total@Flatten[f Bt At\[Transpose]]- Tr[A.ρ]Tr[B.ρ])//Chop
]

Example usage

ρ = (({{0.3, 0.1-0.05I}, {0.1+0.05I, 0.7}}));
A = σx+0.3 σz;
B = 0.1 σy - 0.4 σx;

IntegratedCOVy[A,B,ρ]

Sanity check

ρ = (({{0.3, 0.1-0.05I}, {0.1+0.05I, 0.7}}));
A = σx+0.3 σz;
B = 0.1 σy - 0.4 σx;

covy = Tr[A.MatrixPower[ρ,y].B.MatrixPower[ρ,1-y]]-Tr[A.ρ] Tr[B.ρ]//Simplify

(1/2)Integrate[covy,{y,0,1}]//Chop

IntegratedCOVy[A,B,ρ]

LoadArbitrarySpinMatrices[1,"a"];
ρ = MatrixExp[-Sx.Sx];
ρ = ρ/Tr[ρ];
A = Sx+(1/3) Sz;
B = (1/10) Sy - (9/10) Sx;

covy = Tr[A.MatrixPower[ρ,y].B.MatrixPower[ρ,1-y]]-Tr[A.ρ] Tr[B.ρ]//Simplify
N[(1/2)Integrate[covy,{y,0,1}],20]

Table[InputForm[IntegratedCOVy[A,B,ρ,tol]],{tol,logspace[-15,-5,10]}]//TableForm

Other (slower implementations)

IntegratedCOVy2[A_,B_,ρ_]:=Module[{f,d=Length@ρ,ps,vecs},
{ps,vecs} = Eigsys[ρ];
vecs=vecs\[Transpose];
f = Table[
If[Abs[ps[[α]]-ps[[β]]]<=(10^(-12)),
ps[[α]],
((ps[[α]]-ps[[β]])/(Log[ps[[α]]]-Log[ps[[β]]]))],{α,d},{β,d}];

(1/2)(Sum[f[[α,β]] vecs[[α]]\[Conjugate].B.vecs[[β]] vecs[[β]]\[Conjugate].A.vecs[[α]],{α,d},{β,d}]-Sum[ps[[α]] vecs[[α]]\[Conjugate].A.vecs[[α]],{α,d}] Sum[ps[[α]] vecs[[α]]\[Conjugate].B.vecs[[α]],{α,d}])//Chop

]

(* Terrible: slow and imprecise *)
IntegratedCOVy3[A_,B_,ρ_,nys_:200]:=Module[{ave = Tr[A.ρ] Tr[B.ρ]},

(1/2)Trapz[Table[Tr[A.MatrixPower[ρ,y].B.MatrixPower[ρ,1-y]]-ave,{y,linspace[0,1,nys]}],1./nys]//Chop
]

ps = {a,b,b};

mat1=(DiagonalMatrix[ps]+Outer[Subtract,(1+ϵ)ps,ps] )/(Eye[3]+ϵ+Outer[Subtract,Log[ps],Log[ps]])//Simplify//mf;

mat1/.ϵ->0//mf;

mat2=Table[
If[ps[[α]]===ps[[β]],
ps[[α]],
((ps[[α]]-ps[[β]])/(Log[ps[[α]]]-Log[ps[[β]]]))],{α,3},{β,3}]//mf;

mat1-mat2/.ϵ->0//Simplify

Wigner-Yanase-Dyson skew information (maybe buggy as well)

Computes (1/2)(∫_0^( 1))dy (Subscript[I, y])(A,ρ)

where (Subscript[I, y])(A,ρ) = -(1/2)tr([(ρ^y),A] [(ρ^(1-y))A])

Clear[WignerYanaseDyson];
(*WignerYanaseDyson[A_,ρ_,tol_:(10^(-11))]:=(1/2)(Tr[A.A.ρ]-((Tr[A.ρ])^2))-IntegratedCOVy[A,A,ρ,tol]//Chop*)

WignerYanaseDyson[A_,ρ_,tol_:(10^(-11))]:=Module[{f,d=Length@ρ,ps,𝒪,At},
{ps,𝒪} = Eigensystem[N@ρ];
𝒪 = 𝒪\[Transpose];

f=((DiagonalMatrix[ps]+Outer[Subtract,(1+tol)ps,ps] )/(Eye[d]+tol+Outer[Subtract,Log[ps],Log[ps]])); 
At = 𝒪\[ConjugateTranspose].A.𝒪;
(1/2)(Tr[A.A.ρ]-Total@Flatten[(f At) At\[Transpose]])//Chop]

Example usage

ρ = (({{0.3, 0}, {0, 0.7}}));
A = σx+0.3 σz;

WignerYanaseDyson[σz,ρ]

WignerYanaseDyson[σx,ρ]

Quantum State Tomography

Silly simulations of a Quantum State Tomography process.

Optional input: list of orthogonal (not necessarily orthonormal) operators, in the sense that tr((Subscript[A, i]^†)(Subscript[A, j])) ∝ (Subscript[δ, i,j])
If this is omitted, program assumes the canonical basis |n⟩⟨n|, (|n⟩⟨m| + |m⟩⟨n|) and i(|n⟩⟨m| - i |m⟩⟨n|).

Clear[QuantumStateTomography];
QuantumStateTomography[ρ_,nexperiments_,listOfObservables_]:=Module[{d=Length@ρ,λ,V,p,r,ρest},
ρest=Total@Table[

{λ,V} = Eigsys[A];
V = V\[Transpose];
p = Table[v\[Conjugate].ρ.v,{v,V}]//Chop;
r=SillySample[λ,p,nexperiments]//Mean//N;
(r/(Tr[A\[ConjugateTranspose].A])) A

,{A,listOfObservables}];

ρest = (1/d)(1-Tr[ρest])Eye[d] + ρest
]

QuantumStateTomography[ρ_,nexperiments_]:=Module[{d=Length@ρ,listOfObservables},

listOfObservables = Join[
Table[Proj[d,i,i],{i,d}],
Flatten[Table[Proj[d,i,j]+Proj[d,j,i],{i,d},{j,i+1,d}],1],
Flatten[Table[I(Proj[d,i,j]-Proj[d,j,i]),{i,d},{j,i+1,d}],1]
];
QuantumStateTomography[ρ,nexperiments,listOfObservables]]

Example usage

(* Generate a random state *)
ψ = RandomReal[{0,1},2] + I RandomReal[{0,1},2]//Normalize

(* Simulate a tomography process *)
ρ = out[ψ,ψ]//mf;
QuantumStateTomography[ρ,(10^5),{σx,σy,σz}]//mf;

ρ = out[ψ,ψ]//mf;
QuantumStateTomography[ρ,(10^5)]//mf;

Quantum Process Tomography

Based on Sec. 8.4.2 of Nielsen & Chuang.
Input: channel ℰ[ρ], dimension d. 

- QuantumProcessTomography[ℰ,d] will return the χ matrix, the (OverTilde[E]) operators and the reconstructed channel (which in this case matches exactly the original one). 

- QuantumProcessTomography[ℰ,d, nexperiments] will do actual state tomography in the output states. 

- - QuantumProcessTomography[ℰ,d, nexperiments, obs] also includes a generic list of observables.

Clear[QuantumProcessTomography];
QuantumProcessTomography[ℰ_,d_,nexperiments_,obs_]:=Module[{λ,β,χ,ℰreconstructed,ρs},
ρs =  Join[
Table[Proj[d,i,i],{i,d}],
Flatten[Table[out[((Basis[d,i]+Basis[d,j])/(Sqrt[2])),((Basis[d,i]+Basis[d,j])/(Sqrt[2]))],{i,d},{j,i+1,d}],1],
Flatten[Table[out[((Basis[d,i]+I Basis[d,j])/(Sqrt[2])),((Basis[d,i]+I Basis[d,j])/(Sqrt[2]))],{i,d},{j,i+1,d}],1]
];

β = ArrayReshape[N@Table[((Tr[ρk\[ConjugateTranspose].Em.ρj.En\[ConjugateTranspose]])/(Tr[ρk\[ConjugateTranspose].ρk])),{ρj,ρs},{ρk,ρs},{Em,obs},{En,obs}],{(d^4),(d^4)}];

λ = If[nexperiments==0,
Table[((Tr[ρk\[ConjugateTranspose].ℰ[ρj]])/(Tr[ρk\[ConjugateTranspose].ρk])),{ρj,ρs},{ρk,ρs}],
Table[((Tr[ρk\[ConjugateTranspose].QuantumStateTomography[ℰ[ρj],nexperiments]])/(Tr[ρk\[ConjugateTranspose].ρk])),{ρj,ρs},{ρk,ρs}]
];
χ = Unvec@LinearSolve[β,Vec[λ]];

ℰreconstructed = Function[ρ,Sum[χ[[m,n]]obs[[m]].ρ.obs[[n]]\[ConjugateTranspose],{m,Length@obs},{n,Length@obs}]];
{obs,χ,ℰreconstructed}
];

QuantumProcessTomography[ℰ_,d_]:=QuantumProcessTomography[ℰ,d,0]

QuantumProcessTomography[ℰ_,d_,nexperiments_]:=Module[{obs},
obs = Join[
Table[Proj[d,i,i],{i,d}],
Flatten[Table[Proj[d,i,j]+Proj[d,j,i],{i,d},{j,i+1,d}],1],
Flatten[Table[I(Proj[d,i,j]-Proj[d,j,i]),{i,d},{j,i+1,d}],1]
];
QuantumProcessTomography[ℰ,d,nexperiments,obs]]

Example usage

ℰp=QuantumProcessTomography[AmplitudeDamping[0.3,0.5],2];
ρtest = (1/2)(({{1, 1}, {1, 1}}));
AmplitudeDamping[0.3,0.5][ρtest]//mf;
Last[ℰp][ρtest]//mf;

ℰp=QuantumProcessTomography[AmplitudeDamping[0.3,0.2],2,(10^6)];
ρtest = (1/2)(({{1, 1}, {1, 1}}));
AmplitudeDamping[0.3,0.2][ρtest]//mf;
Last[ℰp][ρtest]//mf;

ℰp=QuantumProcessTomography[AmplitudeDamping[0.3,0.2],2,(10^6),{σ0,σx,σy,σz}];
ρtest = (1/2)(({{1, 1}, {1, 1}}));
AmplitudeDamping[0.3,0.2][ρtest]//mf;
Last[ℰp][ρtest]//mf;

Negentropy: relative entropy of Gaussianity for discrete distributions

The negentropy (https://en.wikipedia.org/wiki/Negentropy#:~:text=Negentropy%20measures%20the%20difference%20in,if%20the%20signal%20is%20Gaussian.) 
is a measure of how close a probability distribution is to a given Gaussian. 

It is defined as 

𝒩(p)=D(p||(Subscript[p, G])) = ∫ dx p(x) log(p(x)/(Subscript[p, G])(x)) 

where (Subscript[p, G])(x) is a Gaussian distribution with the same mean and variance as p(x).

For discrete random variables, however, the negentropy is trickier to compute because ∫dx p(x) ln(p(x)) is not the same as (∑_( i))p((Subscript[x, i]))ln(p((Subscript[x, i]))) .
This is explained in https://en.wikipedia.org/wiki/Limiting_density_of_discrete_points

The function below takes as input a series of cumulants from the distribution. 
It approximates the resulting distribution to a smooth curve using the GramChalierEdgeworth function, and then computes D(p||(Subscript[p, G])) by numerical integration

Clear[Negentropy];
Negentropy[cumulants_,nsigma_:7]:=Module[{pgce,w,pg,μ,σ}, 
pgce = GramChalierEdgeworth[cumulants];
μ = cumulants[[1]];
σ = (Sqrt[cumulants[[2]]]);
pg = PDF[NormalDistribution[μ,σ],w];

NIntegrate[Re[pgce[w] Log[pgce[w]/pg]],{w,μ-nsigma σ,μ+nsigma σ},MaxRecursion->∞]
]

Example usage

Work distribution in a macroscopic spin undergoing a sudden quench

LoadArbitrarySpinMatrices[S = 50];
Hi = Sz;
Hf =Sz;
U = MatrixExp[-I 0.9 Sx];
β = 0.1;
P = WorkDistribution[Hi,Hf,"thermal",β,U]//Quiet;
ListLinePlot[P,PlotRange->All]

(* Get cumulants from the moments *)
cumulants = getCumulants[Table[((P[[All,1]])^n).P[[All,2]],{n,1,18}]]

Compute Negentropy

Negentropy[cumulants]

pgce = GramChalierEdgeworth[cumulants];
pg = PDF[NormalDistribution[cumulants[[1]],(Sqrt[cumulants[[2]]])]];
Show[
ListLinePlot[P],
Plot[{pgce[w],pg[w]},{w,-60,100},PlotStyle->{Red,Green},
PlotLegends->legend[{"GramChalierEdgeworth","Gaussian"},{0.35,0.75}]
],
ImageSize->500
]

Check dependence on the number of cumulants

ListLinePlot[Table[{n,Negentropy[cumulants[[1;;n]]]},{n,3,18}],PlotMarkers->Automatic,PlotRange->All]

Quantum thermodynamics

Work distribution & moments

The work distribution reads

P(W)=(∑_(n,m)) (Subscript[p, n ])|⟨m|U|n⟩((|)^2) δ(W - ((Subscript[E, m]^f)-(Subscript[E, n]^i))) 

The characteristic function is 

G(k)=⟨(e^(i k W))⟩ =tr((U^†)(e^(i k (Subscript[H, f]))) U (e^(-i k (Subscript[H, i])))(Subscript[ρ, d]) )

where (Subscript[ρ, d]) is the initial state, but diagonal in the basis of (Subscript[H, 0]).

The n-th moment can be computed as ⟨(W^n)⟩ = (i^(-n)) (G^((n)))(0). Carrying out the derivatives, we then find

⟨(W^n)⟩ = (∑_( k = 0)^( n)) (((-1))^(n-k)) (({{n}, {k}})) (Subscript[⟨(Subscript[(OverTilde[H]), 1]^k) (Subscript[H, 0]^(n-k))⟩, i])    where (Subscript[(OverTilde[H]), 1]) = U†(Subscript[H, 1])U

Usage

WorkMoments[n_,y_,Hi_,Hf_]
Moments of the work distribution for a sudden quench, U = 𝕀. 
This function is fairly fast to be evaluated.
Input: 
- n: moment 
- y: initial state. Can be either pure, y = ψ, or mixed, y = ρ. 
      For the purpose of speed, the function does not test if [(Subscript[H, i]),ρ] = 0 or not. 
      If this is not true, the resulting distribution becomes a quasi-probability. 
- Hi: initial Hamiltonian 
- Hf: final Hamiltonian 

WorkMoments[n_,y_,Hi_,Hf_,U_]
Same, but for a generic work protocol with unitary U. 
User has to supply U, computed by some other mean. 

WorkDistribution[Hi_,Hf_,ρ0type_,y_]
WorkDistribution[Hi_,Hf_,ρ0type_,y_,U_]
Full work distribution P(W) for a quench or for a finite-time work protocol (when U is provided).

ρ0type: type of initial state.  
y: auxiliary numerical quantity, which changes depending on ρ0type. 
- ρ0type == “GS”: ground-state. In this case the value of y is irrelevant. 
- ρ0type == “thermal”: thermal state. In this case y = β = 1/T
- ρ0type == “eigenstate”: a specific eigenstate of the Hamiltonian. In this case y = 1,2,...,d labels the eigenstate, with y = 1 being the GS. 
- ρ0type == “identity”: infinite temperature state. Value of y is irrelevant. 
-ρ0type == “generic”: in this case y = ρ  is a generic initial state; the initial probabilities are computed as (Subscript[p, n])= ⟨n|ρ|n⟩.

Moments of work

(* MatrixPower but with (A^0)=identity, even if A is singular *)
matrixpower[A_,n_]:=If[n==0,Eye[Length@A],MatrixPower[A,n]]
matrixpower[A_,n_,y_]:=If[n==0,y,MatrixPower[A,n,y]]

Clear[WorkMoments];
WorkMoments[nn_,y_,Hi_,Hf_]:=Module[{n,Y,result},
(*If[checkCommute[Hi,y]==False,Print["Initial state does not commute with Hi"]];*)
result=Which[
y[[1]]==="thermal",
Y = MatrixExp[-y[[2]] Hi];
Y = Y/Tr[Y];

Table[Sum[(((-1))^(n-k))Binomial[n,k] Tr[matrixpower[Hf,k].matrixpower[Hi,n-k].Y],{k,0,n}],{n,Flatten[{nn}]}],

y[[1]]=="GS",
Y = GroundState[Hi];
Re@Table[Sum[(((-1))^(n-k))Binomial[n,k] Conjugate[matrixpower[Hf,k,Y]].matrixpower[Hi,n-k,Y],{k,0,n}],{n,Flatten[{nn}]}],

y[[1]]=="eigenstate",
Y = GroundState[Hi,y[[2]]];
Re@Table[Sum[(((-1))^(n-k))Binomial[n,k] Conjugate[matrixpower[Hf,k,Y]].matrixpower[Hi,n-k,Y],{k,0,n}],{n,Flatten[{nn}]}],

Length@Dimensions@y==2,
Table[
Sum[(((-1))^(n-k))Binomial[n,k] Tr[matrixpower[Hf,k].matrixpower[Hi,n-k].y],{k,0,n}],{n,Flatten[{nn}]}],

True,Table[Sum[(((-1))^(n-k))Binomial[n,k] Conjugate[matrixpower[Hf,k,y]].matrixpower[Hi,n-k,y],{k,0,n}],{n,Flatten[{nn}]}]
]//Chop;
If[Head[nn]===List,result,First@result]
]
WorkMoments[n_,y_,Hi_,Hf_,U_]:=WorkMoments[n,y,Hi,U\[ConjugateTranspose].Hf.U]

getCumulants[moms_]:=Module[{nmoms = Length@moms,rep,n},
rep = Thread[Table[Moment[j],{j,nmoms}]->moms];
Table[MomentConvert[Cumulant[n],Moment]/.rep,{n,1,nmoms}]]

Full work distribution

ProbMerger[x_,P_,tol_:(10^(-11))]:=List@@@Normal[GroupBy[Table[{N[Round[x[[i]],tol]],P[[i]]},{i,1,Length[x]}],First-> Last,Total]]

(* Full work distribution *)
Clear[WorkDistribution];
WorkDistribution[Hi_,Hf_,ρ0type_,y_,U_:1,mergetol_:(10^(-11))]:=Module[{ord,i,Ei,Vi,Ef,Vf,ℳ,𝒬,d = Length@Hi,pi,works,probs},
{Ei,Vi} =Eigsys[Hi]; 
{Ef,Vf} =If[U===1,Eigsys[Hf],Eigsys[U\[ConjugateTranspose].Hf.U]];
𝒬 = ((Abs[Vf\[ConjugateTranspose].Vi])^2) (* The matrix |⟨j|U|i⟩((|)^2) *);

(* Initial probabilities *)
Which[
(* ground-state *)
ρ0type =="GS",
pi=IdentityMatrix[d][[1]],

(* Thermal: in this case y = β = 1/T *)
ρ0type=="thermal",
(pi = Table[Exp[-y(Ei[[i]]-Ei[[1]])],{i,1,d}];
pi = pi/Total@pi;
),

(* Eigenstate of (Subscript[H, i]). In this case y labels the eigenstate, with y = 1 being the GS *)
ρ0type =="eigenstate",
pi = IdentityMatrix[d][[y]],

(* Infinite temperature state *)
ρ0type =="identity",
pi = ConstantArray[1/d,{d}],

(* Generic. In this case y is the initial density matrix *)
ρ0type=="generic",
pi = Table[Vi[[All,i]]\[Conjugate].y.Vi[[All,i]],{i,d}]
];

works = Flatten@Table[ef-ei,{ei,Ei},{ef,Ef}];
probs = Flatten@Table[𝒬[[j,i]] pi[[i]],{i,d},{j,d}];
ord = Ordering[works];

Select[ProbMerger[works[[ord]],probs[[ord]],mergetol],Abs[#[[2]]]>(10^(-10))&]
]

(*WorkDistribution[Hi_,Hf_,ρ0type_,y_,U_]:=WorkDistribution[Hi,U\[ConjugateTranspose].Hf.U,ρ0type,y]*)

Example usage

(* Build two tight-binding Hamiltonians with different on-site potentials *)
Hi = TightBindingModel[{1,-1},30];
Hf = TightBindingModel[{1,0,1},30];

(* Work distribution starting from a thermal state at β = 0.5 *)
P=WorkDistribution[Hi,Hf,"thermal",0.5];
ListLinePlot[P,PlotMarkers->Automatic,PlotRange->{{-.5,1.5},All}]

(* First few moments *)
P[[All,1]].P[[All,2]]
((P[[All,1]])^2).P[[All,2]]
((P[[All,1]])^3).P[[All,2]]

(* Instead, the moments can be computed directly with the WorkMoments function, which is faster *)
y = MatrixExp[-0.5 Hi];
y = y/Tr[y];
WorkMoments[1,y,Hi,Hf]
WorkMoments[2,y,Hi,Hf]
WorkMoments[3,y,Hi,Hf]

(* Starting from the GS. Last entry "0" is irrelevant *)
P=WorkDistribution[Hi,Hf,"GS",0];
ListLinePlot[P,PlotMarkers->Automatic(*,PlotRange->{{-.5,1.5},All}*)]

(* First few moments *)
P[[All,1]].P[[All,2]]
((P[[All,1]])^2).P[[All,2]]
((P[[All,1]])^3).P[[All,2]]

y = Eigvecs[Hi,1]//Flatten;
WorkMoments[1,y,Hi,Hf]
WorkMoments[2,y,Hi,Hf]
WorkMoments[3,y,Hi,Hf]

Example: macrospin model with a finite unitary

LoadArbitrarySpinMatrices[S = 50];
Hi = Sz;
Hf = Sz;
U = MatrixExp[-I (Sz - 0.5 Sx) ];
P = WorkDistribution[Hi,Hf,"thermal",0.1,U]//Quiet;

ListLinePlot[P,PlotMarkers->Automatic,PlotRange->All]

WorkMoments[2,{"thermal",1},Hi,Hf,U]

WorkMoments[2,{"GS"},Hi,Hf,U]

ψ = GroundState[Hi];
WorkMoments[2,ψ,Hi,Hf,U]

WorkMoments[2,{"eigenstate",2},Hi,Hf,U]

Example: LMG model with a finite ramp

LoadArbitrarySpinMatrices[S=49/2];
𝒩 = 2S+1;
ℋ[h_]:=-(2/𝒩) Sx.Sx-2 h Sz;
Hi= ℋ[hi=0.5];
Hf=ℋ[hf=1.5];
τ = 2.0;
(*U = UnitaryDynamics[{-(2/𝒩) Sx.Sx,-2 Sz},{Function[t,1],Function[t,hi+(hf-hi) t/τ]},0.005,τ];*)
P1 = WorkDistribution[Hi,Hf,"GS",1]//Quiet;

Hf=ℋ[1.0];
P2 = WorkDistribution[Hi,Hf,"GS",1]//Quiet;

P1b = {#[[1]]+Egs,#[[2]]}&/@P1;
P2b = {#[[1]]+Egs,#[[2]]}&/@P2;
Egs=Eigvals[Hi,1][[1]];

ListPlot[{P1b,P2b},PlotMarkers->Automatic,PlotRange->{{-80,-20},{0,1}},Filling->Axis,AspectRatio->1/5]

LoadArbitrarySpinMatrices[S=49/2];
𝒩 = 2S+1;
ℋ[h_]:=-(2/𝒩) Sx.Sx-2 h Sz;
Hi= ℋ[hi=0.5];
Hf=ℋ[hf=1.5];
τ = 10.5;
PrettyTiming[U = UnitaryDynamics[{-(2/𝒩) Sx.Sx,-2 Sz},{Function[t,1],Function[t,hi+(hf-hi) t/τ]},0.002,τ,"id","RK4"];]
P = WorkDistribution[Hi,Hf,"GS",1,U]//Quiet;

PrettyTiming[U = UnitaryDynamics[{-(2/𝒩) Sx.Sx,-2 Sz},{Function[t,1],Function[t,hi+(hf-hi) t/τ]},0.1,τ,"id","Trotter"];]
P2 = WorkDistribution[Hi,Hf,"GS",1,U]//Quiet;

ListLinePlot[{P,P2},PlotMarkers->Automatic,PlotRange->All]

Thermo-Majorization curve

(* Given probabilities and energies, yields the points (x,y) of a thermo-majorization curve *)
ThermoMajorizationCurve[pps_,Es_,β_]:=Module[{ord,x,y,ps},
ps = pps/Total[pps];
ord=Reverse@Ordering[ps Exp[β Es]];
y=Prepend[Accumulate[ps[[ord]]],0];
x = Prepend[Accumulate[Exp[-β Es][[ord]]],0]//N;
Transpose[{x,y}]
]

Example usage

β = 1.0;
Es = {1.4,2,3.,2.5} (* energies *);
probs = {5,4,3,5} (* probs; don't have to be normalized *);
thermocurve = ThermoMajorizationCurve[probs,Es,β]

ListLinePlot[thermocurve,PlotMarkers->Automatic,PlotRange->All]

Ergotropy

Ergotropy[H_,ρ_]:=Module[{P,ℰ,psiRho,psiH},
{P,psiRho}=Eigensystem[N@ρ];
{ℰ,psiH}=Eigensystem[1000 NEye[Length@H]-H];
ℰ = 1000 - ℰ;
Sum[P[[i]] ℰ[[j]](((Abs[psiH[[j]]\[Conjugate].psiRho[[i]]])^2)-KroneckerDelta[i,j]),{i,Length@ρ},{j,Length@H}]
]

Metrology

QFI & SLD for Gaussian states can be found in the “Gaussian bosonic systems” section.

Quantum Fisher Information

QuantumFisherInformation[ρ_,dρ_]:=2Vec[dρ\[Transpose]].LinearSolve[kron[ρ\[Transpose],Eye[Length@ρ]]+kron[Eye[Length@ρ],ρ],Vec[dρ]]//Chop(*2Vec[dρ\[Transpose]].PseudoInverse[kron[ρ\[Transpose],NEye[Length@ρ]]+kron[NEye[Length@ρ],ρ]].Vec[dρ]*)

SymmetricLogarithmicDerivative[ρ_,dρ_]:=Module[{n,A,b},
n = Length@ρ;
A = kron[ρ\[Transpose],Eye[n]] + kron[Eye[n],ρ];
b = 2 Vec[dρ];
LinearSolve[A,b]//Unvec
]

Example usage

Quantum thermometry

ρ = (({{f, 0}, {0, 1-f}}))/.f->(1/((E^(ω/T))+1));
dρ = D[ρ,T];
QuantumFisherInformation[ρ,dρ]//Simplify

(* The SLD in this case is diagonal *)
SymmetricLogarithmicDerivative[ρ,dρ]//Simplify//mf;

SLD: Explicit formula for a qubit

Symmetric logarithmic derivative:

ρ = (({{p, q}, {qs, 1-p}}));
dρ = (({{dp, dq}, {dqs, -dp}}));

Λ = (({{((-(-1+p) (dq\[Conjugate] q + dq q\[Conjugate])+dp (-1+p + 2 q q\[Conjugate]))/(-p+(p^2)+q q\[Conjugate])), ((q (dp-2 dp p-dq\[Conjugate] q)+dq (-2 p+2 (p^2)+q q\[Conjugate]))/(-p+(p^2)+q q\[Conjugate]))}, {((q\[Conjugate] (dp-2 dp p-dq q\[Conjugate])+dq\[Conjugate] (-2 p+2 (p^2)+q q\[Conjugate]))/(-p+(p^2)+q q\[Conjugate])), ((dp p+dq\[Conjugate] p q+dq p q\[Conjugate]-2 dp q q\[Conjugate])/(-p+(p^2)+q q\[Conjugate]))}}))

Gammelmark-Mølmer Quantum Fisher information for continuous measurements

Based on https://link.aps.org/doi/10.1103/PhysRevLett.112.170401
(Eq. 21 of the Supplemental Material)

(This is the starting point for the Hasegawa bound https://link.aps.org/doi/10.1103/PhysRevLett.125.050601)

I focus here on the estimation of a single parameter for simplicity. 
Input: 
- Steady-state ρ
- Liouvillian ℒ 
- Hamiltonian H
- Derivative of H wrt to θ, H’
- List of jump operators {(Subscript[L, k])}
- List of derivatives of the jump operators {(Subscript[L, k]^('))}.

Note: formula only makes sense if ρ is the steady-state.

Clear[GammelmarkMolmerMFisher];
GammelmarkMolmerMFisher[ρ_,ℒ_, H_,Hp_,cops_,copsprime_]:=Module[{op1,𝕀,op2,ℒL,ℒR,ℒinv,outie},
op1 = -I Hp - (1/2)Sum[copsprime[[k]]\[ConjugateTranspose].cops[[k]] + cops[[k]]\[ConjugateTranspose].copsprime[[k]],{k,Length@cops}];
op2 = I Hp - (1/2)Sum[copsprime[[k]]\[ConjugateTranspose].cops[[k]] + cops[[k]]\[ConjugateTranspose].copsprime[[k]],{k,Length@cops}];
𝕀 = Eye[Length@H];
ℒL=kron[𝕀, op1] + Sum[kron[cops[[k]]\[Conjugate],copsprime[[k]]],{k,Length@cops}];
ℒR=kron[op2\[Transpose],𝕀] + Sum[kron[copsprime[[k]]\[Conjugate],cops[[k]]],{k,Length@cops}];


(*outie = Eye[Length@ℒ]  - out[Vec[ρ], Vec[Eye[Length@ρ]]];
ℒinv = outie.PseudoInverse[ℒ].outie;
4Re@(Sum[Tr[c.ρ.c\[ConjugateTranspose]],{c,copsprime}]- UnTr[ℒL.ℒinv.ℒR.Vec[ρ]]-UnTr[ℒR.ℒinv.ℒL.Vec[ρ]])*)
4Re@(Sum[Tr[c.ρ.c\[ConjugateTranspose]],{c,copsprime}]- UnTr[ℒL.DrazinApply2[ℒ,Vec[ρ],ℒR.Vec[ρ]]]-UnTr[ℒR.DrazinApply2[ℒ,Vec[ρ],ℒL.Vec[ρ]]])
]

Example usage: non-resonant qubit

Reproducing Fig. 1 of the paper (1310.5802)

Clear[Δ,Ω,κ];
H = (Δ/2)σz + (Ω/2)σx;
cops = {(Sqrt[κ])σm};
ℒ = Liouvillian[H,cops]//cf;
ρ = AnalyticalSteadyState[ℒ]//Simplify//mf;

FΔ=GammelmarkMolmerMFisher[ρ,ℒ,H,Evaluate@D[H,Δ],cops,Evaluate@D[cops,Δ]]//cf
FΩ=GammelmarkMolmerMFisher[ρ,ℒ,H,Evaluate@D[H,Ω],cops,Evaluate@D[cops,Ω]]//cf
Fκ=GammelmarkMolmerMFisher[ρ,ℒ,H,Evaluate@D[H,κ],cops,Evaluate@D[cops,κ]]//cf

Grid[{{
Plot[FΔ/.{κ->1/2,Ω->1},{Δ,0,1.5},AspectRatio->1/3,PlotRange->{0,1},FrameLabel->{None,"(Subscript[I, ΔΔ])/T"}],
Plot[FΩ/.{κ->1/2,Ω->1},{Δ,0,1.5},AspectRatio->1/3,PlotRange->{0,8},FrameLabel->{None,"(Subscript[I, ΩΩ])/T"}],
Plot[Fκ/.{κ->1/2,Ω->1},{Δ,0,1.5},AspectRatio->1/3,PlotRange->{0,1},FrameLabel->{"Δ","(Subscript[I, κκ])/T"}]}}\[Transpose]]

Kiilerich-Mølmer result: Fisher information from 2-point functions of a homodyne signal

Based on 1605.00902
The contribution of the sample mean to the Fisher information is 

(ℐ^((1))) = τ ((((∂_θ)J))^2)

The contribution from the two-point function is 

(ℐ^((2))) = τ (∫_0^∞) ((dτ [(∂_θ)F(τ)])^2) = (τ/(4π)) (∫_(-∞)^∞) ((dω [(∂_θ)S(ω)])^2)

The actual Fisher information of the homodyne signal, (ℐ^((hom))) will be bounded by 

(ℐ^Quantum) ≥ (ℐ^((hom))) ≥ (ℐ^((1)))+ (ℐ^((2)))

Reproducing Fig. 3(b) of the paper (1605.00902)

Clear[Δ,Ω,κ];
H =  (Ω/2)σx;
c = (Sqrt[κ])σm;
ℒ = Liouvillian[H,{c}]//cf;
ρ = AnalyticalSteadyState[ℒ]//Simplify//mf;

Clear[κ];
J = FCSAverage[ρ,ℒ,{c (E^(-I π/2))},1,"Homodyne"]//cf
S = FCSPowerSpectrumLinearSys[{ω},ρ,ℒ,{c (E^(-I π/2))},1,"Homodyne"][[1,2]]//cf
G2 = FCSG2MEXP[{τ},ρ,ℒ,{c (E^(-I π/2))},1,"Homodyne"][[1,2]]//cf
F = G2 - (J^2)//cf

ℐ1 = ((D[J,Ω])^2)//cf

dF=D[F,Ω]//cf;
dS = D[S,Ω];

κ = 1;
ℐ2 = Table[{Ω,NIntegrate[(dF^2),{τ,0,∞}]},{Ω,0.01,2,0.041}]//Quiet;

ℐ22 = Table[{Ω,(1/(4π))NIntegrate[(dS^2),{ω,-∞,∞}]},{Ω,0.01,2,0.041}]//Quiet;

Show[
Plot[ℐ1,{Ω,0,2},PlotStyle->blue],
ListLinePlot[ℐ22,PlotStyle->Directive[red,Dashed]],
GridLines->{None,{4}},
GridLinesStyle->Directive[Black, Dashed]
]

int = (dS^2)//cf

int2=Integrate[int,{ω,0,∞},Assumptions->Ω>1]

Show[
Plot[{ℐ1,(1/(2π))Re@int2},{Ω,0,2},PlotStyle->blue],
GridLines->{None,{4}},
GridLinesStyle->Directive[Black, Dashed]
]

Sequential Max-likelihood

Useful for visualization: max-likelihood estimator implemented sequentially, to show how adding more data improves the estimation procedure.

Clear[SequentialMaxLikelihood];
SequentialMaxLikelihood[loglike_,outcomes_,θgrid_,outputstep_:1]:=Module[{ll,posML,Lmax,θmax},
ll = Accumulate@Table[loglike[x,θ],{x,outcomes},{θ,θgrid}];
posML = First@Ordering[#,-1]&/@ll;
(*Lmax=Max/@ll;*)
θmax = θgrid[[posML]];
θmax[[1;;-1;;outputstep]]
]

Clear[MeanSquaredError];
MeanSquaredError[θest_?MatrixQ,θreal_]:=Mean/@Transpose[(((θest-θreal))^2)]
MeanSquaredError[θest_?VectorQ,θreal_]:=MeanSquaredError[{θest},θreal]

Example usage

Log[PDF[ExponentialDistribution[θ],x]]

r = RandomVariate[ExponentialDistribution[1.5],5000];
θs = linspace[0.01,3,1000];

ListLinePlot[SequentialMaxLikelihood[Function[{x,θ},-x θ + Log[θ]],r,θs],GridLines->{None,{1.5}}]

Channels and gates

All channels and gates are applicable to act on states of L qubits.
- For instance, one may apply an Amplitude Damping channel to qubit 5, in an entangled state of 8 qubits. 
- Or one may apply a SWAP between qubits 3 and 6.

Amplitude damping

γ ∈ [0,1] gives the strength of the interaction, with γ = 0 being the identity map and γ  = 1 being full thermalization

If γ = 1 the system will thermalize to (({{f, 0}, {0, 1-f}}))

Clear[AmplitudeDampingKrausOperators];
AmplitudeDampingKrausOperators[f_,γ_]:=Module[{M},
M[0] = (Sqrt[f])(({{1, 0}, {0, (Sqrt[1-γ])}}));
M[1] = (Sqrt[f])(({{0, (Sqrt[γ])}, {0, 0}}));
M[2] = (Sqrt[1-f])(({{(Sqrt[1-γ]), 0}, {0, 1}}));
M[3] = (Sqrt[1-f])(({{0, 0}, {(Sqrt[γ]), 0}}));
{M[0],M[1],M[2],M[3]}

]

Clear[AmplitudeDamping];
AmplitudeDamping[f_,γ_][ρ_]:=Module[{M = AmplitudeDampingKrausOperators[f,γ]},Total@Table[M[[i]].ρ.M[[i]]\[Transpose],{i,Length@M}]]

AmplitudeDamping[f_,γ_,qubit_][ρ_]:=Module[{M = AmplitudeDampingKrausOperators[f,γ]},
Total@Table[KronEye[M[[i]],Log2[Length@ρ],qubit].ρ.KronEye[M[[i]],Log2[Length@ρ],qubit]\[Transpose],{i,Length@M}]

]

Example usage

AmplitudeDampingKrausOperators just gives a list of the 4 Kraus operators for the finite temperature amplitude damping:

mf/@AmplitudeDampingKrausOperators[f,γ];

To apply the map use AmplitudeDamping[f,γ][ρ]

ρ = (({{p, q}, {qs, 1-p}}));

AmplitudeDamping[f,1][ρ]//Simplify//mf;

nn = (1/((E^x)-1));
(nn/(2nn+1))//Simplify

You can also enter a density matrix living in a higher dimensional Hilbert space and apply the map only in one qubit. 
To do that, use AmplitudeDamping[f, γ, i][ρ] where i is the position of the qubit you wish to apply.

ρAB = kron[(({{p, q}, {qs, 1-p}})),(({{1, 0}, {0, 0}}))];

This will apply the map on qubit 1

ρABprime=AmplitudeDamping[f,γ,1][ρAB]//Simplify//mf;

One can check that indeed only qubit 1 was affected

PTr[ρABprime,{2}]//Simplify//mf;
PTr[ρABprime,{1}]//Simplify//mf;

Similarly, we can apply it in 2

ρABprime2=AmplitudeDamping[f,γ,2][ρAB]//Simplify//mf;

Now the reduced density matrices become:

PTr[ρABprime2,{2}]//Simplify//mf;
PTr[ρABprime2,{1}]//Simplify//mf;

SWAP and partial SWAP

SWAPs qubits a and b in a system with L qubits.
Default is for two qubits, and can be called as SWAP[]

Clear[SWAP]
SWAP[a_,b_,L_]:=Module[{𝕀,σx,σy,σz},

𝕀 = Eye[(2^L)];
σx = {{0,1},{1,0}};
σy = {{0,-I},{I,0}};
σz = {{1,0},{0,-1}};

(1/2)(𝕀 + KronEye[σx,L,a].KronEye[σx,L,b]+ KronEye[σy,L,a].KronEye[σy,L,b]+ KronEye[σz,L,a].KronEye[σz,L,b])
]

SWAP[]:=SWAP[1,2,2];

Partial swap with s ∈ [0,1]. 
s = 1 is full swap

Clear[PartialSWAP]
PartialSWAP[s_,a_,b_,L_]:=( -I (Sqrt[1-(s^2)]) Eye[(2^L)] +s SWAP[a,b,L])

A variation of the partial SWAP in which the operator is real.

Clear[RealPartialSWAP];
RealPartialSWAP[s_,a_,b_,L_]:=Module[{𝒳,σp,σm},
σp = {{0,1},{0,0}};
σm = {{0,0},{1,0}};
𝒳 = KronEye[σp,L,a].KronEye[σm,L,b]-KronEye[σm,L,a].KronEye[σp,L,b];
Eye[(2^L)] + s 𝒳 +(1-(Sqrt[1-(s^2)]))𝒳.𝒳
]

Example usage

(* SWAP 1 and 2 in a system with 2 qubits *)
SWAP[]//mf;

(* This is equivalent to *)
SWAP[1,2,2]//mf;

(* SWAP 1 and 2 in a system with 3 qubits *)
SWAP[1,2,3]//mf;

(* SWAP 1 and 3 in a system with 3 qubits *)
SWAP[1,3,3]//mf;

(* Qubit 1 prepared in ψ. Qubits 2 and 3 prepared in |0> *)
ψ = {Cos[θ/2],Sin[θ/2]};
Ψ = kronV[ψ,{1,0},{1,0}]//mf;

Ψprime = SWAP[1,3,3].Ψ//mf;

(* Trace over 2 and 3, we get |0> for qubit 1 and ψ for qubit 3*)
PTr[out[Ψprime,Ψprime],{2,3}]//cf//mf;
PTr[out[Ψprime,Ψprime],{1,3}]//cf//mf;
PTr[out[Ψprime,Ψprime],{1,2}]//cf//mf;

PartialSWAP[s,1,2,3]//mf;

PartialSWAP[s,1,2,3].Ψ//mf;

CNOT

CNOT between control qubit a and target qubit b in a system with L qubits.

Clear[CNOT]
CNOT[a_,b_,L_]:=Module[{σ0,σx,σp,σm},

σ0 = {{1,0},{0,1}};
σx = {{0,1},{1,0}};
σp = {{0,1},{0,0}};
σm = {{0,0},{1,0}};

(* Partial SWAP *)
KronEye[σp.σm,L,a].KronEye[σ0,L,b]+ KronEye[σm.σp,L,a].KronEye[σx,L,b]
]

(*CNOT[] := Normal@CNOT[1,2,2];*)
CNOT[]:=(({{1, 0, 0, 0}, {0, 1, 0, 0}, {0, 0, 0, 1}, {0, 0, 1, 0}}));

CNOT::usage = "CNOT[] calls the standard 4x4 CNOT gate. 

CNOT[a,b,L] loads a CNOT gate in a space of L qubits, with a (=1,...,L) being the control qubit and b (=1,...,L) the target qubit. 

CNOT[1,2,2] is equivalent to CNOT[].";

Example usage

CNOT[1,2,2]//mf;

(* One can construct the Bell basis by applying a Hadamard followed by a CNOT *)
H = kron[(1/(Sqrt[2]))(({{1, 1}, {1, -1}})),Eye[2]];
v0 = {1,0};
v1 = {0,1};
CNOT[1,2,2].H.kronV[v0,v0]
CNOT[1,2,2].H.kronV[v0,v1]
CNOT[1,2,2].H.kronV[v1,v0]
CNOT[1,2,2].H.kronV[v1,v1]

Two CNOTs

CNOT[1,2,2].CNOT[2,1,2]//mf;

Three CNOTs become a SWAP

CNOT[1,2,2].CNOT[2,1,2].CNOT[1,2,2]//mf;
SWAP[1,2,2]//mf;

CNOT applied between 1 and 3 in a 3-qubit system

CNOT[1,3,3]//mf;

Hadamard & Toffoli gate

Clear[Hadamard]
Hadamard[]:=(1/(Sqrt[2]))(({{1, 1}, {1, -1}}));
Hadamard[i_,𝒩_]:=kron[Eye[(2^(i-1))],(({{(1/(Sqrt[2])), (1/(Sqrt[2]))}, {(1/(Sqrt[2])), -(1/(Sqrt[2]))}})),Eye[(2^(𝒩-i))]]
Hadamard::usage = "Hadamard[] calls the 2x2 Hadamard matrix. 

Hadamard[i,𝒩] is a Hadamard gate on qubit i, in a space of 𝒩 qubits";

Clear[Toffoli]
Toffoli[a_,b_,c_,L_]:=Module[{σ0,σx,σp,σm},

σ0 = {{1,0},{0,1}};
σx = {{0,1},{1,0}};
σp = {{0,1},{0,0}};
σm = {{0,0},{1,0}};

(* Partial SWAP *)
KronEye[σp.σm,L,a].KronEye[σm.σp,L,b].KronEye[σ0,L,c]+KronEye[σm.σp,L,a].KronEye[σp.σm,L,b].KronEye[σ0,L,c]+KronEye[σp.σm,L,a].KronEye[σp.σm,L,b].KronEye[σ0,L,c]+ KronEye[σm.σp,L,a].KronEye[σm.σp,L,b].KronEye[σx,L,c]
]

Example usage

tmp=Toffoli[1,2,3,3]//mf;

tmp\[ConjugateTranspose].tmp//mf;

Toffoli[2,3,1,3]-Toffoli[3,2,1,3]//mf;

Full dephasing map

(* Dephases A in the eigenbasis of X *)
Clear[FullDephasingMap]
FullDephasingMap[A_,X_,degeneracy_:False]:=Module[{λ,v,kd},

{λ,v}=Eigsys[X];
v=v\[Transpose];
kd[a_,b_,tol_:(10^(-10))] := If[Abs[a-b]<tol,1,0];
If[degeneracy===False,
Total@Table[(v[[i]]\[Conjugate].A.v[[i]]) out[v[[i]],v[[i]]],{i,Length@v}],
Total@Flatten[Table[(v[[i]]\[Conjugate].A.v[[j]]) out[v[[i]],v[[j]]] kd[λ[[i]],λ[[j]]],{i,Length@λ},{j,Length@λ}],1]]
]

Example usage

LoadArbitrarySpinMatrices[1];
ρ = MatrixExp[Sz+Sx];
ρ = ρ/Tr[ρ]//mf;

(* Dephase in the eigenbasis of Sz *)
FullDephasingMap[ρ,Sz]//mf;

(* Dephasing in the full eigenbasis of Sx *)
FullDephasingMap[ρ,Sx]//mf;

(* Dephasing in the full eigenbasis of (Sz^2) *)
(* Since (Sz^2) is degenerate, one can choose to dephase with or without taking degeneracies into account *)
(* Default is without degeneracies *)
FullDephasingMap[ρ,Sz.Sz]//mf;

(* With degeneracies, the map keeps the coherences between degenerate subspaces *)
FullDephasingMap[ρ,Sz.Sz,True]//mf;

Open quantum systems

Vectorization-based routines

Vectorization

(* Not vectorized *)
Clear[LindbladDissipator]
LindbladDissipator[A_,ρ_]:=A.ρ.A\[ConjugateTranspose]-(1/2)(A\[ConjugateTranspose].A.ρ+ρ.A\[ConjugateTranspose].A);
LindbladDissipator[A_,B_,ρ_]:=A.ρ.B-(1/2)(B.A.ρ+ρ.B.A);

Vec[X_]:=Flatten[X\[Transpose]];
Unvec[x_]:=With[{d = (Sqrt[Length@x])},Partition[x,d]\[Transpose]];
UnTr[X_]:=Tr@Unvec@X

LindbladToVec[L_]:=With[{ℐ = Eye[Length@L]},kron[Conjugate[L],L]-(1/2)kron[(L\[ConjugateTranspose].L)\[Transpose],ℐ]-(1/2)kron[ℐ,L\[ConjugateTranspose].L]]
UnitaryToVec[H_]:=With[{ℐ = Eye[Length@H]},-I (kron[ℐ,H]- kron[H\[Transpose],ℐ])]

Liouvillian[H_,cops_]:=Module[{c},
If[Length[H]!=Length[cops[[1]]],0,UnitaryToVec[H]]+ Sum[LindbladToVec[c],{c,cops}]]

Liouvillian[H_,cops_,rates_]:=Module[{c},
If[Length[H]!=Length[cops[[1]]],0,UnitaryToVec[H]] + Sum[rates[[i]] LindbladToVec[cops[[i]]],{i,Length@cops}]]

Clear[JumpOp];
(*JumpOp[c_,type_:"PD"]:=If[type==="PD",
kron[c\[Conjugate],c],
kron[Eye[Length@c],c]+kron[c\[Conjugate],Eye[Length@c]]
]*)

JumpOp[c_,type_:"PD"]:=
Which[
matchString["PD",type],kron[c\[Conjugate],c],
matchString["Homodyne",type],kron[Eye[Length@c],c]+kron[c\[Conjugate],Eye[Length@c]],
True,kron[Eye[Length@c],c]+kron[c\[Conjugate],Eye[Length@c]]
]

Clear[EffectiveNonHermitianHamiltonian];
EffectiveNonHermitianHamiltonian[H_,cops_]:=Module[{c},
H -(I/2)Sum[c\[ConjugateTranspose].c,{c,cops}]]

EffectiveNonHermitianHamiltonian[H_,cops_,rates_]:=Module[{c},
H -(I/2) Sum[rates[[i]] cops[[i]]\[ConjugateTranspose].cops[[i]],{i,Length@cops}]]

! Basis-dependent vectorization & Kamiya’s effective Liouvillian

Clear[VecDiagsOrdering];
VecDiagsOrdering[d_]:=Module[{diags=Table[(d+1)i - d,{i,1,d}]},
Join[diags,Complement[Range[1,(d^2)],diags]]];

Clear[VecDiags];
VecDiags[X_]:=Vec[X][[VecDiagsOrdering[Length@X]]]
VecDiags[X_,S_]:=Chop@VecDiags[S\[ConjugateTranspose].X.S]

Clear[UnvecDiags];
UnvecDiags[X_]:=X[[Ordering@VecDiagsOrdering[(Sqrt[Length@X])]]]//Unvec;
UnvecDiags[X_,S_]:=S.UnvecDiags[X].S\[ConjugateTranspose]//Chop;

Clear[LindbladToVecDiags]
LindbladToVecDiags[L_]:=Module[{ord = VecDiagsOrdering[Length@L]},LindbladToVec[L][[ord,ord]]];
LindbladToVecDiags[L_,S_]:=Module[{ord = VecDiagsOrdering[Length@L]},LindbladToVec[S\[ConjugateTranspose].L.S][[ord,ord]]];

Clear[UnitaryToVecDiags];
UnitaryToVecDiags[H_]:=Module[{ord = VecDiagsOrdering[Length@H]},UnitaryToVec[H][[ord,ord]]];
UnitaryToVecDiags[H_,S_]:=Module[{ord = VecDiagsOrdering[Length@H]},UnitaryToVec[S\[ConjugateTranspose].H.S][[ord,ord]]];

Clear[LiouvillianDiags];
LiouvillianDiags[H_,cops_,rates_]:=Module[{ord = VecDiagsOrdering[Length@H]},Liouvillian[H,cops,rates][[ord,ord]]]
LiouvillianDiags[H_,cops_,rates_,S_]:=Module[{ord = VecDiagsOrdering[Length@H]},Liouvillian[S\[ConjugateTranspose].H.S,S\[ConjugateTranspose].#.S&/@cops,rates][[ord,ord]]]

AnalyticalSteadyStateDiags[ℒ_]:=Module[{ℒ2,d,ρ},d=Length@ℒ;
(*ℒ2=Join[ℒ,{ConstantArray[1,d]}];*)ℒ2=Normal@Join[ℒ,{Vec@Eye[Sqrt[d]]}];
ρ=UnvecDiags@LinearSolve[ℒ2,Eye[d+1][[-1]]];
ρ]
(*Specify the vectorized identity matrix 𝕀.Output in this case is not unvectorized.*)
AnalyticalSteadyStateDiags[ℒ_,𝕀_]:=Module[{ℒ2,d},d=Length@ℒ;
ℒ2=Normal@Join[ℒ,Normal@{𝕀}];
LinearSolve[ℒ2,Eye[d+1][[-1]]]]

(* Based on Norikazu Kamiya, Prog. Theor. Exp. Phys. 2015, 043A02 *)
(* Assumes ℒ was built using LiouvillianDiags[H_,cops_,rates_,S_] *)
KamiyaEffectiveLiouvillian[ℒ_]:=Module[{d,ℒpp,ℒcp,ℒpc,ℒcc},
d = (Sqrt[Length@ℒ]);
ℒpp = ℒ[[1;;d,1;;d]];
ℒpc = ℒ[[1;;d,d+1;;(d^2)]];
ℒcp = ℒ[[d+1;;(d^2),1;;d]];
ℒcc = ℒ[[d+1;;(d^2),d+1;;(d^2)]];
ℒpp - ℒpc.Inverse[ℒcc].ℒcp
]

KamiyaTransformedObservable[ℒ_,A_]:=Module[{d,ℒcp,ℒcc},
d = (Sqrt[Length@ℒ]);
ℒcp = ℒ[[d+1;;(d^2),1;;d]];
ℒcc = ℒ[[d+1;;(d^2),d+1;;(d^2)]];
(({{Eye[d], -ℒcp\[ConjugateTranspose].Inverse[ℒcc]}, {0, Eye[d]}})).A

]

Example usage: VecDiags & UnvecDiags

These functions vectorise using a specific basis choice. 
In the simplest case, VecDiags[X] will vectorize X ordering the diagonals first, and then the off-diagonals. 
For example

VecDiags[(({{a, b}, {c, d}}))] = (({{a}, {d}, {b}, {c}}))

Vec[Eye[2]]//mf;

VecDiags[Eye[2]]//mf;

VecDiags[X] and UnvecDiags[X] vectorizes/unvectorizes by listing the diagonals first

X = Table[(Subscript[x, i,j]),{i,3},{j,3}]//mf;

VecDiags[X]//mf;

(* Compare with: *) Vec[X]//mf;

If we want to use some other basis ordering, we can call VecDiags[X,S] and UnvecDiags[X,S].
Here S is a unitary matrix, whose columns are the eigenvectors of the basis we want to change.

Example:

S = (({{(1/(Sqrt[2])), 0, (1/(Sqrt[2]))}, {0, 1, 0}, {(1/(Sqrt[2])), 0, -(1/(Sqrt[2]))}}));
S.S\[ConjugateTranspose]//cf//mf;

VecDiags[X,S]//mf;

Example usage: Liouvillian

The same logic above also applies to the construction of the Liouvillian. 
The syntax is now LiouvillianDiags[H, cops, rates] or LiouvillianDiags[H, cops, rates, S].

The result is of the form 

LiouvillianDiags[H, cops, rates] = (({{(Subscript[ℒ, pp]), (Subscript[ℒ, pc])}, {(Subscript[ℒ, cp]), (Subscript[ℒ, cc])}})) where “p” stands for populations and “c” for coherences.

Qubit example:

LoadPauliMatrices[]
H = (ω/2)σz + (Ω/2)σx;
(* original vectorization *)ℒ = Liouvillian[H,{σm,σp},{γ (1-f),γ f}]//cf//mf;

(* ℒ listing the diagonals first *)
ℒdiags = LiouvillianDiags[H,{σm,σp},{γ (1-f),γ f}]//cf//mf;
(* This shows more clearly how Ω acts only on the block off-diagonals *)

We can also write ℒ in the basis that diagonalizes H, for example.
For simplicity I will assume ω =0, so H ∝ (Subscript[σ, x])

S=Eigenvectors[H/.ω->0];
S = FullSimplify[(Normalize/@S)\[Transpose],{ω>0,Ω>0}]//mf;

ℒEnergyDiags =LiouvillianDiags[H/.ω->0,{σm,σp},{γ (1-f),γ f},S]//Simplify//mf;

Example usage: Kamiya Effecive Liouvillian

Will be a good approximation when ω >> γ. 
That is, when the coherent component oscillates very quickly compared with the populations.

LoadPauliMatrices[]
H = (ω/2)σz + (Ω/2)σx;
ℒ = LiouvillianDiags[H,{σm,σp},{γ (1-f),γ f}]//cf//mf;

ρ = AnalyticalSteadyStateDiags@Liouvillian[H,{σm,σp},{γ (1-f),γ f}]//cf//mf;

ℒeff = KamiyaEffectiveLiouvillian[ℒ]//Simplify//mf;

(* Reproduces the diagonals exactly (?) *)
AnalyticalSteadyStateDiags[ℒeff,{1,1}]//Simplify

Steady-states of a master equation

(* Only meant for numerics *)
Clear[SteadyState];
SteadyState[A_]:=Module[{ρ,x},
x=SparseArray@First@Eigenvectors[A,-1];
ρ = Unvec[x] ;
ρ = (ρ+ρ\[HermitianConjugate]);
ρ = ρ/Tr[ρ]//Chop
];

Clear[AnalyticalSteadyState];
AnalyticalSteadyState[ℒ_]:=Module[{ℒ2,d,ρ},
d = Length@ℒ;
(*ℒ2 = Join[ℒ,{ConstantArray[1,d]}];*)
ℒ2 = Normal@Join[ℒ,{Vec@Eye[(Sqrt[d])]}];
ρ = Unvec@LinearSolve[ℒ2,Eye[d+1][[-1]]];
ρ
]

(* Specify the vectorized identity matrix 𝕀. Output in this case is not unvectorized. *)
AnalyticalSteadyState[ℒ_,𝕀_]:=Module[{ℒ2,d},
d = Length@ℒ;
ℒ2 = Normal@Join[ℒ,Normal@{𝕀}];
LinearSolve[ℒ2,Eye[d+1][[-1]]]
]

(* Kind of buggy: use with care *)
Clear[AnalyticalSteadyStateSequential]
AnalyticalSteadyStateSequential[ℒ_]:=Module[{B,nn,x,i,p,ph,phh,ρ,tr},
Clear[B];
B = Normal@ℒ;
nn=Length@ℒ;
Do[
Do[
B[[i]] = Together[B[[i]]-B[[j]]B[[i,j]]/B[[j,j]]]
,{i,j+1,nn}];
PrintTemporary[j];
(*Print[Normal@B[[j+1]]];*)
,{j,1,nn}];
x=ConstantArray[0,nn];
x[[nn]]=1;
Do[
x[[i]]=-Together@Total@Table[B[[i,j]]x[[j]],{j,i+1,nn}]/B[[i,i]];
(*Print[x[[i]]];*)
PrintTemporary[i]
,{i,nn-1,1,-1}];

Do[x[[i]] = Simplify[x[[i]]];PrintTemporary[i];PrintTemporary[x[[i]]];,{i,Length@x}];
p = Unvec[x];
ph = ConstantArray[0,{Length@p,Length@p}];
phh = p\[HermitianConjugate];
Do[
ph[[i,j]]=cf[phh[[i,j]]];
PrintTemporary[{i,j}];
PrintTemporary[ph[[i,j]]];
,{i,Length@p},{j,Length@p}];
ρ = p + ph;
tr = Tr[ρ]//Simplify;
ρ = ρ/tr;
Simplify@ρ
]

Crash course on vectorization

"Vec" means stacking columns

vec(({{a, b}, {c, d}})) = (({{a}, {c}, {b}, {d}}));

The fundamental identity from vectorization is 

vec(AρB ) = (Bᵀ⊗ A) vec(ρ)

This allows us to convert Lindblad equations into vector equations. 
For instance

Hρ = (𝕀 ⊗ H)vec(ρ)
ρH = (Hᵀ ⊗ 𝕀) vec(ρ)

∴   -i[H,ρ] = -i(𝕀 ⊗ H - Hᵀ ⊗ 𝕀)vec(ρ)

(This is what UnitaryToVec does)

Similarly:

vec(((LρL)^†)-(1/2){L†L,ρ}) = (L*⊗L - (1/2)𝕀 ⊗ L†L - (1/2)L†L ⊗ 𝕀) vec(ρ)

(This is what LindbladToVec does)

Example usage

ρ = (({{p, q}, {q\[Conjugate], 1-p}}));

Vec[ρ]//mf;

Unvec@Vec[ρ]//mf;

LoadPauliMatrices[]

H= (Ω/2)σz;
𝒟 = γ (1-f) LindbladToVec[σm]+γ f LindbladToVec[σp];
Liouvillian = UnitaryToVec[H] + 𝒟//mf;

(* Steady-state should be a thermal state *)
ρth = (({{f, 0}, {0, 1-f}}));
Liouvillian.Vec[ρth]//cf//mf;

(* Or we can check this without vectorization *)
γ (1-f) Lindbladian[σm][ρth] + γ f Lindbladian[σp][ρth]//cf//mf;

Clear[γ,Ω,f];
H= (Ω/2)σx;
𝒟 = γ (1-f) LindbladToVec[σm]+γ f LindbladToVec[σp];
ℒ = UnitaryToVec[H] + 𝒟//mf;

AnalyticalSteadyState[ℒ]

AnalyticalSteadyState2[ℒ]

LoadBosonicOperators[nmax = 30];
ϵ = 0.8;
γ = 1.0;
nb = 3.0;
H = a\[ConjugateTranspose].a +ϵ (a + a\[ConjugateTranspose]);
𝒟 = γ(nb+1)LindbladToVec[a] + γ nb LindbladToVec[a\[ConjugateTranspose]];
ℒ = UnitaryToVec[H] + 𝒟;
AbsoluteTiming[(ρ = SteadyState[ℒ])//Chop;]
ρ//MatrixPlot

AbsoluteTiming[ρ2 = AnalyticalSteadyState2[ℒ]//Chop;]
ρ2//MatrixPlot

Tr[ρ]

Tr[ρ2]

ρ-ρ2//ChopCheck

(* Analytical Steady steate of an XXZ chain with 4 spins *)
LoadSpinChainMatrices[L=4,"a"] (* "a" makes the operators suitable for analytical calculations *) 
H = Sum[sx[i].sx[i+1] + sy[i].sy[i+1] + Δ sz[i].sz[i+1],{i,1,L-1}] + Sum[h sz[i],{i,1,L}];
ℒ = UnitaryToVec[H] + γ LindbladToVec[sp[1]] + γ LindbladToVec[sm[L]];

ρ = AnalyticalSteadyState[ℒ]

Waiting time distributions (WTDs)

Waiting Time Distribution
Computes the general waiting time distribution between an initial jump (Subscript[𝒥, i]) and a final jump (Subscript[𝒥, f]), with no jump Liouvillian (Subscript[ℒ, 0])

(Subscript[P, f|i])(t) = ((tr ((Subscript[𝒥, f])(e^((Subscript[ℒ, 0])t ))(Subscript[𝒥, i])ρ))/(tr((Subscript[𝒥, i])ρ)))

The jump operators usually have the form (Subscript[𝒥, k])= (Subscript[L, k])ρ (Subscript[L, k]^†).
If no initial state ρ is input, it is assumed that ρ  = identity (maximally mixed state). This is convenient in the case of renewal processes, where ρ does not matter. 

For a Liouvillian decomposed as ℒ = (Subscript[ℒ, 0]) + (∑_( k))(Subscript[𝒥, k]), the WTD will be normalized as 

(∑_( f)) ∫ dt (Subscript[P, f|i])(t) = 1 - (Subscript[P, no])(∞), 

where (Subscript[P, no])(∞) = (lim_( t-> ∞)) tr((e^((Subscript[ℒ, 0])t))ρ) is the no jump distribution. 
If after an infinite time, a jump definitely occurs, then (Subscript[P, no])(∞)=0 and one gets the usual normalization. 

Moments of the waiting time
The moments are only implement for the case where the Liouvillian is split as ℒ = (Subscript[ℒ, 0])+(Subscript[ℒ, 1]) and the WTD is 

 P(t)=((tr ((Subscript[ℒ, 1])(e^((Subscript[ℒ, 0])t ))(Subscript[ℒ, 1])ρ))/(tr((Subscript[ℒ, 1])ρ)))
 
The moments then read 

E((T^n)) = ∫ dt P(t) (t^n). 

For the general WTDs implemented above, it becomes a bit awkward to speak of moments since the distribution is not necessarily normalized. 
It also assumes that (Subscript[ℒ, 0]) has no zero eigenvalues (which means a jump must eventually occur). 

Implementation: 
Assuming that (Subscript[ℒ, 0]) has no dark subspaces, we get 

(∫_0^∞)dt (e^((Subscript[ℒ, 0])t ))(t^n) = (((-1))^(n+1))n! (Subscript[ℒ, 0]^(-(n+1)))

Thus 

E((T^n)) = (((-1))^(n+1))n! ((tr((Subscript[ℒ, 1])(Subscript[ℒ, 0]^(-(n+1)))(Subscript[ℒ, 1])ρ))/(tr((Subscript[ℒ, 1])ρ))).

But since (Subscript[ℒ, 1])=ℒ-(Subscript[ℒ, 0]) and ℒ is traceless, we can also write this as 

E((T^n)) = (((-1))^n)n!  ((tr((Subscript[ℒ, 0]^(-n))(Subscript[ℒ, 1])ρ))/(tr((Subscript[ℒ, 1])ρ)))

The first moment, for instance, reads 

E(T) = -((tr((Subscript[ℒ, 0]^(-1))(Subscript[ℒ, 1])ρ))/(tr((Subscript[ℒ, 1])ρ)))

Clear[WaitingTimeDistribution];
WaitingTimeDistribution[t_,ℒ0_,𝒥i_,𝒥f_,ρ0_:None]:=Module[{ρ,d=(Sqrt[Length@ℒ0])},
ρ=If[ρ0===None,Eye[d]/d,ρ0];
((UnTr[𝒥f.MatrixExp[ℒ0 t,𝒥i.Vec[ρ]]])/(UnTr[𝒥i.Vec[ρ]]))]

Clear[WaitingTimeDistributionClassical]
WaitingTimeDistributionClassical[t_,ℒ0_,𝒥i_,𝒥f_,ρ0_:None]:=Module[{ρ,d=Length@ℒ0},
ρ=If[ρ0===None,ConstantArray[1,d]/d,ρ0];
((Total[𝒥f.MatrixExp[ℒ0 t,𝒥i.ρ]])/(Total[𝒥i.ρ]))]

Clear[WaitingTimeMoments];
WaitingTimeMoments[ρ_?MatrixQ,ℒ_,ℒ1_,n_,reset_:True]:=Module[{f,α,ρ0},
f = LinearSolve[ℒ-ℒ1];
ρ0 = If[reset==True,((ℒ1.Vec[ρ])/(UnTr[ℒ1.Vec[ρ]])),Vec[ρ]];
α = Nest[f,ρ0,n];
(((-1))^n)n! UnTr[α]  
];

WaitingTimeMoments[ρ_?VectorQ,ℒ_,ℒ1_,n_,reset_:True]:=Module[{f,α,ρ0},
f = LinearSolve[ℒ-ℒ1];
ρ0 = If[reset==True,((ℒ1.ρ)/(Total[ℒ1.ρ])),ρ];
α = Nest[f,ρ0,n];
(((-1))^n)n! Total[α]  
]

Quantum model with a single jump

(* A quantum model *)
H = σz + σx;
c = (Sqrt[1/2])σm;
ℒ = Liouvillian[H,{c}];
ℒ1 = JumpOp[c];
ℒ0 = ℒ-ℒ1;

P=WaitingTimeDistribution[t,ℒ0,ℒ1,ℒ1]

Plot[P,{t,0,20}]

NIntegrate[P,{t,0,∞}]

WaitingTimeMoments[ρ,ℒ,ℒ1,1]//N
WaitingTimeMoments[ρ,ℒ,ℒ1,2]//N
WaitingTimeMoments[ρ,ℒ,ℒ1,3]//N

NIntegrate[P t,{t,0,∞}]
NIntegrate[P (t^2),{t,0,∞}]//Quiet
NIntegrate[P (t^3),{t,0,∞}]//Quiet

Quantum model with multiple jumps

(* A quantum model with 3 jump operators, but only two of them being monitored *)
H = σz + σx;
cdn = (Sqrt[1/2])σm; (* emission *)
cup = (Sqrt[1/3])σp;  (* absorption *)
cdeph = (Sqrt[1/10])σz ;(* dephasing *)
ℒ = Liouvillian[H,{cdn,cup,cdeph}];
Jdn = JumpOp[cdn];
Jup = JumpOp[cup];
ℒ0 = ℒ-Jdn-Jup;

(* Waiting time distribution between an emission & an absorption *)
Pea=WaitingTimeDistribution[t,ℒ0,Jdn,Jup];
Plot[Pea,{t,0,20}]

(* Waiting time distribution between two emissions (assuming that we still monitor the absorptions) *)
Pee=WaitingTimeDistribution[t,ℒ0,Jdn,Jdn];
Plot[Pee,{t,0,20}]

(* Normalization *)
NIntegrate[Pea,{t,0,∞}]+NIntegrate[Pee,{t,0,∞}]

Autonomous Quantum Clock: classical version

Based on http://link.aps.org/doi/10.1103/PhysRevX.7.031022

Effective model as a Pauli (classical) Master equation

𝒲[d_,pup_,pdw_,Γ_]:=Module[{W},
W=DiagonalMatrix[ConstantArray[pup,{d-1}],-1] + DiagonalMatrix[ConstantArray[pdw,{d-1}],1] +DiagonalMatrix[ConstantArray[-pup-pdw,d]];
W[[1,d]] = Γ;
W[[d,d]] = W[[d,d]]-Γ+pup;
W[[1,1]] = - pup;
W
]
𝒲1[d_,Γ_] := SparseArray[{{1,d}->Γ},{d,d}]

W=𝒲[5,(Subscript[p, up]),(Subscript[p, dw]),Γ]//mf;
W1 = 𝒲1[5,Γ]//mf;

d = 20;
pup = 0.2;
pdw = 0.08;
Γ = 20;
P = WaitingTimeDistributionClassical[t,𝒲[d,pup,pdw,Γ]-𝒲1[d,Γ],𝒲1[d,Γ],𝒲1[d,Γ]];
Plot[P,{t,0,500}]

Autonomous Quantum Clock: full quantum version

Full quantum model, involving a d-level system + two qubits coupled to a hot & a cold bath

AutonomousClockWaitingTime[d_,ts_,{g_,γ_,Γ_},{Ec_,Ew_},{Tc_,Th_}]:=Module[{Eh,𝕀,σ,K,H0,Hint,cops,ℒ,ℒ1,ρ},
Eh = Ec + Ew;
𝕀 = Eye[d];
σ=(({{0, 1}, {0, 0}}));
Do[K[k] = Basis[d,k],{k,d}];

H0 = Ec kron[σ\[ConjugateTranspose].σ,σ0,𝕀] + Eh kron[σ0,σ\[ConjugateTranspose].σ,𝕀] + Sum[(k-1) Ew kron[σ0,σ0,out[K[k],K[k]]],{k,d}];

Hint = g Sum[kron[σ\[ConjugateTranspose],σ,out[K[k+1],K[k]]],{k,1,d-1}];
Hint = Hint + Hint\[ConjugateTranspose];
cops = {
(Sqrt[γ])kron[σ,σ0,𝕀],
(Sqrt[γ (E^(-Ec/Tc))])kron[σ\[ConjugateTranspose],σ0,𝕀],
(Sqrt[γ])kron[σ0,σ,𝕀],
(Sqrt[γ (E^(-Eh/Th))])kron[σ0,σ\[ConjugateTranspose],𝕀],
(Sqrt[Γ])kron[σ0,σ0,out[K[1],K[d]]]};
ℒ = Liouvillian[H0+Hint ,cops];
ℒ1 = cf@JumpOp[cops[[-1]]];
ρ = kron[(({{(1/(1+Exp[-Ec/Tc])), 0}, {0, (1/(1+Exp[Ec/Tc]))}})),(({{(1/(1+Exp[-Eh/Th])), 0}, {0, (1/(1+Exp[Eh/Th]))}})),Proj[d,1,1]];  
Table[{t,WaitingTimeDistribution[t,ℒ-ℒ1,ℒ1,ℒ1]//Chop},{t,ts}]

]

Pfull=AutonomousClockWaitingTime[
d = 18,
ts=linspace[0,7600,80],
{g=0.05,γ=0.3,Γ=0.05},
{Ec=20,Ew=1.0},
{Tc = 1.0,Th = 100}];
ListLinePlot[Pfull,PlotRange->All]

Comparison with the effective model

Zc = 1+ (E^(-Ec/Tc));
Zh = 1+ (E^(-Eh/Th));
Eh = Ec + Ew;
pdw = ((4 (g^2)Exp[-Ec/Tc])/(Zh Zc  γ (Zh+Zc)));
pup = ((4 (g^2)Exp[-Eh/Th])/(Zh Zc  γ (Zh+Zc)));

Peff =Table[{t, WaitingTimeDistributionClassical[t,SetPrecision[𝒲[d,pup,pdw,Γ]-𝒲1[d,Γ],20],SetPrecision[𝒲1[d,Γ],20],SetPrecision[𝒲1[d,Γ],20]]},{t,ts}];
ListLinePlot[{Pfull,Peff}]

No-jump distribution

(* The actual no-jump distribution is computed as (Subscript[P, no])=tr(ρf), where f is the output of "NoJumpDistributionFactor" *)
(* This is what the function NoJumpDistribution does *)

Clear[NoJumpDistributionFactor];
NoJumpDistributionFactor[ts_,ℒ0_]:=Module[{d = (((Length[ℒ0]))^(1/2))},
Table[UnTr@MatrixExp[ℒ0 t, kronV[Basis[d,j],Basis[d,i]]],{j,d},{i,d},{t,ts}]]

NoJumpDistributionFactor[ts_,H_,cops_]:=Module[{d = H,He,ℰ},
He = H - (I/2)Total@Table[c\[ConjugateTranspose].c,{c,cops}];
Transpose[Table[
ℰ = MatrixExp[-I He t];
ℰ\[ConjugateTranspose].ℰ,{t,ts}],{3,1,2}]
]

Clear[NoJumpDistribution];
NoJumpDistribution[ρ_,f_]:=Vec[ρ].Flatten[f,1]//Chop

NoJumpDistribution[ρ_,ts_,ℒ0_]:=With[{f = NoJumpDistributionFactor[ts,ℒ0]},NoJumpDistribution[ρ,f]];

NoJumpDistribution[ρ_,ts_,H_,cops_]:=With[{f = NoJumpDistributionFactor[ts,H,cops]},NoJumpDistribution[ρ,f]];

Example usage and sanity checks

H = 0.5 σx/2;
c1 = (Sqrt[0.1])σm;
c2 = (Sqrt[0.3])σp;
ℒ = Liouvillian[H,{c1,c2}];
ℒ1 = JumpOp[c1]+JumpOp[c2];
ℒ0 = ℒ-ℒ1;
ρ = (({{0.3, 0.1I}, {-0.1I, 0.7}}));
He = H - (I/2)(c1\[ConjugateTranspose].c1+c2\[ConjugateTranspose].c2);
ts=range[0,2,0.1];

f=NoJumpDistributionFactor[ts,ℒ0]
f2=NoJumpDistributionFactor[ts,H,{c1,c2}]

Table[Chop@UnTr@MatrixExp[ℒ0 t,Vec[ρ]],{t,ts}]
Table[Chop@Tr[MatrixExp[-I He t].ρ.MatrixExp[I He\[ConjugateTranspose] t]],{t,ts}]
NoJumpDistribution[ρ,f]
NoJumpDistribution[ρ,f2]

Emission & absorption spectra

The steady-state emission spectra of a system, with jump operator c, is defined as 

ℰ(ω) = ∫ dτ (e^(-i ω τ)) ⟨c†(τ)c(0)⟩ = ⟨(Subscript[b, out]^†)(ω)(Subscript[b, out])(ω)⟩

The absorption spectra, on the other hand, is given by 

𝒜(ω) = ∫ dτ (e^(-i ω τ)) ⟨c(0)c†(τ)⟩

The 2-time correlation functions can be computed using the quantum regression theorem: 

⟨A(t+τ)B(t)⟩ = tr(A (e^(ℒ τ))((Subscript[Bρ, t]))) 
or
⟨A(t)B(t+τ)⟩ = tr(B (e^(ℒ τ))((Subscript[ρ, t])A)) 

with τ > 0. 

We thus get 

ℰ(ω) = - tr(c† (1/(ℒ-i ω))(c ρ)) - tr(c (1/(ℒ+i ω))(ρ c†))
and
𝒜(ω) = -tr(c† (1/(ℒ-i ω))(ρ c)) - tr(c (1/(ℒ+i ω))(c†ρ ))

For Quantum white noise, the output field correlation function is given by 

⟨(Subscript[b, out]^†)(t) (Subscript[b, out])(t')⟩ = γ N δ(t-t') + γ (N+1) ⟨c†(t)c(t’)⟩ - γ N ⟨c(t’) c†(t)⟩

Hence, the power spectrum of the measured output field is actually (in the steady-state)

𝒮(ω) = ∫ dτ (e^(-ι ω τ)) ⟨(Subscript[b, out]^†)(τ)(Subscript[b, out])(0)⟩ = γ N + γ (N+1) ℰ(ω) - γ N 𝒜(ω)

That is, it can be readily determined from the emission and absorption spectra.

Clear[EmissionSpectrum];
EmissionSpectrum[ρ_,ωs_,L_,c_]:=Module[{one,J,α,β,tab,tmp,𝕀=Eye[Length@L]},

tab = Table[
α = LinearSolve[L-I ω 𝕀, Vec[c.ρ]];
(*β = LinearSolve[L+I ω Eye[Length@L], Vec[ρ.c\[ConjugateTranspose]]];*)
tmp= -Tr[c\[ConjugateTranspose].Unvec[α]](*-Tr[c.Unvec[β]]*);
tmp+tmp\[Conjugate]
,{ω,ωs}];

tab//Chop
]

Clear[AbsorptionSpectrum];
AbsorptionSpectrum[ρ_,ωs_,L_,c_]:=Module[{one,J,α,β,tab,tmp},

tab = Table[
α = LinearSolve[L-I ω Eye[Length@L], Vec[ρ.c]];
(*β = LinearSolve[L+I ω Eye[Length@L], Vec[c\[ConjugateTranspose].ρ]];*)
tmp= -Tr[c\[ConjugateTranspose].Unvec[α]](*-Tr[c.Unvec[β]]*);
tmp+tmp\[Conjugate]
,{ω,ωs}];

tab//Chop
]

Checking the symmetry of the 2 terms

Verifying that 

tr(c (1/(ℒ+i ω))(ρ c†)) = conjugate of tr(c† (1/(ℒ-i ω))(c ρ))

H = 0.8 σz + 0.7 σx + 0.6 σy + 0.1 σ0;
ℒ=Liouvillian[H,{σm,σp,σz},{0.3,0.8,0.1}];
ρ = SteadyState[ℒ]//mf;
ωs = linspace[-10,10,100];

S = EmissionSpectrum[ρ,ωs,ℒ,σm]

S2 = EmissionSpectrum2[ρ,ωs,ℒ,σm]

S-S2//Chop

Clear[EmissionSpectrum2];
EmissionSpectrum2[ρ_,ωs_,L_,c_]:=Module[{one,J,α,β,tab,tmp},

tab = Table[
α = LinearSolve[L-I ω Eye[Length@L], Vec[c.ρ]];
β = LinearSolve[L+I ω Eye[Length@L], Vec[ρ.c\[ConjugateTranspose]]];
tmp= -Tr[c\[ConjugateTranspose].Unvec[α]]-Tr[c.Unvec[β]];
(*tmp+tmp\[Conjugate]*)
tmp
,{ω,ωs}];

tab//Chop
]

Example: Mollow Triplet in the fluorescence spectrum of a qubit

ℒ = Liouvillian[(Ω/2)σx,{σm},{γ}];
ρ = AnalyticalSteadyState[ℒ]//mf;

S=FCSEmissionSpectrum[ρ,{ω},ℒ,σm]//First//cf

Plot[S/.{γ->0.1,Ω->4},{ω,-7,7}]

Emission spectrum of the tight-binding model

Clear[h,H,γ,ℒ,ρ];
h = TightBindingHamiltonian[4];
LoadFermionicOperators[4];
H = Sum[h[[i,j]] cd[i].c[j],{i,4},{j,4}];
γ =0.01;
ℒ = N@Liouvillian[H,{cd[1],c[4]},{γ,γ}];
ρ = SteadyState[ℒ];
ωs = linspace[-2,4,100];
ee=EmissionSpectrum[ρ, ωs,ℒ,c[4]];

ListLinePlot[ee]

Examples

Minimal 2-qubit engine

Based on https://arxiv.org/pdf/1010.6029.pdf and http://arxiv.org/abs/2106.13817

LoadSpinChainMatrices[2,"a"];
H0 = ϵ1 sp[1].sm[1] + ϵ2 sp[2].sm[2];
V = g(sp[1].sm[2]+sp[2].sm[1]);

cops = {
(Sqrt[γ1m])sm[1],
(Sqrt[γ1p])sp[1],
(Sqrt[γ2m])sm[2],
(Sqrt[γ2p])sp[2]
};
ℒ = Liouvillian[V,{sm[1],sp[1],sm[2],sp[2]},{γ1m,γ1p,γ2m,γ2p}]//cf;

ρ = AnalyticalSteadyState[ℒ]//Simplify//mf;

𝒟1 = γ1m LindbladToVec[sm[1]] + γ1p LindbladToVec[sp[1]];
𝒟2 = γ2m LindbladToVec[sm[2]] + γ2p LindbladToVec[sp[2]];
Tr[V.Unvec[𝒟1.Vec[ρ]]]//Simplify
Tr[V.Unvec[𝒟2.Vec[ρ]]]//Simplify

W = I g (ϵ2-ϵ1) Tr[(sp[1].sm[2]-sp[2].sm[1]).ρ]//cf

Q1 = Tr[H0.Unvec[𝒟1.Vec[ρ]]]//Simplify
Q1 = ϵ1 (γ1p Tr[sm[1].sp[1].ρ]- γ1m Tr[sp[1].sm[1].ρ])//cf

Q2 = Tr[H0.Unvec[𝒟2.Vec[ρ]]]//Simplify

W+Q1+Q2//cf

n1 = (1/(Exp[β1 ϵ1]-1));
n2 = (1/(Exp[β2 ϵ2]-1));
{c1,c2,c3} ={,,};
rep = {γ1m->(n1+1),γ1p->n1,γ2m->n2+1,γ2p->n2,g->3};
(*Manipulate[Plot[Evaluate[{W,Q1,Q2}/.rep/.{ϵ1->1,β1->1/T1,β2->1/T2}],{ϵ2,0.1,2},
GridLines->{None,{0}},
PlotStyle->{c1,c2,c3},
ImageSize->450,
PlotLegends->legend[{"W","(Subscript[Q, 1])","(Subscript[Q, 2])"},{0.3,0.1},LegendLayout->Row],
Filling->{
1->{Axis,{Directive[c1,Opacity[0.4]],Opacity[0]}},
2->{Axis,{Opacity[0],Directive[c2,Opacity[0.4]]}},
3->{Axis,{Directive[c3,Opacity[0.4]],Opacity[0]}}}

],
{{T1,1},0.1,3},
{{T2,1/2},0.1,3}]*)

Plot[Evaluate[{W,Q1,Q2}/.rep/.{ϵ1->1,β1->1,β2->2}],{ϵ2,0.1,2},
GridLines->{None,{0}},
PlotStyle->{c1,c2,c3},
ImageSize->450,
PlotLegends->legend[{"W","(Subscript[Q, 1])","(Subscript[Q, 2])"},{0.3,0.1},LegendLayout->"Row"],
Filling->{
1->{Axis,{Directive[c1,Opacity[0.4]],Opacity[0]}},
2->{Axis,{Opacity[0],Directive[c2,Opacity[0.4]]}},
3->{Axis,{Directive[c3,Opacity[0.4]],Opacity[0]}}}
]

Collision models

Collision Map

Clear[CollisionMap];
CollisionMap[ρs0_,U_,ρa_,n_,output_:"system"]:=Module[{ds=Length@ρs0,da=Length@ρa},

Which[
output=="system",
NestList[PTr[U.kron[#,ρa].U\[ConjugateTranspose],{2},{ds,da}]&,ρs0,n],
output=="all",
NestList[
With[{ρsa=U.kron[#[[1]],ρa].U\[ConjugateTranspose]} , 
{PTr[ρsa,{2},{ds,da}],PTr[ρsa,{1},{ds,da}]}]&,{ρs0,ρa},n]
]
]

Example usage

ρs0 = (({{1, 0}, {0, 0}}));
ρa = (({{0.4, 0}, {0, 0.6}}));
U = PartialSWAP[0.5,1,2,2]//mf;

mf/@CollisionMap[ρs0,U,ρa,10];

results=CollisionMap[ρs0,U,ρa,10,"all"]//Chop;
TableForm[Table[
{MatrixForm[results[[i,1]]],MatrixForm[results[[i,2]]]},
{i,10}],TableHeadings->{None,{"S","A"}}]

Collision Model Steady-state

Clear[CollisionModelSteadyState]
CollisionModelSteadyState[U_,ρa_]:=Module[{da=Length@ρa,ds,ρ,𝒯,p},
ds = Length[U]/da;
ρ = Table[p[i,j],{i,ds},{j,ds}];
𝒯=Last@CoefficientArrays[Vec[PTr[U.kron[ρ,ρa].U\[ConjugateTranspose],{2},{ds,da}]],Vec[ρ]];
(*SteadyState[𝒯-Eye[(ds^2)]]*)
AnalyticalSteadyState[𝒯-Eye[(ds^2)]] (* "AnalyticalSteadyState handles multiple steady-states, by selecting one that is guaranteed physical *)
]

Example usage

ρa = (({{0.4, 0}, {0, 0.6}}));
U = PartialSWAP[0.5,1,2,2];
CollisionModelSteadyState[U,ρa]//mf;

χ = {(Sqrt[0.3]),(Sqrt[1-0.3])};
LoadSpinChainMatrices[2];
U = MatrixExp[-I sx[1].sx[2]];
𝒯=CollisionModelSteadyState[U,out[χ,χ]]//mf;

Coherent quantum absorber

Clear[CoherentQuantumAbsorber];
CoherentQuantumAbsorber[U_,χ_]:=Module[{da=Length@χ,ds,ρa,ρss,λ,f,g,V,ψt,ϕ,support,i,fχ,error},
ds = Length[U]/da;
ρa = out[χ,χ];
ρss = CollisionModelSteadyState[U,ρa];
{λ,f} = Eigsys[ρss];
ψt = Sum[(Sqrt[λ[[i]]])kron[f[[i]],f[[i]]],{i,ds}];

ϕ = kron[U,Eye[ds]].Sum[(Sqrt[λ[[i]]])kron[f[[i]],χ,f[[i]]],{i,ds}];

support = Select[{Range[1,ds],λ}\[Transpose],Abs[#[[2]]]>(10^(-12))&][[All,1]];
g=Table[(1/(Sqrt[λ[[i]]]))kron[{f[[i]]\[Conjugate]},Eye[ds da]].ϕ,{i,support}];
g = Join[g,NullSpace[g\[Conjugate]]];

f = Join[Table[f[[i]],{i,support}],Table[f[[i]],{i,Complement[Range[1,ds],support]}]];

fχ = Table[kron[χ,f[[i]]],{i,support}];
fχ = Join[fχ,NullSpace[fχ\[Conjugate]]];

V = Sum[kron[Eye[ds],out[fχ[[i]],g[[i]]]],{i,(ds^2)}];

error=V.kron[U,Eye[ds]].Sum[(Sqrt[λ[[i]]])kron[f[[i]],χ,f[[i]]],{i,ds}]-Sum[(Sqrt[λ[[i]]])kron[f[[i]],χ,f[[i]]],{i,ds}]//Chop;
If[Total@Abs[error]>(10^(-12)),Print["Apparently it did not work. The error was " <>ToString[error]]];
{V,ψt}
]

Example usage

χ = {(Sqrt[0.3]),(Sqrt[1-0.3])};
(*U = PartialSWAP[0.5,1,2,2];*)
LoadSpinChainMatrices[2];
U = MatrixExp[-I sx[1].sx[2]];

{V,ψt}=CoherentQuantumAbsorber[U,χ];

V\[ConjugateTranspose].V//mf;

PTr[out[ψt,ψt],{2}]//mf;

ψt

Full counting statistics

DrazinApply: Applies the Drazi inverse of an operator

(* Not yet sure which approach is more efficient. Found 1 example where DrazinApply does not work, but DrazinApply2 does. *)

DrazinApply[ℒ_,y_]:=LinearSolve[Join[ℒ,{Vec@Eye[(Sqrt[Length@ℒ])]}], Join[y ,{0}]]

DrazinApply2[ℒ_,ρv_,y_]:=Module[{z},
z = LinearSolve[ℒ, y-ρv UnTr[y]];
z - ρv UnTr[z]
]

Example usage

ℒ = Liouvillian[σz,{(Sqrt[γm]) σm,(Sqrt[γp])σp}]//cf;
ρ = AnalyticalSteadyState[ℒ];
ℒD=DrazinInverse[ℒ,ρ]//cf//mf;

(SuperPlus[ℒ])ℒ= 1 - |ρ⟩⟨1|:

P0 = out[Vec[ρ],Vec[Eye[2]]];
P = Eye[4]-P0;

ℒD.ℒ-P//cf//mf;

ℒD.P0//cf//mf;

ℒD.P-ℒD//cf//mf;

Comparison with the Moore-Penrose pseudo-inverse: it does not match. 
I have no idea what Mathematica does here. I think it is using SVD.

ℒMP=PseudoInverse[ℒ]//cf//mf;

ℒD-P.ℒMP.P//cf//mf;

Comparing with the integral formula

-Integrate[MatrixExp[ℒ t].(Eye[4]-out[Vec[ρ],Vec[Eye[2]]]),{t,0,∞},Assumptions->{γm>0,γp>0}]//mf;

Average current

Clear[FCSAverage];
FCSAverage[ρ_,ℒ_,LL_,μμ_:1,type_:"PD"]:=Module[{L,μ,ρv,d,res},

L = If[Length@Dimensions[LL]==2,{JumpOp[LL,type]},JumpOp[#,type]&/@LL]; (* List of operators *)
d = Length@L;
μ = Which[
Dimensions[μμ]==={d},{μμ},
Dimensions[μμ]==={},{μμ ConstantArray[1,d]},
True,μμ];
ρv = Vec[ρ];
res=Table[Total@Table[μ[[α,i]] UnTr[L[[i]].ρv],{i,d}],{α,Length@μ}]//Chop;
If[Length@res==1,res[[1]],res]
]

Diffusion matrix

Clear[FCSDiffusionMatrix];
FCSDiffusionMatrix[ρ_,ℒ_,LL_,μμ_:1,type_:"PD"]:=Module[{L,μ,ρv,d,Jk,M,R,ℒbig,ℒα,Jα,ws,𝒟},

L = If[Length@Dimensions[LL]==2,{JumpOp[LL,type]},JumpOp[#,type]&/@LL]; (* List of operators *)
d = Length@L;
μ = Which[
Dimensions[μμ]==={d},{μμ},
Dimensions[μμ]==={},{μμ ConstantArray[1,d]},
True,μμ]; (* R×d matrix *)
R = Length@μ;
ρv = Vec[ρ];
Jk = Table[UnTr[lop.ρv],{lop,L}];

M = Which[
type=="PD",μ.DiagonalMatrix[Jk].μ\[Transpose],
type=="Homodyne"||True,μ.μ\[Transpose]
]//Chop;

ℒα = μ.L;
Jα = UnTr[#.ρv]&/@ℒα//Chop;
ℒbig =Join[ℒ,{Vec@Eye[(Sqrt[Length@ℒ])]}];
ws = Table[LinearSolve[ℒbig, Join[ℒα[[i]].ρv-Jα[[i]] ρv ,{0}]],{i,R}];
𝒟 = -Table[UnTr[ℒα[[i]].ws[[j]]],{i,R},{j,R}];
𝒟=𝒟 + 𝒟\[Transpose] + M//Chop;
If[R===1,𝒟[[1,1]],𝒟]
]

Power spectrum

Clear[FCSPowerSpectrumEigen]
FCSPowerSpectrumEigen[ρ_,ℒ_,LL_,μμ_:1,type_:"PD"]:=Module[{L,μ,ρv,d,Jk,M,R,ℒbig,ℒα,Jα,ws,𝒟,λ,Q,x,y,Υ,𝒮},

L = If[Length@Dimensions[LL]==2,{JumpOp[LL,type]},JumpOp[#,type]&/@LL]; (* List of operators *)
d = Length@L;
μ = Which[
Dimensions[μμ]==={d},{μμ},
Dimensions[μμ]==={},{μμ ConstantArray[1,d]},
True,μμ]; (* R×d matrix *)
R = Length@μ;
ρv = Vec[ρ];
Jk = Table[UnTr[lop.ρv],{lop,L}];

M = Which[
type=="PD",μ.DiagonalMatrix[Jk].μ\[Transpose],
type=="Homodyne"||True,μ.μ\[Transpose]
]//Chop;

ℒα = μ.L;
Jα = UnTr[#.ρv]&/@ℒα//Chop;
{λ,Q} = Eigsys[ℒ];
λ = Drop[λ,-1];
x = (Q\[Transpose])[[1;;-2]];
y=Inverse[Q][[1;;-2]];
(*Defined so that ℒ = Sum[λ[[i]] out[x[[i]],y[[i]]\[Conjugate]],{i,Length[ℒ]-1}] *)

Υ = Table[UnTr[ℒα[[α]].out[x[[j]],y[[j]]\[Conjugate]].ℒα[[β]].ρv],{α,R},{β,R},{j,Length[λ]}];

If[R===1,
Function[M[[1,1]] - Chop@Total@Table[(1/(λ[[j]]-I #))Υ[[1,1,j]]+(1/(λ[[j]]+I #))Υ[[1,1,j]],{j,Length[λ]}] ],
Function[M -Table[Chop@Total@Table[(1/(λ[[j]]-I #))Υ[[β,α,j]]+(1/(λ[[j]]+I #))Υ[[α,β,j]],{j,Length[λ]}] ,{α,R},{β,R}]]
]

]

Clear[FCSPowerSpectrumLinearSys]
FCSPowerSpectrumLinearSys[ωs_,ρ_,ℒ_,LL_,μμ_:1,type_:"PD"]:=Module[{L,μ,ρv,d,Jk,M,R,ℒbig,ℒα,Jα,ws,𝒟,λ,Q,x,y,Υ,𝒮,v1,v2,𝕀},

L = If[Length@Dimensions[LL]==2,{JumpOp[LL,type]},JumpOp[#,type]&/@LL]; (* List of operators *)
d = Length@L;
μ = Which[
Dimensions[μμ]==={d},{μμ},
Dimensions[μμ]==={},{μμ ConstantArray[1,d]},
True,μμ]; (* R×d matrix *)
R = Length@μ;
ρv = Vec[ρ];
Jk = Table[UnTr[lop.ρv],{lop,L}];

M = Which[
type=="PD",μ.DiagonalMatrix[Jk].μ\[Transpose],
type=="Homodyne"||True,μ.μ\[Transpose]
]//Chop;

ℒα = μ.L;
(*Jα = UnTr[#.ρv]&/@ℒα//Chop;*)

𝕀 = Eye[Length@ℒ];
Table[
v1=Table[LinearSolve[ℒ - I ω 𝕀, ℒα[[i]].ρv],{i,R}];
v2=Table[LinearSolve[ℒ + I ω 𝕀, ℒα[[i]].ρv],{i,R}];
𝒮=M - Table[UnTr[ℒα[[β]].v1[[α]]] + UnTr[ℒα[[α]].v2[[β]]],{α,R},{β,R}];
{ω,If[R===1,𝒮[[1,1]],𝒮]}
,{ω,ωs}]//Chop
]

Clear[FCSCoherence];
FCSCoherence[𝒮_,ω_]:=(((Abs[𝒮[ω][[1,2]]])^2)/(𝒮[ω][[1,1]] 𝒮[ω][[2,2]]))

(g^((2))) function

The general (g^((2))) function is related to the current two-point function as

(Subscript[F, αβ])(τ) = E((Subscript[δI, α])(0) (Subscript[δI, β])(τ))= M δ(τ) + (Subscript[J, α])(Subscript[J, β])  [(Subscript[g, αβ]^((2)))(τ) - 1]

Thus

(Subscript[g, αβ]^((2)))(τ) = ((⟨1|(Subscript[ℒ, β])(e^(ℒτ))(Subscript[ℒ, α])|ρ⟩)/((Subscript[J, α])(Subscript[J, β]) )) := (((Subscript[G, αβ]^((2)))(τ))/((Subscript[J, α])(Subscript[J, β])))

where (Subscript[ℒ, α]) = (∑_( k ))(Subscript[μ, k]^α) (Subscript[L, k])ρ (Subscript[L, k]^†)

Notice that for homodyne detection, (g^((2))) is actually (g^((1))) (which is unnecessarily confusing, I know).

(* Without dividing by (J^2) *)
Clear[FCSG2MEXP]
FCSG2MEXP[ts_,ρ_,ℒ_,LL_,μμ_:1,type_:"PD"]:=Module[{L,μ,ρv,d,Jk,M,R,ℒbig,ℒα,Jα,ws,𝒟,λ,Q,x,y,Υ,𝒮},

L = If[Length@Dimensions[LL]==2,{JumpOp[LL,type]},JumpOp[#,type]&/@LL]; (* List of operators *)
d = Length@L;
μ = Which[
Dimensions[μμ]==={d},{μμ},
Dimensions[μμ]==={},{μμ ConstantArray[1,d]},
True,μμ]; (* R×d matrix *)
R = Length@μ;
ρv = Vec[ρ];
ℒα = μ.L;
Jα = UnTr[#.ρv]&/@ℒα//Chop;

If[R===1,
Table[{t,(*(1/((Jα[[1]])^2))*) UnTr[ℒα[[1]].MatrixExp[ℒ t,ℒα[[1]].ρv]]},{t,ts}],
Table[{t,Table[(*(1/(Jα[[α]]Jα[[β]]))*) UnTr[ℒα[[β]].MatrixExp[ℒ t,ℒα[[α]].ρv]],{α,R},{β,R}]},{t,ts}]
]//Re
]

Clear[FCSg2Eigen]
FCSg2Eigen[ρ_,ℒ_,LL_,μμ_:1,type_:"PD"]:=Module[{L,μ,ρv,d,Jk,M,R,ℒbig,ℒα,Jα,ws,𝒟,λ,Q,x,y,Υ,𝒮},

L = If[Length@Dimensions[LL]==2,{JumpOp[LL,type]},JumpOp[#,type]&/@LL]; (* List of operators *)
d = Length@L;
μ = Which[
Dimensions[μμ]==={d},{μμ},
Dimensions[μμ]==={},{μμ ConstantArray[1,d]},
True,μμ]; (* R×d matrix *)
R = Length@μ;
ρv = Vec[ρ];

ℒα = μ.L;
Jα = UnTr[#.ρv]&/@ℒα;
{λ,Q} = Eigsys[ℒ];
λ = Drop[λ,-1];
x = (Q\[Transpose])[[1;;-2]];
y=Inverse[Q][[1;;-2]];
(*Defined so that ℒ = Sum[λ[[i]] out[x[[i]],y[[i]]\[Conjugate]],{i,Length[ℒ]-1}] *)

Υ = Table[UnTr[ℒα[[β]].out[x[[j]],y[[j]]\[Conjugate]].ℒα[[α]].ρv],{α,R},{β,R},{j,Length[λ]}];

If[R===1,
Function[1+(1/((Jα[[1]])^2))Total@Table[Exp[λ[[j]] #] Υ[[1,1,j]],{j,Length[λ]}] ],
Function[Table[1+(1/(Jα[[α]]Jα[[β]]))Total@Table[Exp[λ[[j]] #]Υ[[β,α,j]],{j,Length[λ]}] ,{α,R},{β,R}]]
]//Chop
]

Clear[FCSg2MEXP]
FCSg2MEXP[ts_,ρ_,ℒ_,LL_,μμ_:1,type_:"PD"]:=Module[{L,μ,ρv,d,Jk,M,R,ℒbig,ℒα,Jα,ws,𝒟,λ,Q,x,y,Υ,𝒮},

L = If[Length@Dimensions[LL]==2,{JumpOp[LL,type]},JumpOp[#,type]&/@LL]; (* List of operators *)
d = Length@L;
μ = Which[
Dimensions[μμ]==={d},{μμ},
Dimensions[μμ]==={},{μμ ConstantArray[1,d]},
True,μμ]; (* R×d matrix *)
R = Length@μ;
ρv = Vec[ρ];
ℒα = μ.L;
Jα = UnTr[#.ρv]&/@ℒα;

If[R===1,
Table[{t,(1/((Jα[[1]])^2))Tr[ℒα[[1]].MatrixExp[ℒ t,ℒα[[1]].ρv]]},{t,ts}], 
Table[{t,Table[(1/(Jα[[α]]Jα[[β]])) UnTr[ℒα[[β]].MatrixExp[ℒ t,ℒα[[α]].ρv]],{α,R},{β,R}]},{t,ts}]
]//Re

]

Example usage

(* Resonantly driven qubit *)
Clear[γ,Ω,Δ];
H = (1/2)σx;
c = (Sqrt[γ])σm;
ℒ = Liouvillian[H,{c}];
ρ = AnalyticalSteadyState[ℒ];

g2=FullSimplify[FCSg2MEXP[{τ},ρ,ℒ,{c}][[1,2]],{γ>0}]

Integrate[g2-1,{τ,0,∞},Assumptions->γ>0]

(* This formula can actually be written in a prettier way, in terms of the Rabi frequency (Subscript[Ω, R])=(Sqrt[1-(γ^2)/4]) *)
g2pretty = 1 - (E^(-3 γ τ/4))(Cos[ΩR τ]+ ((3(Sqrt[1-((ΩR)^2)]))/(ΩR))Sin[ΩR τ]);
g2 - g2pretty/.ΩR->(Sqrt[1-(γ^2)/16])/.{γ->0.3,τ->1.}//Chop

Plot[Evaluate@Table[g2,{γ,{0.1,1}}],{τ,0,20},
PlotStyle->{red,Black},
PlotLegends->legend[{"γ = 0.1", "γ = 1"},{0.7,0.2}]
]

(* Alternative way of computing g2 *)
γ = 0.3;
g2/.τ->0.3//Chop
FCSg2Eigen[ρ,ℒ,{c}][0.3]

Two-point function  (Subscript[F, αβ])= (Subscript[M, αβ])δ(τ)+(Subscript[J, α])(Subscript[J, β])((Subscript[g, αβ]^((2)))-1)

Clear[FCSTwoPointFunctionEigen]
FCSTwoPointFunctionEigen[ρ_,ℒ_,LL_,μμ_:1,type_:"PD"]:=Module[{L,μ,ρv,d,Jk,M,R,ℒbig,ℒα,Jα,ws,𝒟,λ,Q,x,y,Υ,𝒮},

L = If[Length@Dimensions[LL]==2,{JumpOp[LL,type]},JumpOp[#,type]&/@LL]; (* List of operators *)
d = Length@L;
μ = Which[
Dimensions[μμ]==={d},{μμ},
Dimensions[μμ]==={},{μμ ConstantArray[1,d]},
True,μμ]; (* R×d matrix *)
R = Length@μ;
ρv = Vec[ρ];
(*Jk = Table[UnTr[lop.ρv],{lop,L}];*)
(*M = Which[
type=="PD",μ.DiagonalMatrix[Jk].μ\[Transpose],
type=="Homodyne"||True,μ.μ\[Transpose]
]//Chop;

*)
ℒα = μ.L;
Jα = UnTr[#.ρv]&/@ℒα//Chop;
{λ,Q} = Eigsys[ℒ];
λ = Drop[λ,-1];
x = (Q\[Transpose])[[1;;-2]];
y=Inverse[Q][[1;;-2]];
(*Defined so that ℒ = Sum[λ[[i]] out[x[[i]],y[[i]]\[Conjugate]],{i,Length[ℒ]-1}] *)

Υ = Table[UnTr[ℒα[[β]].out[x[[j]],y[[j]]\[Conjugate]].ℒα[[α]].ρv],{α,R},{β,R},{j,Length[λ]}];

If[R===1,
Function[ Chop@Total@Table[Exp[λ[[j]] #] Υ[[1,1,j]],{j,Length[λ]}] ],
Function[Table[Chop@Total@Table[Exp[λ[[j]] #]Υ[[β,α,j]],{j,Length[λ]}] ,{α,R},{β,R}]]
]
]

Clear[FCSTwoPointFunctionMEXP]
FCSTwoPointFunctionMEXP[ts_,ρ_,ℒ_,LL_,μμ_:1,type_:"PD"]:=Module[{L,μ,ρv,d,Jk,M,R,ℒbig,ℒα,Jα,ws,𝒟,λ,Q,x,y,Υ,𝒮},

L = If[Length@Dimensions[LL]==2,{JumpOp[LL,type]},JumpOp[#,type]&/@LL]; (* List of operators *)
d = Length@L;
μ = Which[
Dimensions[μμ]==={d},{μμ},
Dimensions[μμ]==={},{μμ ConstantArray[1,d]},
True,μμ]; (* R×d matrix *)
R = Length@μ;
ρv = Vec[ρ];
(*Jk = Table[UnTr[lop.ρv],{lop,L}];*)
(*M = Which[
type=="PD",μ.DiagonalMatrix[Jk].μ\[Transpose],
type=="Homodyne"||True,μ.μ\[Transpose]
]//Chop;

*)
ℒα = μ.L;
Jα = UnTr[#.ρv]&/@ℒα//Chop;
(*{λ,Q} = Eigsys[ℒ];
λ = Drop[λ,-1];
x = (Q\[Transpose])[[1;;-2]];
y=Inverse[Q][[1;;-2]];
*)(*Defined so that ℒ = Sum[λ[[i]] out[x[[i]],y[[i]]\[Conjugate]],{i,Length[ℒ]-1}] *)

(*Υ = Table[UnTr[ℒα[[β]].out[x[[j]],y[[j]]\[Conjugate]].ℒα[[α]].ρv],{α,R},{β,R},{j,Length[λ]}];*)

If[R===1,
Chop@Table[{t,UnTr[ℒα[[1]].MatrixExp[ℒ t,ℒα[[1]].ρv]]-((Jα[[1]])^2)},{t,ts}],
Chop@Table[{t,Table[UnTr[ℒα[[β]].MatrixExp[ℒ t,ℒα[[α]].ρv]]-Jα[[α]]Jα[[β]],{α,R},{β,R}]},{t,ts}]
]
]

Full probability P(N(t)=n), for the integrated current

P(n,t)=(∫_(-π)^π)(e^(-i n χ)) tr((e^((Subscript[ℒ, χ])t))(Subscript[ρ, 0]))dχ/2π

Clear[FCSProbability]
FCSProbability[t_,ρ_,ℒ_,cops_,μμ_:1,npts_:1000,tol_:(10^(-8))]:=Module[{L,χs,δχ,ℒs,ρv,Ms,n,μ,χ,nmax,prob,P},
μ = If[μμ===1,
ConstantArray[1,Length@cops],
μμ];

χs = linspace[-π,π,npts];
δχ = χs[[2]]-χs[[1]];
ℒs = Table[ℒ +Total@Table[((E^(I χ μ[[i]])) -1)JumpOp[cops[[i]]],{i,Length@cops}] ,{χ,χs}];

ρv = Vec[ρ];
Ms = Chop@Table[Tr[MatrixExp[L t,ρv]],{L,ℒs}];

prob[nns_]:=Table[{n,(1/(2π))Trapz[(E^(-I n χs)) Ms,δχ]},{n,nns}]//Chop;

nmax = 10;
P = prob[Range[-nmax,nmax]];
While[P[[1,2]]+P[[-1,2]] > tol,
P=Join[prob[Range[-nmax-10,-nmax-1]],P,prob[Range[nmax+1,nmax+10]]];
nmax = nmax+10;
];
P
]

Example usage

H = 0.4σz+σx;
cops = {0.2σm};
ℒ = Liouvillian[H,cops];
ρ = AnalyticalSteadyState[ℒ]//mf;

(* Takes a second to run *)

Clear[P];
ts = Range[0,1000,4];
do[
P[t] = FCSProbability[t,ρ,ℒ,cops],
{t,ts}]

(* run this to show animation *)
Animate[ListStepPlot[P[t],Filling->Axis,PlotRange->{{-3,30},{0,0.14}},PlotRangePadding->{{None,None},{None,Scaled[0.1]}},PlotLabel->t,ImageSize->350],{t,ts}]

Examples

Example usage

Single qubit model coupled to a bath, and with a coherent drive.

H = σz+0.8 σx;
c1 = (Sqrt[0.3])σm;
c2 = (Sqrt[0.65])σp;
ℒ = Liouvillian[H,{c1,c2}];
ρ = SteadyState[ℒ]//mf;

Average
Average current of emission and absorptions

{FCSAverage[ρ,ℒ,c1],FCSAverage[ρ,ℒ,c2]}

Net current (absorptions - emissions)

FCSAverage[ρ,ℒ,{c1,c2},{-1,1}]

The syntax also accepts multiple current choices at a time (here, all 3 results above)

FCSAverage[ρ,ℒ,{c1,c2},{{1,0},{0,1},{-1,1}}]

Choices of μ are not restricted to 0,1,-1. Any value can be provided (used in e.g. defining energy currents)

Diffusion matrix
The syntax is identical to that of the average

{FCSDiffusionMatrix[ρ,ℒ,c1],FCSDiffusionMatrix[ρ,ℒ,c2]}

(* But if we input multiple currents together, this also yields the covariance between them *)
FCSDiffusionMatrix[ρ,ℒ,{c1,c2},{{1,0},{0,1}}]//mf;

Homodyne detection
Add “Homodyne” to convert results to that of homodyning. 
To add angle, redefine c1 c2

FCSAverage[ρ,ℒ,c1,1,"Homodyne"] (* factor of 1 is the optional choice of μ *)
FCSAverage[ρ,ℒ,c1 (E^(I π/4)),1,"Homodyne"]

(* Homodyning the entire Bloch sphere *)
ListLinePlot[Table[{ϕ,FCSAverage[ρ,ℒ,c1 (E^(I ϕ)),1,"Homodyne"]},{ϕ,0,2π,0.01}]]

Same for the diffusion matrix

FCSDiffusionMatrix[ρ,ℒ,{c1,c2},{{1,0},{0,1}},"Homodyne"]//mf;

Power Spectrum also has the same syntax. 
But there are two options: 
- FCSPowerSpectrumEigen[] diagonalizes ℒ and returns a function of ω, which is then quick to evaluate. 
-  FCSPowerSpectrumLinearSys[] requires a specific list of frequencies “ωs” and operates by solving linear systems.

𝒮=FCSPowerSpectrumEigen[ρ,ℒ,{c1,c2},{{1,0},{0,1}}]

(* Evaluate at specific frequencies *)
𝒮[5.0]//mf;

FCSPowerSpectrumLinearSys[{5.0},ρ,ℒ,{c1,c2},{{1,0},{0,1}}]
%[[1,2]]//mf;

𝒮[3.][[1,1]]

Plot[{
Evaluate@Re[𝒮[ω][[1,1]]],
Evaluate@Re[𝒮[ω][[2,2]]]
},{ω,-5,5}]

The “coherence” in the language of signal processing is (Subscript[𝒞, xy])(ω) = ((|(Subscript[𝒮, xy])(ω)((|)^2))/((Subscript[𝒮, xx])(ω)(Subscript[𝒮, yy])(ω)))
https://en.wikipedia.org/wiki/Coherence_(signal_processing)

Plot[{
Evaluate@Re[(((Abs[𝒮[ω][[1,2]]])^2)/(𝒮[ω][[1,1]] 𝒮[ω][[2,2]]))]
},{ω,-5,5},PlotRange->All]

Example: Reproducing Fig. 2(a) of arXiv 2103.07791

Clear[γu,γl,nu,nl,Δ,ϵ,σ];
γu = 2.0;
γl = 0.1;
nl = 5.0;
nu = 0.027; 
Δ = 0.0;

Do[σ[i,j] = Proj[3,i+1,j+1],{i,0,2},{j,0,2}];
H =  -Δ σ[1,1] + ϵ(σ[1,0] + σ[0,1]);
cops = {(Sqrt[γl (nl+1)])σ[0,2],(Sqrt[γl nl])σ[2,0],(Sqrt[γu(nu+1)])σ[1,2],(Sqrt[γu nu])σ[2,1]};
ℒ = Liouvillian[H,cops];
ρ = AnalyticalSteadyState[ℒ];
𝒬=Table[
ave = FCSAverage[ρ,ℒ,cops,{-1,1,0,0}];
var=FCSDiffusionMatrix[ρ,ℒ,cops,{-1,1,0,0}];
{ϵ,Log[((nl(nu+1))/(nu(nl+1)))] (var/ave)},{ϵ,0.001,0.8,0.01}];
ListLinePlot[𝒬,PlotRange->{0,4},
GridLines->{None,{2}},
GridLinesStyle->Directive[Black, Dashed],
PlotStyle->red,
FrameLabel->{"ϵ","𝒬"},
Epilog->Text["classical TUR",Scaled[{0.73,0.42}]]
]

Example: “Mollow Triplet”; comparison with the emission & absorption spectra

I’m actually not sure this is really the Mollow triplet, since that refers to the emission spectrum and here I am plotting the coherence (in the signal processing sense)

γs = {0.01,0.1,0.5,1.};
f = 0.7;
Clear[𝒮,ℰ,𝒮h,𝒜];
Do[
H =(*σz+*) 1.8 σz+σx;
c1 = (Sqrt[γ])σm;

ℒ = Liouvillian[H,{c1,c2}];
ρ = SteadyState[ℒ];
𝒮[γ]=FCSPowerSpectrumEigen[ρ,ℒ,{c1,c2},{{1,0},{0,1}}(*,"Homodyne"*)];
𝒮h[γ]=FCSPowerSpectrumEigen[ρ,ℒ,{c1,c2},{{1,0},{0,1}},"Homodyne"];
ℰ[γ]=EmissionSpectrum[ρ,{ω},ℒ,(Sqrt[γ])σm];
𝒜[γ]=AbsorptionSpectrum[ρ,{ω},ℒ,(Sqrt[γ])σm];
,{γ,γs}]
Table[Plot[{
Re@𝒮[γ][ω][[1,1]]
},{ω,-5,5},PlotRange->All],{γ,γs}]

γ = 0.01;
Plot[{
Re@𝒮[γ][ω][[1,1]]
},{ω,-5,5},PlotRange->All]

Table[Plot[ℰ[γ],{ω,-5,5}],{γ,γs}]

Plot[S/.{γ->0.1,Ω->4},{ω,-7,7}]

γs = {0.1,0.5,1.};
f = 0.7;
Clear[𝒮];
Do[
H =σz+ σx;
c1 = (Sqrt[γ (1-f)])σm;
c2 = (Sqrt[γ f])σp;

ℒ = Liouvillian[H,{c1,c2}];
ρ = SteadyState[ℒ];
𝒮[γ]=FCSPowerSpectrumEigen[ρ,ℒ,{c1,c2},{{1,0},{0,1}}];
,{γ,γs}]
Plot[{
Evaluate@Table[Re[(((Abs[𝒮[γ][ω][[1,2]]])^2)/(𝒮[γ][ω][[1,1]] 𝒮[γ][ω][[2,2]]))],{γ,γs}]
},{ω,-5,5},PlotRange->All]

Plot[{
Evaluate@Table[Re@𝒮[γ][ω][[1,1]] ,{γ,γs[[3]]}]
},{ω,-5,5},PlotRange->All]

γs = {0.1,0.5,1.};
f = 0.7;
Clear[𝒮];
Do[
H =σz+ σx;
c1 = (Sqrt[γ (1-f)])σm;
c2 = (Sqrt[γ f])σp;

ℒ = Liouvillian[H,{c1,c2}];
ρ = SteadyState[ℒ];
𝒮[γ]=FCSPowerSpectrumEigen[ρ,ℒ,{c1,c2},{{1,0},{0,1}},"Homodyne"];
,{γ,γs}]
Plot[{
Evaluate@Table[Re[(((Abs[𝒮[γ][ω][[1,2]]])^2)/(𝒮[γ][ω][[1,1]] 𝒮[γ][ω][[2,2]]))],{γ,γs}]
},{ω,-5,5},PlotRange->All]

Ex: Mollow Triplet

Clear[γ,Ω,Δ];
H = (Δ/2)σz+σx;
c = (Sqrt[γ])σm;
ℒ = Liouvillian[H,{σm},{γ}];
ρ = AnalyticalSteadyState[ℒ]//mf;

J=cf@FCSAverage[ρ,ℒ,{c}]

S = FullSimplify[FCSPowerSpectrumLinearSys[{ω},ρ,ℒ,{c}][[1,2]],γ>0]

g2=FCSG2MEXP[{τ},ρ,ℒ,{c}][[1,2]];

Fτ = FCSTwoPointFunctionMEXP[{τ},ρ,ℒ,{c}][[1,2]];

𝒲=FullSimplify[ToRadicals@FullSimplify[WaitingTimeDistribution[ρ,ℒ,JumpOp@c,t],{γ>0}],{γ>0,t>0,Δ>0}]

Clear[γ,Δ];
Manipulate[
Grid[{{
Plot[Evaluate[Re@Fτ/.{γ->γγ,Δ->ΔΔ}],{τ,0,15/ γγ},GridLines->{None,{0}},GridLinesStyle->Directive[Black, Dashed],PlotStyle->COLORLIST[[2]],AspectRatio->1,FrameLabel->{"γτ","F(τ)"},ImageSize->300],
Plot[S/.{γ->γγ,Δ->ΔΔ},{ω,-20 γγ,20γγ},GridLines->Evaluate[{{-(Sqrt[4+(Δ^2)]),(Sqrt[4+(Δ^2)])},{((4 γ)/(8+(γ^2)+4 (Δ^2)))}}/.{γ->γγ,Δ->ΔΔ}],GridLinesStyle->Directive[Black, Dashed],PlotStyle->COLORLIST[[2]],AspectRatio->1,FrameLabel->{"ω/γ","S(ω)"},ImageSize->300],
Plot[𝒲/.{γ->γγ,Δ->ΔΔ},{t,0,15 /γγ},GridLines->{None,{0}},GridLinesStyle->Directive[Black, Dashed],PlotStyle->COLORLIST[[2]],AspectRatio->1,FrameLabel->{"γτ","𝒲"},ImageSize->300]
}}],{{γγ,1},0.1,5},{{ΔΔ,0},0.,5}]

γγ = 3.0;
ΔΔ = 0.0;
plt1=Grid[{{
Plot[Evaluate[Re@Fτ/.{γ->γγ,Δ->ΔΔ}],{τ,0,15/ γγ},GridLines->{None,{0}},GridLinesStyle->Directive[Black, Dashed],PlotStyle->COLORLIST[[2]],AspectRatio->1,FrameLabel->{"γτ","F(τ)"},ImageSize->300],
Plot[S/.{γ->γγ,Δ->ΔΔ},{ω,-10 γγ,10γγ},GridLines->Evaluate[{{-(Sqrt[4+(Δ^2)]),(Sqrt[4+(Δ^2)])},{((4 γ)/(8+(γ^2)+4 (Δ^2)))}}/.{γ->γγ,Δ->ΔΔ}],GridLinesStyle->Directive[Black, Dashed],PlotStyle->COLORLIST[[2]],AspectRatio->1,FrameLabel->{"ω/γ","S(ω)"},ImageSize->300],
Plot[𝒲/.{γ->γγ,Δ->ΔΔ},{t,0,25 /γγ},GridLines->{None,{0}},GridLinesStyle->Directive[Black, Dashed],PlotStyle->COLORLIST[[2]],AspectRatio->1,FrameLabel->{"γτ","𝒲"},ImageSize->300]
}}];
γγ = 0.4;
ΔΔ = 0.0;
plt2=Grid[{{
Plot[Evaluate[Re@Fτ/.{γ->γγ,Δ->ΔΔ}],{τ,0,15/ γγ},GridLines->{None,{0}},GridLinesStyle->Directive[Black, Dashed],PlotStyle->COLORLIST[[2]],AspectRatio->1,FrameLabel->{"γτ","F(τ)"},ImageSize->300],
Plot[S/.{γ->γγ,Δ->ΔΔ},{ω,-10 γγ,10γγ},GridLines->Evaluate[{{-(Sqrt[4+(Δ^2)]),(Sqrt[4+(Δ^2)])},{((4 γ)/(8+(γ^2)+4 (Δ^2)))}}/.{γ->γγ,Δ->ΔΔ}],GridLinesStyle->Directive[Black, Dashed],PlotStyle->COLORLIST[[2]],AspectRatio->1,FrameLabel->{"ω/γ","S(ω)"},ImageSize->300],
Plot[𝒲/.{γ->γγ,Δ->ΔΔ},{t,0,25 /γγ},GridLines->{None,{0}},GridLinesStyle->Directive[Black, Dashed],PlotStyle->COLORLIST[[2]],AspectRatio->1,FrameLabel->{"γτ","𝒲"},ImageSize->300]
}}];
Grid[{{Labeled[plt1,Style["γ/Ω=3",22,FontFamily->"Times"],Top]},{},{},{Labeled[plt2,Style["γ/Ω=0.4",22,FontFamily->"Times"],Top]}}]

ρt=Unvec@MatrixExp[ℒ t,Vec[Proj[2,2]]];
{sx,sy,sz} = {Tr[σx.ρt],Tr[σy.ρt],Tr[σz.ρt]};
Show[BlochSphere[],
ParametricPlot3D[{sx,sy,sz},{t,0,20},PlotStyle->Black,PlotRange->All],PlotRange->All]

Example: homodyne spectrum of squeezing in a parametric amplifier

Based on chapter 7 of Walls & Milburn. 
Computes equations 7.61 & 7.62.

(there is a factor of 2 different, which I believe is related to the way they define the quadratures)

LoadBosonicOperators[nmax = 40];
ωs = range[-5,5,0.1]+0.02;
ϵ = 0.4;
γ = 2;
H = ((I ϵ)/2) (a\[ConjugateTranspose].a\[ConjugateTranspose]-a.a);
cop = (Sqrt[γ])a;
ℒ = Liouvillian[H,{cop}];
ρ = SteadyState[ℒ];

Sx = FCSPowerSpectrumLinearSys[ωs,ρ,ℒ,{a},1,"Homodyne"];
Sy = FCSPowerSpectrumLinearSys[ωs,ρ,ℒ,{I a},1,"Homodyne"];

Grid@{{Show[
Plot[1+ ((γ ϵ)/(((((γ/2)-ϵ))^2)+(ω^2))),{ω,-5,5},PlotStyle->Red],
ListLinePlot[Sx,Joined->False,PlotMarkers->Automatic],
FrameLabel->{"ω","(Subscript[S, X])"}
],
Show[
Plot[1- ((γ ϵ)/(((((γ/2)+ϵ))^2)+(ω^2))),{ω,-5,5},PlotStyle->Red],
ListLinePlot[Sy,Joined->False,PlotMarkers->Automatic],
FrameLabel->{"ω","(Subscript[S, P])"}
]}}

Algebraic method in Gernot’s notes

ℒp = ℒ’(χ=0)
ℒpp = ℒ’’(χ=0)

GernotDiffusionCoefficient[ρ_,ℒ_,ℒp_,ℒpp_]:=Module[{ℐ,d,ℒ2,b,σ,S1,S2},
ℐ = -I Tr[Unvec[ℒp.Vec[ρ]]];
d = Length@ℒ;
ℒ2 =Join[ℒ,{Vec@Eye[(Sqrt[d])]}];
b = Join[I ℐ Vec[ρ] - ℒp.Vec[ρ],{0}];
σ = LinearSolve[ℒ2,b];
S1 = -Tr[Unvec[ℒpp.Vec[ρ]]];
S2 =-2Tr[Unvec[ℒp.σ]];
S1+S2//Chop
]

Clear[γu,γl,nu,nl,Δ,ϵ,σ];
γu = 2.0;
γl = 0.1;
nl = 5.0;
nu = 0.027; 
Δ = 0.0;
ϵ = 0.3;

Do[σ[i,j] = Proj[3,i+1,j+1],{i,0,2},{j,0,2}];
H =  -Δ σ[1,1] + ϵ(σ[1,0] + σ[0,1]);
cops = {(Sqrt[γl (nl+1)])σ[0,2],(Sqrt[γl nl])σ[2,0],(Sqrt[γu(nu+1)])σ[1,2],(Sqrt[γu nu])σ[2,1]};
ℒ = Liouvillian[H,cops];
ρ = AnalyticalSteadyState[ℒ];

FCSDiffusionMatrix[ρ,ℒ,cops,{-1,1,0,0}]

FCSPowerSpectrumEigen[ρ,ℒ,cops,{-1,1,0,0}][0]

ℒp = -I JumpOp[cops[[1]]]+I JumpOp[cops[[2]]];
ℒpp = - JumpOp[cops[[1]]]- JumpOp[cops[[2]]];
GernotDiffusionCoefficient[ρ,ℒ,ℒp,ℒpp]

Resonant qubit: (g^((2)))  and S(ω)

Reproducing FIg. 1 of Mølmer’sSx =  Phys. Rev. A. 94 032103 (2016)

Clear[γ,Ω,Δ];
H = (Ω/2)σx;
c = (Sqrt[γ])σm;
ℒ = Liouvillian[H,{σm},{γ}];
ρ = AnalyticalSteadyState[ℒ]//mf;

FCSAverage[ρ,ℒ,{c},1,"Homodyne"]//cf
FCSAverage[ρ,ℒ,{c (E^(-I π/2))},1,"Homodyne"]//cf

G2x=FCSG2MEXP[{τ},ρ,ℒ,{c},1,"Homodyne"][[1,2]]//cf

G2y=FCSG2MEXP[{τ},ρ,ℒ,{c (E^(-I π/2))},1,"Homodyne"][[1,2]]//cf

Plot[Evaluate[{G2x,G2y}/.{γ->1,Ω->4}],{τ,0,10}]

Sx = FullSimplify[FCSPowerSpectrumLinearSys[{ω},ρ,ℒ,{c},1,"Homodyne"][[1,2]],γ>0]
Sy = FullSimplify[FCSPowerSpectrumLinearSys[{ω},ρ,ℒ,{c (E^(-I π/2))},1,"Homodyne"][[1,2]],γ>0]

Plot[Evaluate[{Sx,Sy} /.{γ->1,Ω->4}],{ω,-5.2 ,5.2},PlotRange->{0.8,All}]

(g^((2))) function for a single qubit in a bad cavity

Based on Rice & Carmichael, IEEE JOURNAL OF QUANTUM ELECTRONICS, VOL . 24. NO . 7, JULY 1988

LoadBosonicOperators[nmax = 6];
ϵ = 0.01;
g = 3;
κ = 25 ;
γ = 1/5 ;
H = ϵ kron[a+a\[ConjugateTranspose],σ0] + g (kron[a\[ConjugateTranspose],σm] + kron[a,σp]);
cops = {(Sqrt[2κ])kron[a,σ0],(Sqrt[γ])kron[𝕀,σm]};
ℒ=Liouvillian[H,cops];
ρ =AnalyticalSteadyState[ℒ];

ts = linspace[0,15,50];
g2=FCSg2MEXP[ts,ρ,ℒ,(Sqrt[2κ])kron[a,σ0]];
ListLinePlot[g2,PlotRange->{0,10}]

(* Comparison with Eq. (41) of Rice & Carmichael *)
g2RiceCarmichael[ϵ_,g_,κ_,γ_]:=Module[{𝒞 = ((g^2)/(κ γ)),ns = ((γ^2)/(8 (g^2))),μ = 2κ/γ,Y = (ϵ/(κ (Sqrt[ns]))),Ω,τp},
Ω = (1/4)(((1-((8 (Y^2))/(((1+2𝒞))^2))))^(1/2));
τp = γ (1+2𝒞) τ;

(((1-4 (𝒞^2)(E^(-τp/2))))^2)]

Show[
Plot[g2RiceCarmichael[ϵ,g,κ,γ],{τ,0,14},PlotRange->{0,4},PlotStyle->Black],
ListLinePlot[g2,PlotStyle->red],
FrameLabel->{"τ","(G^((2)))(τ)"}
]

Show[
Plot[g2RiceCarmichael[ϵ,g,κ,γ],{τ,0,14},PlotRange->All,PlotStyle->Black],
ListLinePlot[g2,PlotStyle->red,PlotRange->All]]

(* What happens if we approximate the bosonic mode by a qubit *)
(* Only differs at very short times *)
ϵ = 1/100.;
g = 3;
κ = 25 ;
γ = 1/5 ;
H = ϵ kron[σx,σ0] + g (kron[σp,σm] + kron[σm,σp]);
cops = {(Sqrt[2κ])kron[σm,σ0],(Sqrt[γ])kron[σ0,σm]};
ℒ=Liouvillian[H,cops];
(*ℒ=SetPrecision[ℒ,pres=30];*)
ρ =AnalyticalSteadyState[ℒ];
ts = linspace[0,2,50]//Rationalize;
g2q=FCSg2MEXP[ts,ρ,ℒ,(Sqrt[2κ])kron[σm,σ0]];

H = ϵ kron[a+a\[ConjugateTranspose],σ0] + g (kron[a\[ConjugateTranspose],σm] + kron[a,σp]);
cops = {(Sqrt[2κ])kron[a,σ0],(Sqrt[γ])kron[𝕀,σm]};
ℒ=Liouvillian[H,cops];
ρ =AnalyticalSteadyState[ℒ];
g2b=FCSg2MEXP[ts,ρ,ℒ,(Sqrt[2κ])kron[a,σ0]];

Show[
Plot[g2RiceCarmichael[ϵ,g,κ,γ],{τ,0,2},PlotRange->All,PlotStyle->Black],
ListLinePlot[{g2q,g2b}]
]

Homodyne spectrum for dephasing of a qubit

Clear[γ,Ω];
H = (Ω/2)σx;
c = (Sqrt[γ])σz;
ℒ = Liouvillian[H,{c}]//cf;
ρ = AnalyticalSteadyState[ℒ]//mf;

(* Average homodyne current is zero *)
FCSAverage[ρ,ℒ,{c},1,"Homodyne"]//cf

(* But the spectrum is not *)
S = FCSPowerSpectrumLinearSys[{ω},ρ,ℒ,{c},1,"Homodyne"][[1,2]]//cf
G2 = FCSG2MEXP[{t},ρ,ℒ,{c},1,"Homodyne"][[1,2]]//cf

Row[
{Plot[G2/.{Ω->1,γ->0.1},{t,0.01,20}],
Plot[S/.{Ω->1,γ->0.1},{ω,-10,10}]}
]

Compute the spectrum numerically using Homodyne solver

dt = 0.01;
tf = 1000;
Ω = 1.0;
γ = 0.1;
sim = HomodyneSimulatePureState[{1,0},H,c,dt,tf]["J"];

F=TwoPointCorrelation[butter[sim,150,dt],Round[30/dt],dt,4];
Show[
Plot[G2/.{Ω->1,γ->0.1},{t,0.01,30},PlotStyle->Red],
ListLinePlot[F,PlotStyle->Directive[Black,Opacity[0.25]]],
AspectRatio->1/4,
ImageSize->700
]

Show[
Plot[S/.{Ω->1,γ->0.1},{ω,-3,3},PlotStyle->Red,PlotRange->{{-3,3},{0.8,6}}],
ListLinePlot[PowerSpectrum[sim,dt,8],PlotStyle->Directive[Black,Opacity[0.25]],PlotRange->{{-3,3},All}]
]

TURs

Hasegawa steady-state TUR

Based on https://link.aps.org/doi/10.1103/PhysRevLett.125.050601

In this case (Subscript[H, θ]) = (1+θ) H and (Subscript[L, k,θ]) = (Sqrt[1+θ])(Subscript[L, k])
Hence 

(∂_θ)H = H   and   (∂_θ)(Subscript[L, k,θ]) = (1/(2(Sqrt[1+θ])))(Subscript[L, k ])= (Subscript[L, k])/2 since  we want both evaluated in the limit θ -> 0.

Clear[HasegawaSteadyStateTUR];
HasegawaSteadyStateTUR[ρ_,ℒ_,H_,cops_]:=GammelmarkMolmerMFisher[ρ,ℒ,H,H,cops,#/2&/@cops]

Example usage

g = {1,0};
e = {0,1};
H = Δ out[e,e] + (Ω/2)(out[e,g] + out[g,e]);
L = (Sqrt[κ])out[g,e];
ℒ = Liouvillian[H,{out[g,e]},{κ}];
ρ = AnalyticalSteadyState[ℒ]//Simplify//mf;

has=HasegawaTUR[ρ,ℒ,H,{L}]//cf

𝒟 = FCSDiffusionMatrix[ρ,ℒ,{L}]//cf
J=Tr[L\[ConjugateTranspose].L.ρ]//cf

𝒟

(𝒟/(J^2))//Simplify

Plot[Evaluate[{(𝒟/(J^2)),1/has}/.{Ω->1,κ->1/2}],{Δ,0,2.5}]

Hasegawa transient TUR

Based on https://link.aps.org/doi/10.1103/PhysRevLett.126.010602

Clear[HasegawaTransientTUR]
HasegawaTransientTUR[t_,ρ_,H_,cops_]:=Module[{Ξ,Heff,V0},
Heff = EffectiveNonHermitianHamiltonian[H,cops];
V0 = MatrixExp[-I Heff t];
Ξ = Tr[Inverse[(V0\[ConjugateTranspose].V0)].ρ]- 1
]

Example usage

g = {1,0};
e = {0,1};
H = Δ out[e,e] + (Ω/2)(out[e,g] + out[g,e]);
L = (Sqrt[κ])out[g,e];
ℒ = Liouvillian[H,{out[g,e]},{κ}];
ρ = (({{0, 0}, {0, 1}}));
(*ρ = AnalyticalSteadyState[ℒ]//Simplify//mf;*)

Ξ=HasegawaTransientTUR[t,ρ,H,{L}];
ℒχ =ℒ-JumpOp[L] + (E^(I χ))JumpOp[L]//cf;
𝒞 = Log@UnTr[MatrixExp[ℒχ t].Vec[ρ]];
𝒟 = (((-I))^2)D[𝒞,χ,χ]/.χ->0;
J=-I D[𝒞,χ]/.χ->0;

Plot[Evaluate[Re@{(𝒟/(J^2))t,t/Ξ}/.{Ω->0.5,κ->0.1,Δ->0.0}],{t,1,130},PlotRange->All]

Modified Hasegawa’s bound

Clear[ModifiedHasegawa];
ModifiedHasegawa[ρ_,ℒ_,LL_,μμ_:1,type_:"PD"]:=Module[{L,μ,ρv,d,Jk,M0,R,ℒbig,ℒα,Jα,ws,𝒟,M,ℋ,ψ},

L = If[Length@Dimensions[LL]==2,{JumpOp[LL,type]},JumpOp[#,type]&/@LL]; (* List of operators *)
d = Length@L;
μ = Which[
Dimensions[μμ]==={d},{μμ},
Dimensions[μμ]==={},{μμ ConstantArray[1,d]},
True,μμ]; (* R×d matrix *)
R = Length@μ;
ρv = Vec[ρ];
Jk = Table[UnTr[lop.ρv],{lop,L}];

M0 = Which[
type=="PD",Total@Jk,
type=="Homodyne"||True,μ.μ\[Transpose]
]//Chop;

ℋ = ℒ-Sum[LindbladToVec[lop],{lop,LL}];
ws = Table[DrazinApply[ℒ,ℋ.ρv],{r,R}];

ψ = Table[(1/(μ[[r]].Jk))Sum[μ[[r,k]] UnTr[L[[k]].ws[[r]]],{k,d}],{r,R}][[1]];
{M0,ψ,(1/M0)(((1+ψ))^2)} 
]

(*Clear[ModifiedHasegawaOptimalDeformation];
ModifiedHasegawaOptimalDeformation[ρ_,ℒ_,LL_,μμ_:1,type_:"PD"]:=Module[{L,μ,ρv,d,Jk,M,R,ℒbig,ℒα,Jα,ws,𝒟μ,ℒ1,x,ℒJ},

L = If[Length@Dimensions[LL]==2,{JumpOp[LL,type]},JumpOp[#,type]&/@LL]; (* List of operators *)
d = Length@L;
μ = Which[
Dimensions[μμ]==={d},{μμ},
Dimensions[μμ]==={},{μμ ConstantArray[1,d]},
True,μμ]; (* R×d matrix *)
R = Length@μ;
ρv = Vec[ρ];
Jk = Table[UnTr[lop.ρv],{lop,L}];

M = Which[
type=="PD",μ.DiagonalMatrix[Jk].μ\[Transpose],
type=="Homodyne"||True,μ.μ\[Transpose]
]//Chop;

ℒJ = Sum[μ[[1,k]] L[[k]],{k,d}];
ws = Table[DrazinApply[ℒ,LindbladToVec[LL[[q]]].ρv],{i,R},{q,d}];
Total@Table[((((μ[[1,k]] Jk[[k]] - UnTr[ℒJ.ws[[1,k]]]))^2)/(Jk[[k]])),{k,d}]
];*)

(* Apparently wrong *)
Clear[ModifiedHasegawaUnitary];
ModifiedHasegawaUnitary[ρ_,ℒ_,LL_,H_,μμ_:1,type_:"PD"]:=Module[{L,μ,ρv,d,Jk,M0,R,ℒbig,ℒα,Jα,ws,𝒟,M,ℋ,ψ,wn,wd,ℒJ},

L = If[Length@Dimensions[LL]==2,{JumpOp[LL,type]},JumpOp[#,type]&/@LL]; (* List of operators *)
d = Length@L;
μ = Which[
Dimensions[μμ]==={d},{μμ},
Dimensions[μμ]==={},{μμ ConstantArray[1,d]},
True,μμ]; (* R×d matrix *)
R = Length@μ;
ρv = Vec[ρ];
Jk = Table[UnTr[lop.ρv],{lop,L}];

M0 = Which[
type=="PD",Total@Jk,
type=="Homodyne"||True,μ.μ\[Transpose]
]//Chop;

wn = DrazinApply[ℒ,Vec[-I(H.ρ-ρ.H)]];
wd = DrazinApply2[ℒ, ρv,Vec[H.ρ+ρ.H]];
ℒJ = Sum[μ[[1,k]] L[[k]],{k,d}];

-(((UnTr[ℒJ.wn])^2)/(Tr[H.Unvec[wd]]))
]

Example usage

Clear[γ,Ω,Δ];
H = (Δ/2)σz+(Ω/2) σx;
cops = {(Sqrt[γm])σm,(Sqrt[γp])σp};
ℒ = Liouvillian[H,cops]//cf;
ρ = AnalyticalSteadyState[ℒ]//cf//mf;

J=FCSAverage[ρ,ℒ,cops,{{μ1,μ2}}]//cf
𝒟 = FCSDiffusionMatrix[ρ,ℒ,cops,{{μ1,μ2}}]//cf;
ratio = 𝒟/(J^2);

M = ((μ1)^2)FCSAverage[ρ,ℒ,cops,{{1,0}}]+((μ2)^2)FCSAverage[ρ,ℒ,cops,{{0,1}}]//cf

{M0,ψ,bound}=ModifiedHasegawa[ρ,ℒ,cops,{{μ1,μ2}}]//cf

Limit[ψ,Ω->0]

(* Apparently horrible; still to check *)
boundOpt = ModifiedHasegawaOptimalDeformation[ρ,ℒ,cops,{{μ1,μ2}}]//cf

hasegawaoriginal = 1/HasegawaSteadyStateTUR[ρ,ℒ,H,cops]//cf;

boundUnitary = ModifiedHasegawaOptimalDeformation[ρ,ℒ,cops,H,{{μ1,μ2}}]//cf;

{Plot[Evaluate[Re@{𝒟,(J^(2 ))bound,(J^2)hasegawaoriginal,(J^2)/M0}/.{Δ->0.3,γm->1,γp->0.5,μ1->1,μ2->1}],{Ω,0,4},
ImageSize->550,
PlotStyle->COLORLIST,
FrameLabel->{"Ω",None},
PlotLegends->legend[{"D","(J^2)ℬ","(J^2)Hasegawa","(J^2)/𝒦"},{0.77,0.7}]
],
Plot[Evaluate[Re@{ψ}/.{Δ->0.3,γm->1,γp->0.5,μ1->1,μ2->1}],{Ω,0,4},
PlotStyle->COLORLIST,
FrameLabel->{"Ω","ψ"},
FrameLabel->{"Ω",None}
]}

Plot[Evaluate[Re@{𝒟/(J^2),bound,hasegawaoriginal,1/M0}/.{Δ->0.3,γm->1,γp->0.5,μ1->1,μ2->1}],{Ω,0,4},
ImageSize->550,
PlotStyle->COLORLIST,
FrameLabel->{"Ω",None},
PlotLegends->legend[{"D/(J^2)","ℬ","Hasegawa","1/𝒦"},{0.77,0.5}]
]

Plot[Evaluate[Re@{𝒟/(J^2),((((1+ψ))^2)/M0),(1/M0)}/.{Δ->0.3,γm->1,γp->0.5,μ1->1,μ2->1}],{Ω,0,4},
PlotStyle->COLORLIST,
FrameLabel->{"Ω","ψ"},
FrameLabel->{"Ω",None}
]

(*Manipulate[Plot[Evaluate[Re@{𝒟,(J^(2 ))bound,(J^2)hasegawaoriginal,(J^2)/M0}/.{Δ->ΔΔ,γm->γγm,γp->γγp,μ1->μμ1,μ2->μμ2}],{Ω,0,4},
ImageSize->600,
(*PlotRange->{0,2},*)
PlotStyle->COLORLIST,
FrameLabel->{"Ω",None},
PlotLegends->legend[{"D","(J^2)ℬ","(J^2)Hasegawa","(J^2)/𝒦"},{0.77,0.7}]
],
{{ΔΔ,0.3,"Δ"},-4,4},
{{γγm,1,"(SubMinus[γ])"},0,4},
{{γγp,0.5,"(SubPlus[γ])"},0,4},
{{μμ1,1,"(Subscript[μ, 1])"},-2,2},
{{μμ2,1,"(Subscript[μ, 2])"},-2,2}]*)

Manipulate[Plot[Evaluate[Re@{ψ}/.{Δ->ΔΔ,γm->γγm,γp->γγp,μ1->μμ1,μ2->μμ2}],{Ω,0,4},
ImageSize->600,
(*PlotRange->{0,2},*)
PlotStyle->COLORLIST,
FrameLabel->{"Ω",None}
],
{{ΔΔ,0.3,"Δ"},-4,4},
{{γγm,1,"(SubMinus[γ])"},0,4},
{{γγp,0.5,"(SubPlus[γ])"},0,4},
{{μμ1,1,"(Subscript[μ, 1])"},-2,2},
{{μμ2,1,"(Subscript[μ, 2])"},-2,2}]

ψ//Simplify

ψ/.{μ1->1,μ2->1}//cf
ψ/.{μ1->1,μ2->-1}//cf

Length@Select[Table[ψ/.Thread[{γm,γp}->RandomReal[{0,10},2]]/.Thread[{Ω,μ1,μ2,Δ}->RandomReal[{-3,3},4]],{(10^4)}],#>=0&]

Length@Select[Table[Re[ratio-has11]/.Thread[{γm,γp}->RandomReal[{0,10},2]]/.Thread[{Ω,μ1,μ2,Δ}->RandomReal[{-3,3},4]],{(10^4)}],#<0&]

Length@Select[Table[Re[ratio-boundUnitary]/.Thread[{γm,γp}->RandomReal[{0,10},2]]/.Thread[{Ω,μ1,μ2,Δ}->RandomReal[{-3,3},4]],{(10^4)}],#<0&]

Length@Select[Table[Re[ratio-hasegawaoriginal]/.Thread[{γm,γp}->RandomReal[{0,10},2]]/.Thread[{Ω,μ1,μ2,Δ}->RandomReal[{-3,3},4]],{(10^4)}],#<0&]

J/.Ω->0//cf

𝒟/.Ω->0//cf

ratio/.Ω->0//cf

has/.Ω->0//cf

has2/.Ω->0//cf

Plot[Evaluate[{ratio,has,has2/(J^2)}/.{Ω->0.0,Δ->0.1,γm->0.2,μ1->0.9,μ2->0.9}],{γp,0.3,3}(*,PlotRange->{0,4}*)]

Quantum trajectories & stochastic processes

Gillespie algorithm for classical stochastic processes

Gillespie[W_,x0_,njumps_]:=Module[{χ,r1,𝒲,x,λ,τ,tab},
χ = Range[1,Length@W];
r1 = RandomReal[{0,1},njumps];
𝒲 = W - DiagonalMatrix@Diagonal@W; (* Make sure the matrix has zero diagonals *)

x = x0;
τ = 0;
tab=Table[
λ = Total[𝒲[[All,x]]];
τ =τ -(1/λ)Log[1-r1[[n]]];
x = RandomChoice[((Drop[𝒲[[All,x]],{x}])/λ)->Drop[χ,{x}]];

{τ,x},{n,njumps}];

Prepend[tab,{0,x0}]
];

GillespieMoment[result_,n_]:=((Differences[result[[All,1]]].(((result[[1;;-2,2]]))^n))/(result[[-1,1]]))

Example: quantum harmonic oscillator

Clear[W];
Nb = 1.5;
γ = 1.0;
nmax = 50;
(*W = Table[KroneckerDelta[m,n+1] γ(Nb+1)(n+1)+KroneckerDelta[m,n-1] γ Nb n,{n,0,nmax},{m,0,nmax}]//mf;*)
W = DiagonalMatrix[Table[γ (Nb+1)(n+1),{n,0,nmax-1}],1] + DiagonalMatrix[Table[γ Nb n,{n,1,nmax}],-1];
result = {#[[1]],#[[2]]-1}&/@Gillespie[W,10,550];

ListLinePlot[result,InterpolationOrder->0,
AspectRatio->1/5,
ImageSize->700,
PlotStyle->Black,
GridLines->{None,{Nb}},
GridLinesStyle->Directive[Red,Dashed,Thick],
FrameLabel->{"time","⟨a\[ConjugateTranspose]a⟩"}
]

GillespieMoment[{#[[1]],#[[2]]-1}&/@Gillespie[W,10,(10^5)],1]

Pauli master equation

Input: 
- (Subscript[p, up]): vector (or scalar) of upward transition rates
- (Subscript[p, dw]): vector (or scalar) of downward transition rates.

Syntax: 
- If (Subscript[p, up(dw) ]) are vectors: PauliEquation[(Subscript[p, up]),(Subscript[p, dw])]
- If (Subscript[p, up(dw) ]) are scalars: PauliEquation[d,(Subscript[p, up]),(Subscript[p, dw])] , where d is the dimension

Clear[PauliEquation];
PauliEquation[pup_?VectorQ,pdw_?VectorQ]:=Module[{W,d=Length@pup+1},
W = DiagonalMatrix[pup,-1] + DiagonalMatrix[pdw,1] - DiagonalMatrix[Append[pup,0]]-DiagonalMatrix[Prepend[pdw,0]]
]

PauliEquation[d_,pup_,pdw_]:=PauliEquation[ConstantArray[pup,{d-1}],ConstantArray[pdw,{d-1}]]

Example usage

(* Non-uniform rates *)
W=PauliEquation[Table[p[i],{i,5}],Table[q[i],{i,5}]]//mf;

Table[Total[W[[All,i]]],{i,6}]

(* Uniform rates *)
W = PauliEquation[6,(Subscript[p, up]),(Subscript[p, dw])]//mf;

Table[Total[W[[All,i]]],{i,6}]

Quantum Jump unravelling with pure states

Clear[QuantumJumpUnravelling];
QuantumJumpUnravelling[H_,cops_,ψ0_,ts_,seed_:0]:=Module[{r,Δt,npts,ncops = Length@cops,He,ψ,𝒰,states,jump,jumpList,dyna,n,ss},
If[seed!=0,SeedRandom[seed]];
Δt = ts[[2]]-ts[[1]];
npts=Length[ts]-1;
r = RandomReal[{0,1},npts];
He = H - (I/2)Sum[c\[ConjugateTranspose].c,{c,cops}];
ψ = N@ψ0;
𝒰 = Eye[Length@He]-I He Δt-((He.He ((Δt)^2))/2)+(1/6) I He.He.He ((Δt)^3)+((He.He.He.He ((Δt)^4))/24); 
jumpList = {};
states = {};
n=1;
While[n<npts,
ss=NestWhileList[𝒰.#&,ψ,((Norm[#])^2)>r[[n]]&,1,npts-n+1];
AppendTo[states,Normalize/@ss];
ψ = ss[[-1]];
n = n + Length@ss;
jump=If[ncops==1,1,RandomChoice[Table[Re[ψ\[Conjugate].c\[ConjugateTranspose].c.ψ],{c,cops}]->Range[1,ncops]]];
If[n<=npts,AppendTo[jumpList,{n (*Δt*), jump}]];
ψ = cops[[jump]].ss[[-1]];
ψ = ψ/Norm[ψ];

{states}];
{Flatten[states,1],jumpList}

]

Example usage

H=(1/2)(σz + 0.5 σx);
cops = {0.5σm,0.5σp};
ψ0 = {1,1}/(Sqrt[2]);
ts = Range[0,30.0,0.001];
{ψ,jumpList}=QuantumJumpUnravelling[H,cops,ψ0,ts,3];
jumpList

ups = Select[jumpList,#[[2]]==1&];
dws = Select[jumpList,#[[2]]==2&];
ListLinePlot[{ts,((Abs[ψ[[All,2]]])^2)}\[Transpose],PlotRange->All,
PlotStyle->Directive[Black,Dotted],
Epilog->{
Red,Thickness[0.007],
Table[Line[{
{ts[[ups[[j,1]]]],((Abs[ψ[[ups[[j,1]]-1,2]]])^2)},
{ts[[ups[[j,1]]]],1}}],{j,Length@ups}],
Darker@Green,
Table[Line[{
{ts[[dws[[j,1]]]],((Abs[ψ[[dws[[j,1]]-1,2]]])^2)},
{ts[[dws[[j,1]]]],0}}],{j,Length@dws}]
}
]

ups = Select[jumpList,#[[2]]==1&];
dws = Select[jumpList,#[[2]]==2&];
ListLinePlot[Table[{ts[[jumpList[[j,1]];;jumpList[[j+1,1]]-1]],((Abs[ψ[[jumpList[[j,1]];;jumpList[[j+1,1]]-1,2]]])^2)}\[Transpose],{j,Length@jumpList-1}],
PlotStyle->Black,
Epilog->{
Black,Dashed,
Table[Line[{
{ts[[ups[[j,1]]]],((Abs[ψ[[ups[[j,1]]-1,2]]])^2)},
{ts[[ups[[j,1]]]],1}}],{j,Length@ups}],
Table[Line[{
{ts[[dws[[j,1]]]],((Abs[ψ[[dws[[j,1]]-1,2]]])^2)},
{ts[[dws[[j,1]]]],0}}],{j,Length@dws}]
},
AspectRatio->1/3,
ImageSize->400,
AxesLabel->{"time","observable"},
Ticks->None,
Frame->False,
Axes->True,
AxesStyle->Directive[Arrowheads[0.05],Black],
PlotRange->{{1,32},{0,1.3}},
Prolog->{
Arrow[{{14,0.3},{14,0.7}}],
Arrow[{{18,0.7},{18,0.3}}]
}

]

Ex: Zeno effect in a 3-level system

LoadArbitrarySpinMatrices[1,"a"]
ψ0 = Basis[3,1];
ρ0 = out[ψ0,ψ0];
κ = 15.0;
cops = {(Sqrt[κ])Proj[3,3,3]};
ℒ = Liouvillian[Sx,cops];

ts = Range[0,tf=30,0.005];

Clear[res];
Do[
res[i] = Table[{t,Tr[Proj[3,i,i].Unvec@MatrixExp[ℒ t,Vec[ρ0]]]},{t,0,tf,0.1}]//Chop;
,{i,1,3}]

rasta@ListLinePlot[{res[1],res[2],res[3]},PlotRange->All]

ψs=QuantumJumpUnravelling[Sx,cops,ψ0,ts][[1]];
Do[
res2[i] = Table[((expect[Proj[3,i,i], ψs[[n]]])/((Norm[ψs[[n]]])^2)),{n,1,Length@ψs}]//Chop;
,{i,1,3}]

rasta@ListLinePlot[{res2[1],res2[2],res2[3]},PlotRange->{0,1.1},DataRange->{0,tf}]

S=FCSPowerSpectrumLinearSys[{ω},Eye[3]/3,ℒ,cops][[1,2]];
Plot[S,{ω,-6,6}]

! Quantum Gillespie algorithm for jump unravelling

Clear[QuantumJumpGillespie];
QuantumJumpGillespie[H_,cops_,ψ0_,ts_,njumps_]:=Module[{He,𝒥,Qs,V,ψ,τ,Ps,norm,Vs,tr,δτr,weights,jump,cr,tab},

𝒥 = Sum[c\[ConjugateTranspose].c,{c,cops}];
He = H - (I/2)𝒥;

tr = Range[1,Length@ts];
cr = Range[1,Length@cops];
Vs = Table[MatrixExp[-I He t],{t,ts}];
Qs = Table[ V\[ConjugateTranspose].𝒥.V,{V,Vs}];
norm = Norm[Qs[[-1]]];

ψ = ψ0;
τ= 0;
tab=Table[
Ps = Table[ψ\[Conjugate].Q.ψ,{Q,Qs}]//Chop;
δτr = SillySample[tr,Ps];
τ = τ + ts[[δτr]];
ψ = Vs[[δτr]].ψ;
weights = Table[ψ\[Conjugate].c\[ConjugateTranspose].c.ψ,{c,cops}]//Chop;
jump=RandomChoice[weights->cr];
ψ = cops[[jump]].ψ;
ψ = ψ/Norm[ψ];
{τ,jump(*,ψ*)},{n,njumps}];

(*{tab,norm,He}*)
tab

]

(* Assumes it is a renewal process *)
Clear[QuantumJumpGillespieRenewal];
QuantumJumpGillespieRenewal[H_,cops_,ψ0_,ts_,njumps_]:=Module[{He,𝒥,Qs,V,ψ,τ,Ps,norm,Vs,tr,δτr,weights,jump,cr,tab,δτrs},

𝒥 = Sum[c\[ConjugateTranspose].c,{c,cops}];
He = H - (I/2)𝒥;

tr = Range[1,Length@ts];
cr = Range[1,Length@cops];
Vs = Table[MatrixExp[-I He t],{t,ts}];
Qs = Table[ V\[ConjugateTranspose].𝒥.V,{V,Vs}];
norm = Norm[Qs[[-1]]];

Do[
ψ = cops[[c]].RandomReal[{0,1},Length@ψ0];
ψ = ψ/Norm[ψ];
Ps[c] = Table[ψ\[Conjugate].Q.ψ,{Q,Qs}]//Chop;
δτrs[c] = SillySample[tr,Ps[c],njumps];
,{c,cr}];

τ= 0;
jump = 1;
ψ = cops[[jump]].RandomReal[{0,1},Length@ψ0];
ψ = ψ/Norm[ψ];
tab=Table[
(*δτr = SillySample[Ps[jump],tr];*)
δτr = δτrs[jump][[n]];
τ = τ + ts[[δτr]];
ψ = Vs[[δτr]].ψ;
weights = Table[ψ\[Conjugate].c\[ConjugateTranspose].c.ψ,{c,cops}]//Chop;

jump=RandomChoice[weights->cr];
ψ = cops[[jump]].ψ;
ψ = ψ/Norm[ψ];
{τ,jump},{n,njumps}];

(*{tab,norm,He}*)
tab

]

Example usage

H=(σz + σx);
cops = {σm};
ψ0 = {1,1}/(Sqrt[2]);
ts = linspace[0,50.0,2000];
tab=QuantumJumpGillespie[H,cops,ψ0,ts,(10^4)];
tab2=QuantumJumpGillespieRenewal[H,cops,ψ0,ts,(10^4)];

Histogram[Differences[tab[[All,1]]],{0,100,0.5},"PDF"]

Compare with the numerically exact waiting time distribution.
They only coincide in this case because this is a renewal process. 
In general, the stochastic method here is more general, since it allows for memory in the renewal.

ℒ = Liouvillian[H,cops];
ℒ1 = Sum[JumpOp[c],{c,cops}];
𝒲 = WaitingTimeDistribution[out[ψ0,ψ0],ℒ,ℒ1,#]&/@ts//Chop;

Show[
Histogram[Differences[tab[[All,1]]],{0,30,0.25},"PDF"],
ListLinePlot[𝒲,PlotRange->{{0,30},All},DataRange->{0,Last@ts}],
ImageSize->700,
AspectRatio->1/4]

Homodyne/Diffusion unravelling

Based on Eqs. (4) and (7) of https://arxiv.org/pdf/1410.5345.pdf

Clear[HomodyneSimulate];
HomodyneSimulate[y0_,H_,ccops_,dt_,tf_,ssops_:None,seed_:0]:=Module[{n,sops,nsteps,S,ρ,ψ,dW,M,xave,dY,tab,𝕀,M0,x,c2,xs,c2s,dc,tr,cops,Υ},
(* cops are monitored. sops are not *)
If[seed!=0,SeedRandom[seed]];
cops = If[Length@Dimensions[ccops]===2,{ccops},ccops];
dc = Length@cops;

sops = If[ssops===None,
{ConstantArray[0,{Length@H,Length@H}]},
If[Length@Dimensions[sops]===2,
{ssops},
ssops]];

nsteps = Round[tf/dt];
S= Association[];

S["dt"]=dt;
S["tf"]=tf;
S["nsteps"]=nsteps;
𝕀 = NEye[Length@H];
M0 = 𝕀 - (I H + (1/2)Sum[c\[ConjugateTranspose].c,{c,cops}] + (1/2)Sum[c\[ConjugateTranspose].c,{c,sops}])dt;
dW = RandomVariate[NormalDistribution[0,(Sqrt[dt])],{nsteps,dc}];
ρ = ρ0;
xs = Table[c + c\[ConjugateTranspose],{c,cops}];
c2s = Table[c1.c2,{c1,cops},{c2,cops}];
tr = Sum[c.c,{c,cops}];

If[MatrixQ[y0]||Not[sops===None],
(ρ = If[MatrixQ[y0],y0,out[y0,y0]];
tab=Table[
xave = Table[Tr[x.ρ],{x,xs}];
dY = xave dt + dW[[n]]; 

Υ = dY.cops;
M = M0 + Υ + (1/2)(Υ.Υ-dt tr);
ρ = M.ρ.M\[ConjugateTranspose] + dt Sum[c.ρ.c\[ConjugateTranspose],{c,sops}];
ρ = ρ/Tr[ρ];
{ρ,dY,xave},{n,nsteps}];
),
(ψ = y0;
tab=Table[
xave = Table[ψ\[Conjugate].x.ψ,{x,xs}];
dY = xave dt + dW[[n]]; 

Υ = dY.cops;
M = M0 + Υ + (1/2)(Υ.Υ-dt tr);
ψ = M.ψ//Normalize;
{ψ,dY,xave},{n,nsteps}]
)];

S["state"]=tab[[All,1]]//Chop;
S["J"]=If[Length@Dimensions@ccops==3,tab[[All,2]],Flatten[tab[[All,2]]]]/dt//Chop;
S["xave"]=If[Length@Dimensions@ccops==3,tab[[All,3]],Flatten[tab[[All,3]]]]//Chop;
S
]

Example usage

(* Pure initial state *)
HomodyneSimulate[{1,0},σz,σm,0.1,1]

Example: homodyne for dephasing

((dρ)/dt)=-i [(Subscript[Ωσ, x]),ρ] + γ D[(Subscript[σ, z])]

(* γ >> Ω: zeno-like dynamics *)
SeedRandom[1];
Ω = 1.0;
γ = 2.0;
H = Ω σx;
c = (Sqrt[γ])σz;
ℒ = Liouvillian[H,{c}];
dt = 0.005;
tf = 20;
ψ0 = {1,0};
szExact=Tr[σz.Unvec@MatrixExp[ℒ t,Vec@out[ψ0,ψ0]]]//Chop//Simplify;
sim = HomodyneSimulate[ψ0={1,0},H,c,dt,tf];

Show[
ListLinePlot[sim["xave"]/(2(Sqrt[γ])),PlotRange->All,DataRange->{dt,tf}],
Plot[Re@szExact,{t,0,20},PlotStyle->Red]]

(* γ << Ω *)
SeedRandom[1];
Ω = 1.0;
γ = 0.1;
H = Ω σx;
c = (Sqrt[γ])σz;
ℒ = Liouvillian[H,{c}];
dt = 0.005;
tf = 20;
szExact=Tr[σz.Unvec@MatrixExp[ℒ t,Vec@out[ψ0,ψ0]]]//Chop//Simplify;
sim = HomodyneSimulate[ψ0={1,0},H,c,dt,tf];

Show[
ListLinePlot[sim["xave"]/(2(Sqrt[γ])),PlotRange->All,DataRange->{dt,tf}],
Plot[szExact,{t,0,20},PlotStyle->Red]]

Example: homodyne for spontaneous emission

γ =0.2;
Δ = 1.;
H =(Δ/2)σz+ σx;
c = (Sqrt[γ])σm;
ℒ = Liouvillian[H,{c}];
ψ0 = (1/(Sqrt[2])){1,1(*I*)};
dt = 0.01;
tf = 20.0;

sim =table[HomodyneSimulate[ψ0,H,c,dt,tf]["xave"],{i,200}];
xave=(Sqrt[γ ])Tr[σx.Unvec[MatrixExp[ℒ t,Vec[out[ψ0,ψ0]]]]]//cf//Chop;

rasta@Show[
Plot[xave,{t,0,tf},PlotStyle->Black],
ListLinePlot[Mean@sim,DataRange->{0,tf},PlotRange->All],
PlotRange->All
]

Comparison with QuTIP

Comparing with the example given here: https://qutip.org/docs/latest/guide/dynamics/dynamics-stochastic.html

In the QuTIP example, if one uses a large dt (e.g. dt = 0.003), the simulations diverge. 
Instead, since algorithm implemented here always produces a valid POVM, if dt is not small enough here one will observe a phase lag in the dynamics. 

HomodyneSimulatePureState takes a similar amount of time as QuTIP.

LoadBosonicOperators[nmax = 20];
Δ = 5 2π;
κ = 2;
H = Δ a\[ConjugateTranspose].a;
c = (Sqrt[κ])a;
intensity = 4.;
ψ0 = CoherentState[(Sqrt[intensity])];

dt = 0.0012;
tf = 1.0;

ℒ = Liouvillian[H,{c}];
ρ0 = out[ψ0,ψ0];

(* Analytical (unconditional) (Subscript[⟨x⟩, t]) *)
ρ = Vec@ρ0;
ℰ = MatrixExp[ℒ dt];
ana = Table[
ρ=ℰ.ρ;
{t,(1/(Sqrt[κ]))Tr[(c+c\[ConjugateTranspose]).Unvec@ρ]},{t,dt,tf,dt}]//Chop;

PrettyTiming[
J=Mean@table[MovingAverage[HomodyneSimulate[ψ0,H,c,dt,tf]["J"],2],{i,800}]
];

Show[
(*ListLinePlot[sim,Filling->Axis,DataRange->{dt,tf}],*)
ListLinePlot[J/(Sqrt[κ]),DataRange->{dt,tf}],
ListLinePlot[ana,PlotStyle->red],
PlotRange->{-7,7}
]

# Corresponding QuTIP code

import numpy as np
import matplotlib.pyplot as plt
import qutip as qt

# parameters
DIM = 20             # Hilbert space dimension
DELTA = 5*2*np.pi    # cavity detuning
KAPPA = 2            # cavity decay rate
INTENSITY = 4        # intensity of initial state
NUMBER_OF_TRAJECTORIES = 500

# operators
a = qt.destroy(DIM)
x = a + a.dag()
H = DELTA*a.dag()* a

rho_0 = qt.coherent(DIM, np.sqrt(INTENSITY))
times = np.arange(0, 1, 0.0025)

stoc_solution = qt.smesolve(H, rho_0, times,
                            c_ops=[],
                            sc_ops=[np.sqrt(KAPPA) * a],
                            e_ops=[x],
                            ntraj=NUMBER_OF_TRAJECTORIES,
                            nsubsteps=2,
                            store_measurement=True,
                            dW_factors=[1],
                            method='homodyne')

fig, ax = plt.subplots()
ax.set_title('Stochastic Master Equation - Homodyne Detection')
ax.plot(times, np.array(stoc_solution.measurement).mean(axis=0)[:].real,
        'r', lw=2, label=r'$J_x$')
ax.plot(times, stoc_solution.expect[0], 'k', lw=2,
        label=r'$\langle x \rangle$')
ax.set_xlabel('Time')
ax.legend()

Reproducing Fig. 4.6 of Wiseman and Milburn

I think there is a typo in that figure. I think (a) is for Φ = π/2 and (b) is for Φ = 0, not the other way around.

γ =1;
Δ = 0;
Ω = 3 γ;
H =(Δ/2)σz+ ((Ω )/2)σy;
c = (Sqrt[γ])σm;
ℒ = Liouvillian[H,{c}];
ψ0 = (1/(Sqrt[2])){1,1};
ρ0 = out[ψ0,ψ0];
dt = 0.01;
tf = 10.0;

simX =HomodyneSimulate[ρ0,H,c ,dt,tf];
simY =HomodyneSimulate[ρ0,H,c (E^(I π/2)),dt,tf];

xave=(Sqrt[γ ])Tr[σx.Unvec[MatrixExp[ℒ t,Vec[ρ0]]]]//cf//Chop;
yave=(Sqrt[γ ])Tr[σy.Unvec[MatrixExp[ℒ t,Vec[ρ0]]]]//cf//Chop;
Plot[{xave,yave},{t,0,tf}]

PhiTheta[sim_]:=Module[{
sx=Chop@Table[Tr[σx.ρ],{ρ,sim["state"]}],
sy=Chop@Table[Tr[σy.ρ],{ρ,sim["state"]}],
sz=Chop@Table[Tr[σz.ρ],{ρ,sim["state"]}]
},
{Table[ArcTan[sx[[i]],sy[[i]]],{i,Length@sx}],ArcCos[#]&/@sz}
]

BlochSpherePlot[sim_]:=Module[{
sx=Chop@Table[Tr[σx.ρ],{ρ,sim["state"]}],
sy=Chop@Table[Tr[σy.ρ],{ρ,sim["state"]}],
sz=Chop@Table[Tr[σz.ρ],{ρ,sim["state"]}]
},
Show[BlochSphere[],
ListLinePlot3D[{sx,sy,sz}\[Transpose],PlotStyle->Black,PlotRange->All,AspectRatio->1],PlotRange->All,AspectRatio->1,ImageSize->270]
]

{ϕx,θx}=PhiTheta[simX];
ListLinePlot[Cos@θx,AspectRatio->1/5,ImageSize->{Automatic,180},FrameLabel->{"γt","cos θ"},ImagePadding->{{60,10},{50,10}}]
ListLinePlot[ϕx,PlotRange->{0,4.5},AspectRatio->1/5,ImageSize->{Automatic,180},FrameLabel->{"γt","ϕ"},ImagePadding->{{60,10},{50,10}}]
BlochSpherePlot[simX]

{ϕy,θy}=PhiTheta[simY];
ListLinePlot[Cos@θy,AspectRatio->1/5,ImageSize->{Automatic,180},FrameLabel->{"γt","cos θ"},ImagePadding->{{60,10},{50,10}}]
ListLinePlot[ϕy,PlotRange->{0,4.5},AspectRatio->1/5,ImageSize->{Automatic,180},FrameLabel->{"γt","ϕ"},ImagePadding->{{60,10},{50,10}}]
BlochSpherePlot[simY]

{ListLinePlot[LowpassFilter[simX,0.1]],ListLinePlot[LowpassFilter[simY,0.1]]}

timeseries = TimeSeries[{range[dt,tf,dt],sim}\[Transpose]]

ListLinePlot[timeseries]

Show[Plot[4xave/(Sqrt[γ]),{t,0,tf},PlotStyle->Red],
ListLinePlot[LowpassFilter[timeseries,5]]]

Two-point function & power spectrum from the stochastic homodyne current

Clear[ω,γ,Ω];
γ =0.7;
Δ = 0;
Ω = 5 γ;
H =(Δ/2)σz+ ((Ω )/2)σy;
c = (Sqrt[γ])σm;
ℒ = Liouvillian[H,{c}];
ℒ = Liouvillian[H,{c}]//cf;
ρ = AnalyticalSteadyState[ℒ];

ψ0 = {1,0};
{𝒮=FCSPowerSpectrumLinearSys[{ω},ρ,ℒ,c,1,"Homodyne"][[1,2]]//cf,
ℱ = FCSTwoPointFunctionMEXP[{τ},ρ,ℒ,c,1,"Homodyne"][[1,2]]//cf};

dt = 0.01;
tf = 4000.0;

sim =HomodyneSimulate[ψ0,H,c ,dt,tf]["J"];

{Plot[𝒮,{ω,-12,12}],Plot[ℱ,{τ,0,12}]}

PrettyTiming[F=TwoPointCorrelation[sim,Round[8/dt],dt,3];]

(* Butterworth filter smooths the 2-point function *)
PrettyTiming[Ffilt=TwoPointCorrelation[butter[sim,50,dt],Round[8/dt],dt,4];]

rasta@Show[
ListLinePlot[{F,Ffilt},PlotStyle->{Directive[Black,Opacity[0.25]],Black}],
Plot[ℱ,{τ,0,9},PlotStyle->red]
]

Grid@PartitionIn[Table[rasta@Show[
ListLinePlot[PowerSpectrum[sim,dt,av],PlotRange->{{-10,10},All}],
Plot[𝒮,{ω,-10,10},PlotStyle->{Red,Thick}],
PlotLabel->"Averaging = " <>ToString@av
],{av,{1,5,10,20,40,80}}],2]

(* Power spectrum using Butterworth filter is no good, because it suppresses the shotnoise frequency *)
rasta@Show[
ListLinePlot[{PowerSpectrum[sim,dt,20],PowerSpectrum[butter[sim,10,dt],dt,10]},PlotRange->{{-10,10},All}],
Plot[𝒮,{ω,-10,10},PlotStyle->{Red,Thick}]
]

(* More detailed simulations with 10x more points *)

sim2 =HomodyneSimulate[ρ,H,c ,dt,10tf]["J"];

Show[
ListLinePlot[PowerSpectrum[sim2,dt,500],PlotRange->{{-10,10},{0.9,2.5}}],
Plot[𝒮,{ω,-10,10},PlotStyle->{Red,Thick},PlotRange->{{-10,10},{0.9,2.5}}]
]

Markov order 1 Gaussian stationary process

Clear[Markov1Gaussian];
Markov1Gaussian[L_,μ_,σ_,ρ_]:=Module[{Σ,Q,Z},
Σ =(σ^2) SparseArray[{
{i_,i_}->1,
{i_,j_}/;i!=j->(ρ^(Abs[i-j]))},{L,L}];

(*Σ=γ0 Eye[L] + γ1 toeplitzMatrix[1,2,L];*)
Q = CholeskyDecomposition[Σ]\[Transpose];
Z = RandomVariate[NormalDistribution[],L];
Q.Z + μ
]

Markov1Gaussian[5,1.,0.2,0.1]

Non-interacting systems (covariance matrix, Lyapunov, &c.)

Non-interacting systems (Lyapunov etc.)

LyapunovEigen: solves the Lyapunov equation using eigen-decomposition

This function solves WC + CW†=F using eigendecomposition of W. 
Apparently this turns out to be faster than “LyapunovSolve[W,F]”. 
I believe this is related to the fact that in Lindblad dynamics, F is usually quite sparse.

Clear[LyapunovEigen]
LyapunovEigen[W_,F_]:=Module[{ℐ,Λ,S,Sinv},
{Λ,S}=Quiet@Eigensystem[W];
S = S\[Transpose];
Sinv = Inverse[S];

ℐ = (1/(Outer[Plus,Λ,Λ\[Conjugate]])) Sinv.F.Sinv\[ConjugateTranspose];
S.ℐ.S\[ConjugateTranspose]//Chop
];

Example usage

NESS of an Aubry-Andre quantum spin chain. 
Localization transition occurs at λ = 1

Clear[h,H,Γ,W,F];
λ = 0.5;
γ = 1;
f1 = 0.9;
fL = 0.1;
L = 5;

h[n_]:=λ Cos[ 2π GoldenRatio n ];

Γ = SparseArray[{{1,1}->γ,{L,L}->γ},{L,L}];
H = SparseArray[{{i_,i_}->2h[i],{i_,j_}/;j==i+1->-1,{i_,j_}/;j==i-1->-1},{L,L}];
W = I H-Γ;

F= SparseArray[{{1,1}->γ f1,{L,L}->γ fL},{L,L}];

LyapunovEigen[W,F]//Chop//mf;

LyapunovDriven: time-dependent Lyapunov dynamics

Solves (dC/dt)= -((Subscript[W, t])C + C (Subscript[W, t]^†)) + (Subscript[F, t]).

W and F can either be (matrix-valued) functions (W(t), F(t)) or matrices.

LyapunovDriven[W_,F_,𝒞0_,Δt_,tf_,sparse_:1]:=Module[{f,testW,testF},
(* Check if input is a function or a matrix *)
testW = Head[W] ===Symbol || Head[W] ===Function;
testF = Head[F] ===Symbol || Head[F] ===Function;

Which[
testW&&testF,
f[t_,𝒞_]:=-W[t].𝒞-𝒞.W[t]\[ConjugateTranspose]+F[t],
testW && Not[testF],
f[t_,𝒞_]:=-W[t].𝒞-𝒞.W[t]\[ConjugateTranspose]+F,
Not[testW] && testF,
f[t_,𝒞_]:=-W.𝒞-𝒞.W\[ConjugateTranspose]+F[t],
True,
f[t_,𝒞_]:=-W.𝒞-𝒞.W\[ConjugateTranspose]+F
];
RK4t[f,𝒞0,Δt,tf][[1;;-1;;sparse]]
]

Example usage

Double quantum dot + Local Lindblad + Periodic drive on dot 2. 
Recall that 

W = i h + (Γ/2)

We first create the undriven matrices, and then add a drive to the unitary (complex) part of W:

(* Undriven matrices *)
{W,F}=BDMatrices[1,2,0.1,{0.2,0.5}];
𝒲[t_]:=W +3 (({{0, 0}, {0, I}}))Cos[t];

𝒞0 = (({{0, 0}, {0, 1}}));

(* We pass to the function a matrix F, and the function 𝒲 *)
res=LyapunovDriven[W +3 (({{0, 0}, {0, I}}))Cos[#]&,F,𝒞0,0.005,50,10];

(* Plot the populations *)
ListLinePlot[{
{res[[All,1]],res[[All,2,1,1]]}\[Transpose],
{res[[All,1]],res[[All,2,2,2]]}\[Transpose]},
PlotRange->All
]

BD: Boundary-driven chains (fermions & bosons)

Clear[BDMatrices]
BDMatrices[h_,γ_,f_]:=Module[{L=Length@h,Γ,F0},
Γ =If[Length@γ===Length@h, SparseArray@DiagonalMatrix@γ,SparseArray[{{1,1}->γ,{L,L}->γ},{L,L}]];
F0 =Which[
Length@f===Length@h, SparseArray@DiagonalMatrix@f ,
Length@f === 2,SparseArray[{{1,1}-> f[[1]],{L,L}-> f[[2]]},{L,L}],
True,f Eye[L]
];
{I h + (Γ/2), Γ F0}
]

BDMatrices[V_,L_,γ_,f_]:=Module[{Γ,A,W,F,g,h,i}, 
BDMatrices[TightBindingHamiltonian[L,V], γ,f]
];

Clear[BDCovMat];
BDCovMat[W_,F_]:=LyapunovEigen[W,F]
BDCovMat[h_,γ_,{f1_,fL_}]:=LyapunovEigen@@BDMatrices[h,γ,{f1,fL}];
BDCovMat[V_,L_,γ_,{f1_,fL_}]:=LyapunovEigen@@BDMatrices[V,L,γ,{f1,fL}]

(* Only holds for nearest-neighbor tight-binding models *)
Clear[BDCurrent];
BDCurrent[𝒞_]:=(*Im@𝒞[[2,1]]*) -I (𝒞[[2,1]]-𝒞[[1,2]])//Chop;
BDCurrent[W_,F_]:=BDCurrent[LyapunovEigen[W,F]]
BDCurrent[h_,γ_,{f1_,fL_}]:=BDCurrent[LyapunovEigen@@BDMatrices[h,γ,{f1,fL}]];
BDCurrent[V_,L_,γ_,{f1_,fL_}]:=BDCurrent[LyapunovEigen@@BDMatrices[V,L,γ,{f1,fL}]];

Example usage

h = TightBindingHamiltonian[4,1]//mf;

MatrixForm/@BDMatrices[h,{γ1,γ2,γ3,γ4},{f1,f2,f3,f4}]

MatrixForm/@BDMatrices[h,γ1,{f1,f2,f3,f4}]

MatrixForm/@BDMatrices[h,γ1,{f1,f4}]

MatrixForm/@BDMatrices[1,5,γ1,{f1,f5}]

{W,F}=BDMatrices[ϵ,4,γ,{f1,fL}];
mf@W;
mf@F;

{W,F}=BDMatrices[1,4,0.1,{0.3,0.7}];
mf@W;
mf@F;

BDMatrices[1,7,1,{1/2,0.3}]

LyapunovEigen@@BDMatrices[1.,7,1,{1/2,0.3}]

LyapunovEigen@@{W,F}

LyapunovEigen[W,F]//mf;

CovMatCurrent[W,F]

{W,F}=BDMatrices[{ϵ1,ϵ2,ϵ3,ϵ4},4,γ,{f1,fL}];
mf@W;
mf@F;

{W,F}=BDMatrices[RandomReal[{0,1},{4,4}],γ,{f1,fL}];
mf@W;
mf@F;

CovMatCurrent[1.,87,1,{0.2,0.3}]

BDCovMat[1.0,10,1,{0.2,0.3}]//mf;

(* Aubry-André model *)

g = GoldenRatio;
V[n_]:=λ ((Cos[ 2π g n + ϕ])/(1-α Cos[2π g n + ϕ]));

Example: quantum transport in the Fibonnacci model (based arXiv 2106.11406)

The Fibonnacci model is quite incredible because, even though it is a non-interacting chain, it can show any kind of transport coefficient.

(* Takes a couple of minutes to run *)
Clear[L,λ];
λrange = range[0,7,0.1];
Lrange ={8,13,21,34,55,89,144,233,377,610,987};
sims = Association[];

Monitor[Do[
Clear[V];
V = N@Table[IntegerPart[((i+1)/(GoldenRatio^2))]-IntegerPart[(i/(GoldenRatio^2))],{i,1,L}];
sims[{λ,L}]=BDCurrent[λ V,L,1,{1,0}];
,{λ,λrange},{L,Lrange}],{λ,L}]

fits = Association[];
Do[
fits[λ] = Fit[Table[{Log10@L,Log10@sims[{λ,L}]},{L,Lrange}],{1,x},x];
,{λ,λrange}]

Show[
ListLogLogPlot[Table[{L,sims[{λ,L}]},{λ,range[0,5,1.]},{L,Lrange}],Joined->False,PlotMarkers->Automatic,
AspectRatio->1,
PlotStyle->Drop[ColorData[3,"ColorList"],3]
],
LogLogPlot[Evaluate@Table[10^(fits[λ]/.x->Log10[y]),{λ,range[0,5,1.]}],{y,0.1,(10^3)},
PlotStyle->Drop[ColorData[3,"ColorList"],3],
PlotLegends->legend[Round@range[0,5,1.],{0.29,0.12},LegendLayout->{"Row",2}]],
FrameLabel->{"L","J"}
]

ListLinePlot[Table[{λ,-fits[λ][[2,1]]},{λ,λrange}],PlotMarkers->Automatic,
GridLines->{None,{1}},
GridLinesStyle->Directive[Black, Dashed]]

Fermionic chains with pairing terms

Implements the master equation 

((dρ)/dt) = -i [H,ρ] + (∑_( i)) (Subscript[γ, i]^(-)) D[(Subscript[c, i])] + (Subscript[γ, i]^(+))D[(Subscript[c, i]^†)]

with 

H = (∑_( n,m)) (Subscript[h, nm])(Subscript[c, n]^†)(Subscript[c, m]) + (1/2)((Subscript[G, nm])(Subscript[c, n]^†)(Subscript[c, m]^†)+ (Subscript[G, mn]^( * )) (Subscript[c, n])(Subscript[c, m]))  = (1/4) Γ† 𝒯 Γ + (1/2)tr(h)

where (Subscript[Γ, i ])= (Subscript[c, i]^†)+(Subscript[c, i]) and (Subscript[Γ, L+i]) = i((Subscript[c, i]^†)-(Subscript[c, i])) are majorana operators and 

𝒯=(Subscript[σ, z]) ⊗ (((G+G†))/2)   -  (Subscript[σ, y])⊗ h -(Subscript[σ, x])⊗ i(((G-G†)/2)) =(({{((G+G†)/2), i h - (i/2)(G-G†)}, {-i h - (i/2)(G-G†), -(((G+G†)/2))}}))  

The covariance matrix Θ = (1/2)⟨[(Subscript[Γ, i,])(Subscript[Γ, j])]⟩ satisfies the Lyapunov equation 

((dΘ)/dt) = -(𝒲Θ+Θ𝒲†) +ℱ

where 

𝒲 = i 𝒯 + Υ + Υᵀ   and  ℱ = - 2(Υ-Υᵀ)   and   Υ = (1/4)(({{(SubPlus[γ])+(SubMinus[γ]), i((SubPlus[γ])-(SubMinus[γ]))}, {-i((SubPlus[γ])-(SubMinus[γ])), (SubPlus[γ])+(SubMinus[γ])}}))

Clear[BDPairingMatrices];
BDPairingMatrices[𝒯_,γ_,f_]:=Module[{L,W,γm,γp,Υ,𝒲,ℱ},

L=Length[𝒯]/2;
{W,γp} = BDMatrices[Eye[L],γ,f];
γm = W+W\[ConjugateTranspose]-γp;

Υ = (1/4)ArrayFlatten[(({{γp+γm, I(γp-γm)}, {-I (γp-γm), γp+γm}}))];
𝒲 = I 𝒯 + Υ+Υ\[Transpose];
ℱ = - 2(Υ-Υ\[Transpose]);
{𝒲,ℱ}
]

BDPairingMatrices[h_,G_,γ_,f_]:=BDPairingMatrices[MajoranaHamiltonian[h,G],γ,f]

(* XY chain, with z-field h0 and anisotropy κ *)
BDPairingMatrices[L_,h0_,κ_,γ_,f_]:=Module[{Δ},
Δ=h0 Eye[L]+ SparseArray[{Band[{1,2}]->((1-κ)/2)(*Jy*),Band[{2,1}]->((1+κ)/2)(*Jx*)},{L,L}] ;
 BDPairingMatrices[I ArrayFlatten[(({{0, -Δ}, {Δ\[ConjugateTranspose], 0}}))],γ,f]
]

Clear[BDPairingCovMat];
BDPairingCovMat[𝒲_,ℱ_]:=LyapunovEigen[𝒲,ℱ]
BDPairingCovMat[𝒯_,γ_,f_]:=LyapunovEigen@@BDPairingMatrices[𝒯,γ,f];
BDPairingCovMat[h_,G_,γ_,f_]:=LyapunovEigen@@BDPairingMatrices[h,G,γ,f];
BDPairingCovMat[L_,h0_,κ_,γ_,f_]:=LyapunovEigen@@BDPairingMatrices[L,h0,κ,γ,f];

BDPairingCurrent[Θ_,γ_,f_]:=Module[{γγ = First@Flatten@{γ},ff=First@Flatten@{f}},
{First@Flatten@{γ} (First@Flatten@{f}-FermionsReducedC[Θ][[1,1]]),
Last@Flatten@{γ} (Last@Flatten@{f}-FermionsReducedC[Θ][[-1,-1]])}//Chop
]

Sanity check: no-pairing case

{𝒲,ℱ} = BDPairingMatrices[TightBindingHamiltonian[10],0.0,0.1,{0.3,0.4}];
Θ =BDPairingCovMat[𝒲,ℱ];
FermionsReducedC@Θ//mf;

Θ = BDPairingCovMat[TightBindingHamiltonian[10],0.0,0.1,{0.3,0.4}];
FermionsReducedC@Θ//mf;
BDPairingCurrent[Θ,0.1,{0.3,0.4}]
BDPairingCurrent2[Θ,0.1,{0.3,0.4}]

BDCovMat[TightBindingHamiltonian[10],0.1,{0.3,0.4}]//mf;
BDCurrent[TightBindingHamiltonian[10],0.1,{0.3,0.4}]

Ex: Non-equilibrium transition in the XY chain

Based on arXiv 0805.2878. 
The boundary-driven XY chain has a transition at (Subscript[h, c])=1-(κ^2)

Below we plot the reduced covariance matrix (Subscript[C, ij])=⟨(Subscript[c, j]^†)(Subscript[c, i])⟩ for L = 100, below and above the transition.

Row@{rasta@MatrixPlot@Re@FermionsReducedC@BDPairingCovMat[100,0.7,κ = 0.5,γ = 1.0,{f1 = 0.3,fL = 0.4}],rasta@MatrixPlot@Re@FermionsReducedC@BDPairingCovMat[100,0.8,κ,γ,{f1,fL}]}

(* The transition is more strongly present in the coherences. The populations don't differ that much from one phase to another *)
ListLinePlot[
{Diagonal@FermionsReducedC@BDPairingCovMat[100,0.7,κ = 0.5,γ = 1.0,{f1 = 0.3,fL = 0.4}],
Diagonal@FermionsReducedC@BDPairingCovMat[100,0.8,κ,γ,{f1,fL}]}]

Bosonic chains with squeezing terms (to-do)

Dephasing

Clear[DephasingSolve];
DephasingSolve[W_,F_,Γ_]:=Module[{L = Length@W,vecW,vecRemoveDiag,vecF},
vecW = kron[W\[Conjugate],NEye[L]]+kron[NEye[L],W];
vecRemoveDiag = SparseArray[{i_,i_}/;Last@QuotientRemainder[i,L+1]≠1->1,{(L^2),(L^2)}];

LinearSolve[vecW + Γ vecRemoveDiag, Vec[F]]//Unvec//Chop
]

Clear[BDCovMatDephasing];
BDCovMatDephasing[W_,F_,Γ_]:=DephasingSolve[W,F,Γ];
BDCovMatDephasing[h_,γ_,{f1_,fL_},Γ_]:=Module[{W,F} ,
{W,F} = BDMatrices[h,γ,{f1,fL}];
DephasingSolve[W,F,Γ]
];
BDCovMatDephasing[V_,L_,γ_,{f1_,fL_},Γ_]:=Module[{W,F} ,
{W,F} = BDMatrices[V,L,γ,{f1,fL}];
DephasingSolve[W,F,Γ]
];

(* Only holds for nearest-neighbor tight-binding models *)
Clear[BDCurrentDephasing];
BDCurrentDephasing[𝒞_]:=(*Im@𝒞[[2,1]]*) -I (𝒞[[2,1]]-𝒞[[1,2]])//Chop;
BDCurrentDephasing[W_,F_,Γ_]:=BDCurrentDephasing[BDCovMatDephasing[W,F,Γ]]
BDCurrentDephasing[h_,γ_,{f1_,fL_},Γ_]:=BDCurrentDephasing[BDCovMatDephasing[h,γ,{f1,fL},Γ]];
BDCurrentDephasing[V_,L_,γ_,{f1_,fL_},Γ_]:=BDCurrentDephasing[BDCovMatDephasing[V,L,γ,{f1,fL},Γ]];

QuotientRemainder logic

This vectorized superoperator removes the diagonal of a matrix

L=4;
tmp=SparseArray[{i_,i_}/;Last@QuotientRemainder[i,L+1]≠1->1,{(L^2),(L^2)}]/.L->10//mf;

tmp.Vec@Table[(Subscript[a, i,j]),{i,L},{j,L}]//Unvec//mf;

Example: noise-assisted transport in a Fibonnacci subdiffusive chain (arXiv 2106.11406)

Define a tight-binding model with Fibonnacci on-site potentials

L = 100;
V = N@Table[IntegerPart[((i+1)/(GoldenRatio^2))]-IntegerPart[(i/(GoldenRatio^2))],{i,1,L}];
BDCurrent[V,L,1,{1,0}]

BDCurrentDephasing[V,L,1,{1,0},0.0]

Γrange = logspace[-3,2,30];
L = 500;
V = N@Table[IntegerPart[((i+1)/(GoldenRatio^2))]-IntegerPart[(i/(GoldenRatio^2))],{i,1,L}];
results = Table[{Γ,BDCurrentDephasing[4 V,L,1,{1,0},Γ]},{Γ,Γrange}]

ListLogLinearPlot[results,Joined->True,PlotMarkers->Automatic]

Quantum information with Covariance Matrices

Get ρ from Cov Mat 𝒞

Given a bosonic or fermionic covariance matrix (Subscript[𝒞, ij])= ⟨(Subscript[c, j]^†)(Subscript[c, i])⟩, returns a pair (M,Z) which can be used to reconstruct the state as ρ=(e^(-c†.M.c)) /Z

Clear[CovMatRhoFromC];
CovMatRhoFromC[𝒞_,statistic_:"Fermions"]:=Module[{𝕀 = Eye[Length@𝒞],λ,V,Z,M},
{λ,V} = Eigsys[𝒞];
If[matchString["Fermions", statistic],
Z = 1/Det[𝕀-𝒞];
M=V.DiagonalMatrix[Log[((1-λ)/λ)]].V\[ConjugateTranspose];
,
Z = Det[𝕀+𝒞];
M=V.DiagonalMatrix[Log[((1+λ)/λ)]].V\[ConjugateTranspose];
];
{M,Z}//Chop
]

Example usage

Covariance matrix obtained from a boundary-driven problem with 3 sites

𝒞=BDCovMat[1,3,0.1,{0.8,0.2}]//mf;

Reconstruct the full quantum state in the case of Fermions

{M,Z} = RhoFromC[𝒞,"fermions"]

LoadFermionicOperators[L = Length@𝒞];
ρ = (1/Z)MatrixExp[-Sum[M[[i,j]] cd[i].c[j],{i,L},{j,L}]]//mf;

Check that this gives back the correct covariance matrix

𝒞2 = Table[Tr[cd[j].c[i].ρ],{i,L},{j,L}];
𝒞-𝒞2//mf;

Von Neumann and Rényi entropy

Considers a bosonic or fermionic system with covariance matrix (Subscript[𝒞, ij])= ⟨(Subscript[c, j]^†)(Subscript[c, i])⟩.
Computes vonNeumann or Rényi entropy.

Clear[CovMatEntropy];
CovMatEntropy[𝒞_,α_:1,statistic_:"Fermions"]:=Module[{𝕀 = Eye[Length@𝒞],Z,M,λ,V},
{λ,V} = Eigsys[𝒞];
If[matchString["Fermions", statistic],
Z = 1/Det[𝕀-𝒞];
M=V.DiagonalMatrix[Log[((1-λ)/λ)]].V\[ConjugateTranspose];
,
Z = Det[𝕀+𝒞];
M=V.DiagonalMatrix[Log[((1+λ)/λ)]].V\[ConjugateTranspose];
];
Chop@If[Abs[α-1]<(10^(-12)),
Log[Z] + Tr[M.𝒞],
((-α)/(1-α))Log[Z] + (1/(1-α))If[matchString["Fermions", statistic],
Total@Log[1+(((((1-λ)/λ)))^(-α))],-Total@Log[1-(((((1+λ)/λ)))^(-α))]]]
]

Example usage

Covariance matrix obtained from a boundary-driven problem with 3 sites

𝒞=BDCovMat[1,3,0.1,{0.8,0.2}]//mf;

Reconstruct the full quantum state in the case of Fermions

{M,Z} = RhoFromC[𝒞,"fermions"];
LoadFermionicOperators[L = Length@𝒞];
ρ = (1/Z)MatrixExp[-Sum[M[[i,j]] cd[i].c[j],{i,L},{j,L}]];

Compute the von Neumann entropy

vonNeumann[ρ]
CovMatEntropy[𝒞]

Compute Rényi entropies

{Renyi[ρ,0.5],CovMatEntropy[𝒞,0.5]}
{Renyi[ρ,1.5],CovMatEntropy[𝒞,1.5]}

Relative entropy (von Neumann & Rényi)

Clear[CovMatRelativeEntropy];
CovMatRelativeEntropy[𝒞1_,𝒞2_,α_:1,statistic_:"Fermions"]:=Module[{𝕀 = Eye[Length@𝒞1],Z1,M1,λ1,V1,Z2,M2,λ2,V2,s,ζ,ξ},
{λ1,V1} = Eigsys[𝒞1];
{λ2,V2} = Eigsys[𝒞2];
If[matchString["Fermions", statistic],
Z1 = 1/Det[𝕀-𝒞1];
M1=V1.DiagonalMatrix[Log[((1-λ1)/(λ1))]].V1\[ConjugateTranspose];
Z2 = 1/Det[𝕀-𝒞2];
M2=V2.DiagonalMatrix[Log[((1-λ2)/(λ2))]].V2\[ConjugateTranspose]; 
,
Z1 = Det[𝕀+𝒞1];
M1=V1.DiagonalMatrix[Log[((1+λ1)/(λ1))]].V1\[ConjugateTranspose];
Z2 = Det[𝕀+𝒞2];
M2=V2.DiagonalMatrix[Log[((1+λ2)/(λ2))]].V2\[ConjugateTranspose]; 
];
s = If[matchString["Fermions", statistic],1,-1];

Chop@If[Abs[α-1]<(10^(-12)),
-(Log[Z1] + Tr[M1.𝒞1]) + Log[Z2] + Tr[M2.𝒞1]
,
ζ = DiagonalMatrix[(((((λ2)/(1-s λ2))))^((1-α)/(2α)))].V2\[ConjugateTranspose].V1.DiagonalMatrix[(((λ1)/(1-s λ1)))].V1\[ConjugateTranspose].V2.DiagonalMatrix[(((((λ2)/(1-s λ2))))^((1-α)/(2α)))]; 
ξ = Eigvals[ζ];
Log[Z2]+(α/(1-α))Log[Z1] - (1/(1-α))s Total@Log[1+s (ξ^α)]
]
]

Example usage

Covariance matrix obtained from a boundary-driven problem with 3 sites

𝒞=BDCovMat[1,3,0.1,{0.8,0.2}]//mf;

Change some parameter to obtain a new covariance matrix

𝒞2=BDCovMat[1,3,0.2,{0.8,0.2}]//mf;

{M2,Z2} = RhoFromC[𝒞2,"fermions"];
ρ2 = (1/Z2)MatrixExp[-Sum[M2[[i,j]] cd[i].c[j],{i,L},{j,L}]];

Compute relative entropy

KullbackLeibler[ρ,ρ2]
CovMatRelativeEntropy[𝒞,𝒞2]

Compute Rényi divergences

{RenyiDivergence[ρ,ρ2,0.5],CovMatRelativeEntropy[𝒞,𝒞2,0.5]}
{RenyiDivergence[ρ,ρ2,1.5],CovMatRelativeEntropy[𝒞,𝒞2,1.5]}

Mesoscopic leads (“thermleads”)

Reaction coordinates  & star-to-chain mapping

Clear[ReactionCoordinateMappingNumerics];
ReactionCoordinateMappingNumerics[Js_,ωs_]:=Module[{Λ1,Ω1,P,ω,ωmin,ωmax,dω,Jnew},

ωmin = First@ωs;
ωmax = Last@ωs;
dω = ωs[[2]]-ωs[[1]];

Λ1 = (Sqrt[(1/(2π))Trapz[Js,dω]]);
Ω1 = (1/(2π ((Λ1)^2)))Trapz[ωs Js,dω];

P = (1/π)Table[Trapz[((Drop[Js,{i}])/(Drop[ωs-ωs[[i]],{i}])),dω],{i,Length@ωs}]; 
Jnew = ((4 ((Λ1)^2)Js)/((P^2)+(Js^2)));
{Λ1,Ω1,Jnew}
]

StarToChainMapping[𝒥s_,ωs_,Lb_]:=Module[{Λ1,Ω1,P,ω,ωmin,ωmax,dω,Jnew,Js},

ωmin = First@ωs;
ωmax = Last@ωs;
dω = ωs[[2]]-ωs[[1]];
Js=𝒥s;
Table[
Λ1 = (Sqrt[(1/(2π))Trapz[Js,dω]]);
Ω1 = (1/(2π ((Λ1)^2)))Trapz[ωs Js,dω];

P = (1/π)Table[Trapz[((Drop[Js,{i}])/(Drop[ωs-ωs[[i]],{i}])),dω],{i,Length@ωs}]; 
Js = ((4 ((Λ1)^2)Js)/((P^2)+(Js^2)));
{((Λ1)^2),Ω1}
,{Lb}]
]

Example usage

(* Boxcar *)
γ = 0.3;
δ =1.0;
ϵ = 0.3;
ωs = linspace[ϵ-δ,ϵ+δ,999];
Js = Table[γ Boxcar[ϵ-δ,ϵ+δ][ω],{ω,ωs}];

{Λ1,Ω1,Jnew}=ReactionCoordinateMappingNumerics[Js,ωs];

{((Λ1)^2),Ω1}
{((γ δ)/π),ϵ}

Show[
ListLinePlot[{ωs,Jnew}\[Transpose],PlotRange->All],
Plot[((4 π δ)/((π^2)+4 ((ArcTanh[((ϵ-ω)/δ)])^2))),{ω,ϵ-δ,ϵ+δ},PlotStyle->Directive[Red,Dotted]]
]

Show[
ListLinePlot[{ωs,Jnew}\[Transpose],PlotRange->All],
Plot[((δ(((2δ))^2))/((((ω-ϵ))^2)+(((2δ))^2))),{ω,-20,20},PlotStyle->Directive[Red,Dotted]]
]

(* Quadratic Lorentzian. Bit weird *)
γ = 0.3;
δ =1.0;
ϵ = 0.2;
ωs = linspace[-20,20,1000];
Js = Table[((γ (δ^2))/((((ω-ϵ))^2)+(δ^2))),{ω,ωs}];

{Λ1,Ω1,Jnew}=ReactionCoordinateMappingNumerics[Js,ωs];

{((Λ1)^2),Ω1}
{((γ δ)/2),ϵ}

Show[
ListLinePlot[{ωs,Jnew}\[Transpose],PlotRange->All],
Plot[2δ,{ω,-30,30},PlotStyle->Red],
PlotRange->{{-20,20},All}
]

Star-to-chain

(* Quartic Lorentzian *)
γ = 0.3;
δ =1.0;
ϵ = 0.2;
ωs = linspace[-4,4,1000];
Js = Table[((γ (δ^4))/((((((ω-ϵ))^2)+(δ^2)))^2)),{ω,ωs}];

StarToChainMapping[Js,ωs,50]

Thermleads: Mesoscopic leads approach for non-interacting fermion dynamics

Based on https://journals.aps.org/prx/pdf/10.1103/PhysRevX.10.031040

LeadSamples[L_,W_,Wstar_,Γ_]:=Module[{Llog,Llin,logsamp,samples,energies,spacings,gamma,couplings},
Llog = Round[0.2 L];
Llin=L -2 Round[0.2 L];
logsamp = logspace[Log10[Wstar],Log10[W],Llog+1];
samples=Join[
Most@Reverse[-logsamp],
linspace[-Wstar,Wstar,Llin+1],
Rest@logsamp];

(*samples = linspace[-W,W,L+1];*)
energies = (Most@samples+Rest@samples)/2;
spacings = Differences[samples];
gamma = spacings;
couplings = (Sqrt[Γ spacings/(2π)]);
{energies,couplings,gamma}
];

LeadSamplesLinear[L_,W_,Wstar_,Γ_]:=Module[{Llog,Llin,logsamp,samples,energies,spacings,gamma,couplings},
samples = linspace[-W,W,L+1];
energies = (Most@samples+Rest@samples)/2;
spacings = Differences[samples];
gamma = spacings;
couplings = (Sqrt[Γ spacings/(2π)]);
{energies,couplings,gamma}
];

Clear[BDThermLeadMatrices];
BDThermLeadMatrices[h_,Γ_,{TL_,TR_,μL_,μR_},Lb_,w_,disc_:"linlog"]:=Module[{energies,couplings,gamma,Ls=Length@h,HB1,HB2,VS1,VS2,H,W,F,Fermis,ws=w/2},
Which[
disc==="linlog",
{energies,couplings,gamma}=LeadSamples[Lb,w,ws,Γ],
disc==="lin",
{energies,couplings,gamma}=LeadSamplesLinear[Lb,w,ws,Γ]
];

HB1 = DiagonalMatrix[energies];
HB2 = HB1;

VS1=Sum[couplings[[n]] Proj[{Lb,Ls},n,1],{n,Length@couplings}];
VS2=Sum[couplings[[n]] Proj[{Ls,Lb},Ls,n],{n,Length@couplings}];

H=ArrayFlatten[(({{HB1, VS1, 0}, {VS1\[ConjugateTranspose], h, VS2}, {0, VS2\[ConjugateTranspose], HB2}}))]; 
Fermis[T_,μ_,energies_]:=(1/(Exp[(energies-μ)/T]+1)) ;

W = I H + (1/2)DiagonalMatrix@Join[gamma,ConstantArray[0,Ls],gamma];

F = DiagonalMatrix@Join[Fermis[TL,μL,energies]gamma,ConstantArray[0,Ls],Fermis[TR,μR,energies]gamma];

{W,F}
]

Clear[ThermleadsGetSysCM];
ThermleadsGetSysCM[𝒞_,Lb_]:=Module[{Ls = Length@𝒞-2Lb},𝒞[[Lb+1;;Lb+Ls,Lb+1;;Lb+Ls]]]

Clear[ThermleadsDecomposeW];
ThermleadsDecomposeW[W_,Lb_,bath_]:=Module[{Λ,γ,ϵ,Ls = Length@W-2Lb,rg},
rg = If[bath==="left",1;;Lb,Lb+Ls+1;;Ls+2Lb];
γ = Diagonal[(W+W\[ConjugateTranspose])][[rg]];
ϵ = Im[Diagonal@W][[rg]];
Λ = If[bath=="left",Im@W[[Lb+1,rg]],Im@W[[Lb+Ls,rg]]];
{γ,ϵ,Λ}//Chop
]

(*Clear[ThermleadsDecomposeWF];
ThermleadsDecomposeWF[W_,F_,Lb_,bath_]:=Module[{γ,ϵ,Λ,f},

{γ,ϵ,Λ}=ThermleadsDecomposeW[W,Lb,bath];
f = Which[
bath=="left",Diagonal[F][[1;;Lb]]/γ,
bath=="right",Diagonal[F][[Lb+Ls+1;;-1]]/γ];
{γ,ϵ,Λ,f}
]*)

Clear[ThermleadsParticleCurrent];
ThermleadsParticleCurrent[𝒞_,W_,F_,Lb_,bath_:"left"]:=Module[{Ls = Length@𝒞-2Lb,γ,rg},
rg = If[bath==="left",
1;;Lb,
Lb+Ls+1;;Lb+Ls+Lb];

γ = (W+W\[ConjugateTranspose])[[rg,rg]];
Tr[F[[rg,rg]]-γ.𝒞[[rg,rg]]]//Chop
]

Clear[ThermleadsEnergyCurrent];
ThermleadsEnergyCurrent[𝒞_,W_,F_,Lb_,bath_:"left"]:=Module[{Ls = Length@𝒞-2Lb,γ,ϵ,Λ,JEprx,JEartur,Ω,Jnaive,Jfcs,term1,term2,term3,rg,JEarturRight,JEprxRight},
rg = If[bath==="left",
1;;Lb,
Lb+Ls+1;;Lb+Ls+Lb];

γ = (W+W\[ConjugateTranspose]);
ϵ=DiagonalMatrix[Im[Diagonal@W]];

If[bath==="left",
(Λ = SparseArray[{{Lb+1,j_}/;1<=j<=Lb:>Im@W[[Lb+1,j]] γ[[j,j]]},{Lb+Ls+Lb,Lb+Ls+Lb}];
Ω = SparseArray[{{Lb+1,j_}/;1<=j<=Lb:>Im@W[[Lb+1,j]] ϵ[[j,j]]},{Lb+Ls+Lb,Lb+Ls+Lb}];
),(
Λ = SparseArray[{{Lb+Ls,j_}/;rg[[1]]<=j<=rg[[2]]:>Im@W[[Lb+Ls,j]] γ[[j,j]]},{Lb+Ls+Lb,Lb+Ls+Lb}];
Ω = SparseArray[{{Lb+Ls,j_}/;rg[[1]]<=j<=rg[[2]]:>Im@W[[Lb+Ls,j]] ϵ[[j,j]]},{Lb+Ls+Lb,Lb+Ls+Lb}];
)];

Λ=Λ+Λ\[ConjugateTranspose];
Ω=Ω-Ω\[ConjugateTranspose];
(* Relevant terms *)
(* tr((Subscript[H, L])ℒ(ρ)) *)
term1 = Tr[ϵ[[rg,rg]].(F[[rg,rg]]-γ[[rg,rg]].𝒞[[rg,rg]])]//Chop;

(* tr((Subscript[V, SL])ℒ(ρ)) *)
term2 = -(1/2)Tr[Λ.𝒞]//Chop;

(* i ⟨[(Subscript[H, L]),(Subscript[V, SL])]⟩ *)
term3 = -I Tr[Ω.𝒞]//Chop;


(* Energy current in Marlon's PRX *)
(* tr((Subscript[H, L])ℒ(ρ)) + tr((Subscript[V, SL])ℒ(ρ)) *)
JEprx = term1+term2;

(* Change in energy of the bath (Artur's paper) *)
(* Meant to be the "correct" one; equal to JEprx in steady-state. *)
(* i ⟨[(Subscript[H, L]),(Subscript[V, SL])]⟩ + tr((Subscript[V, SL])ℒ(ρ)) *)
JEartur = term3+term2;

{{JEprx,JEartur},{term1,term2,term3}}
]

Example usage

h = TightBindingHamiltonian[3,1]//mf;
{W,F}=BDThermLeadMatrices[h,1,{0.5,0.4,0,0},Lb=10,8];

W//Abs//MatrixPlot

{W,F}=BDThermLeadMatrices[h,1,{0.5,0.4,0,0},Lb=150,8];
C1=ThermleadsGetSysCM[BDCovMat[W,F],Lb]//mf;

(* Compare with the exact solution using NEGF *)
C2=NEGFCovMat[h,1,{0.5,0.4,0,0}]//mf;
C1-C2//mf;

tab=Table[
{W,F}=BDThermLeadMatrices[h,1,{0.5,0.4,0,0},Lb,16];
C1=ThermleadsGetSysCM[BDCovMat[W,F],Lb];
{Lb,Norm[C1-C2]},{Lb,10,500,30}]

ListLogPlot[tab,PlotMarkers->Automatic,FrameLabel->{"(Subscript[L, B])","|(Subscript[C, TL]) - (Subscript[C, NEGF])|"},PlotRange->All,Joined->True,
PlotLabel->"Convergence of thermleads"
]

tab=Table[
{W,F}=BDThermLeadMatrices[h,1,{0.5,0.4,0,0},Lb,Wmax];
C1=ThermleadsGetSysCM[BDCovMat[W,F],Lb];
{Wmax,Norm[C1-C2]},{Lb,{150,300,450}},{Wmax,4,30,2}];

ListLogPlot[tab,PlotMarkers->Automatic,FrameLabel->{"(Subscript[W, max])","|(Subscript[C, TL]) - (Subscript[C, NEGF])|"},PlotRange->All,Joined->True,
PlotLabel->"Convergence of thermleads",
PlotLegends->legend[{"(Subscript[L, B])=500","(Subscript[L, B])=300","(Subscript[L, B])=450"},{0.35,0.75}],
ImageSize->400
]

Particle current in a double quantum dot: comparison with Landauer-Büttiker

T = 100;
γ = 1.0;
eV = 100; 
μL = eV/2;
μR = -eV/2;
gs = linspace[0.001,4,10];
Clear[LB,Meso,g,𝒯];
𝒯[g_,γ_,ϵ_:0]:=NEGFTransmissionFunction[(({{ϵ, g}, {g, ϵ}})),γ];
Do[
LB[g] = LandauerButtiker[𝒯[g,γ],{T,T,μL,μR}];
{W,F}=BDThermLeadMatrices[(({{0, g}, {g, 0}})),γ,{T,T,μL,μR},Lb=100,8];
𝒞 = BDCovMat[W,F];

Meso[g] = ThermleadsParticleCurrent[𝒞,W,F,Lb]

,{g,gs}]

Show[
ListLinePlot[Table[{g,LB[g]["IN"]},{g,gs}]],
ListLinePlot[Table[{g, Meso[g]},{g,gs}],PlotStyle->Black]]

Energy current in the transient regime

h = TightBindingHamiltonian[2,1];
{W0,F}=BDThermLeadMatrices[h,1,{0.5,0.5,0,0},Lb=20,8];
C0=BDCovMat[W0,F];

h1 = (({{0, 0}, {0, 1}}));
W1 = I ArrayFlatten[(({{ConstantArray[0,{Lb,Lb}], 0, 0}, {0, h1, 0}, {0, 0, ConstantArray[0,{Lb,Lb}]}}))]//Normal;

(* Pulsed field *)
σ = 5;
ω = 0.2;

ℰ[t_]:=Exp[-((((t-15))^2)/(σ^2))]Cos[ω t ]
dt = 0.02;
tf = 50;
ℰ0 = 2.0;

Clear[f];
f[t_,𝒞_]:=With[{W = W0 +ℰ0  ℰ[t]W1},-W.𝒞-𝒞.W\[ConjugateTranspose]+F];
sol = RK4t[f,C0,dt,tf];

currLeft=Table[ThermleadsEnergyCurrent[c[[2]],W0+ℰ0  ℰ[c[[1]]]W1,F,Lb,"left"][[1]],{c,sol}];
currRight=Table[ThermleadsEnergyCurrent[c[[2]],W0+ℰ0  ℰ[c[[1]]]W1,F,Lb,"right"][[1]],{c,sol}];

ListLinePlot[Flatten[{currLeft\[Transpose][[1;;2]],currRight\[Transpose][[1;;2]]},1],PlotRange->All,
ImageSize->500,
PlotLegends->legend[{"left 1","left 2","right 1", "right 2"},{0.75,0.25}]
]

Energy current: comparison withe Landauer-Büttiker

Clear[TL,Lb]
TLs = Range[0.2,2,0.1];
Lbs = {100,150,200(*,250*)};
h = TightBindingHamiltonian[Ls=5];
γ = 0.1;
𝒯=NEGFTransmissionFunction[h,γ];
(*Clear[simsLB,simsTL,simsArchak];*)
PrettyTiming@Monitor[Do[
LB=LandauerButtiker[𝒯,{TL,TR=1.9,μL=0.,μR=0.3}]//Quiet;
simsLandauerButtiker[TL,"IE"]=LB["IE"];

Do[
{W,F}=BDThermLeadMatrices[h,γ,{TL,TR,μL,μR},Lb,8];
(*simsTL[TL,Lb,"IE"]=ThermleadsFCSAverage[W,F,{Ls,Lb},"energy","left"] ;*)
𝒞= BDCovMat[W,F];
simsMesoscopicLeads[TL,Lb,"IE"]=ThermleadsEnergyCurrent[𝒞,W,F,Lb];

,{Lb,Lbs}];
,{TL,TLs}],{TL,Lb}]

Show[
ListLinePlot[Table[{TL,simsLandauerButtiker[TL,"IE"]},{TL,TLs}],PlotStyle->Black],
ListLinePlot[
Table[{TL,simsMesoscopicLeads[TL,Lb,"IE"][[1,2]]},{Lb,Lbs},{TL,TLs}]
]
]

Full Counting Statistics with Covariance Matrices

BDFCS: Full counting statistics for non-interacting fermions with local Lindblad

BDFCSAverage[W_,F_,{μμp_,μμm_}]:=Module[{γp,γm,𝕀 = Eye[Length@W],𝒞,μm,μp},
γp = F;
γm = W+W\[ConjugateTranspose]-γp;
μm = DiagonalMatrix[μμm];
μp = DiagonalMatrix[μμp];
𝒞 = BDCovMat[W,F];

Tr[μm.γm.𝒞 + μp.γp.(𝕀-𝒞)]//Chop
]

BDFCSDiffusionMatrix[W_,F_,{μμp_,μμm_}]:=Module[{γp,γm,𝕀 = Eye[Length@W],𝒞,Ω,𝒞t,Υ,μm,μp},
γp = F;
γm = W+W\[ConjugateTranspose]-γp;
μm = DiagonalMatrix[μμm];
μp = DiagonalMatrix[μμp];
𝒞 = BDCovMat[W,F];
𝒞t = BDCovMat[W, -(*I*) 𝒞.μm.γm.𝒞+(*I*) (𝕀-𝒞).μp.γp.(𝕀-𝒞)];
Tr[(μm.μm.γm - μp.μp.γp).𝒞+μp.μp.γp]+- 2 (*I*)(-1) Tr[(μm.γm-μp.γp).𝒞t]//Chop
]

Example usage

h = TightBindingHamiltonian[L=4];
{W,F} = BDMatrices[h,γ=0.5,{f1=0.3,fL=0.15}];
μm = {-2,0,0,0};
μp = {1,0,0,3};

BDFCSAverage[W,F,{μp,μm}]
BDFCSDiffusionMatrix[W,F,{μp,μm}]

Comparison with FCS function (using full Hilbert space)

LoadFermionicOperators[L];
H = Sum[h[[i,j]] cd[i].c[j],{i,L},{j,L}];
cops = {(Sqrt[γ(1-f1)])c[1],(Sqrt[γ f1])cd[1],(Sqrt[γ(1-fL)])c[L],(Sqrt[γ fL])cd[L]};
ℒ = Liouvillian[H,cops];
ρ = SteadyState[ℒ];
FCSAverage[ρ,ℒ,cops,{μm[[1]],μp[[1]],μm[[-1]],μp[[-1]]}]
FCSDiffusionMatrix[ρ,ℒ,cops,{μm[[1]],μp[[1]],μm[[-1]],μp[[-1]]}]

Emission & absorption spectra in terms of Lyapunov dynamics

The system satisfies the Lyapunov equation 

(dC/dt) = -(W C + C W†) + F

The emission and absorption spectra are given by 

(Subscript[ℰ, ij])(ω) = ∫dτ (e^(-i ω τ))⟨(Subscript[c, j]^†)(τ)(Subscript[c, i])(0)⟩

and 

(Subscript[𝒜, ij])(ω) = ∫ dτ (e^(-i ω τ ))⟨(Subscript[c, i])(0) (Subscript[c, j]^†)(τ)⟩ 

For Gaussian dynamics, using the quantum regression theorem we can write 

⟨(Subscript[c, j]^†)(t') (Subscript[c, i])(t) ⟩ = (Subscript[θ(t'-t) [(Subscript[C, t])(e^(-W†(t'-t)))], ij]) + (Subscript[θ(t-t') [(e^(-W(t-t')))(Subscript[C, t'])], ij])

and

⟨(Subscript[c, i])(t) (Subscript[c, j]^†)(t') ⟩ = (Subscript[θ(t'-t) [(Subscript[(OverBar[C]), t])(e^(-W†(t'-t)))], ij]) + (Subscript[θ(t-t') [(e^(-W(t-t')))(Subscript[(OverBar[C]), t'])], ij])

where (OverBar[C]) = 1 ± C (with + for bosons and - for fermions).

Computing the Fourier transforms, we therefore get 

(Subscript[ℰ, ij])(ω) = (Subscript[[C (1/(W†+ i ω))+ (1/( W-i ω))C], ij])

(Subscript[𝒜, ij])(ω) = (Subscript[[(OverBar[C]) (1/(W†+i ω))- (1/(W-iω))(OverBar[C])], ij]) 

Thus, 

𝒜(ω)= [(1/(W†+i ω))- (1/( W-i ω))]  ± ℰ(ω)  

The spectrum of the output field is then 

(Subscript[𝒮, ii]) (ω) = (Subscript[γ, i]^(+))+ (Subscript[γ, i]^(-)) (Subscript[ℰ, ii])(ω) - (Subscript[γ, i]^(+))(Subscript[𝒜, ii])(ω) 

One can probably compute an analogous formula for (Subscript[𝒮, ij]). To be done.

Clear[w,wd]

Integrate[Exp[(-wd-I ω)τ],τ]

Integrate[Exp[(w-I ω)τ],τ]

Clear[BDEmissionSpectra];
BDEmissionSpectra[W_,F_,ωs_]:=Module[{𝒞,𝕀,inv1,inv2},
𝒞 = BDCovMat[W,F];
𝕀 = Eye[Length@W];
Table[
inv1 = Inverse[W\[ConjugateTranspose]+I ω 𝕀 ];
inv2 = Inverse[W-I ω 𝕀];
𝒞.inv1+inv2.𝒞,{ω,ωs}]//Chop
]

(* Fermions *) 
Clear[BDAbsorptionSpectra];
BDAbsorptionSpectra[W_,F_,ωs_]:=Module[{𝒞,𝕀,inv1,inv2,𝒞b},
𝕀 = Eye[Length@W];
𝒞 = BDCovMat[W,F];
𝒞b = 𝕀-𝒞;

Table[
inv1 = Inverse[W\[ConjugateTranspose]+I ω 𝕀 ];
inv2 = Inverse[W-I ω 𝕀];
𝒞b.inv1+inv2.𝒞b,{ω,ωs}]//Chop
]

Example usage

Emission = absorption for infinite temperature input/output

{W,F} = BDMatrices[1,6,0.1,{0.5,0.5}];
ωs = linspace[-2,4,2500];
ℰ=BDEmissionSpectra[W,F,ωs];

h=((W - W\[ConjugateTranspose])/(2I));
eigs=Eigvals[h]

ListLinePlot[{
{ωs,ℰ[[All,1,1]]}\[Transpose],
{ωs,ℰ[[All,5,5]]}\[Transpose]},PlotRange->All,GridLines->{eigs,None}]

ListLinePlot[{
{ωs,ℰ[[All,1,6]]}\[Transpose]},PlotRange->All,GridLines->{eigs,None}]

Example 2: dissipators acting on all sites

{W,F} = BDMatrices[1,L=12,ConstantArray[0.1,L],ConstantArray[0.5,L]];
ωs = linspace[-2,4,2500];
ℰ=BDEmissionSpectra[W,F,ωs];

h=((W - W\[ConjugateTranspose])/(2I));
eigs=Eigvals[h];
ListLinePlot[Evaluate@Table[{ωs,ℰ[[All,i,i]]}\[Transpose],{i,1,L}]
,PlotRange->All,GridLines->{eigs,None},ImageSize->900,GridLinesStyle->Black]

Example 3: absorption spectra at zero temperature & bath only at a single site.

Clear[𝒜];
Do[
{W,F} = BDMatrices[1,L=12,0.3Basis[L,k],0 Basis[L,1]];
ωs = linspace[-2,4,2500];
𝒜[k]=BDAbsorptionSpectra[W,F,ωs];
h=((W - W\[ConjugateTranspose])/(2I));
eigs=Eigvals[h];
,{k,L}]

Table[ListLinePlot[Evaluate@Table[{ωs,𝒜[k][[All,k,k]]}\[Transpose],{i,1,L}]
,PlotRange->All,GridLines->{eigs,None},ImageSize->250,GridLinesStyle->Black],{k,1,12,1}]

Clear[𝒜];
{W,F} = BDMatrices[1,L=25,0.3Basis[L,13],0 Basis[L,1]];
(*ωs = linspace[-2,4,2500];*)
𝒜=BDAbsorptionSpectra[W,F,{1.0}];
h=((W - W\[ConjugateTranspose])/(2I));
eigs=Eigvals[h];

Now the bath acting on all sites

{W,F} = BDMatrices[J,2,γ,{f1,fL}];
mf@W;
mf@F;

{mats,ℰ}=LyapunovEmissionSpectra[W,F,{ω}][[1]];

ℰ//cf//mf;

Manipulate[Plot[((2 (-((γ (6 fL+f1 (-2+(γ^2))))/(16+(γ^2)))-((γ (fL (2-4 ω)+f1 (2+(γ^2)+4 ω)))/((γ^2)+16 (ω^2)))))/(4+(γ^2)))/.{f1->1,fL->0},{ω,-10,10}],{{γ,0.1},0,10}]

ThermleadsFCS: Particle FCS for mesoscopic leads

Clear[ThermleadsFCSGMatrix];
ThermleadsFCSGMatrix[W_,Lb_,type_:"particle",bath_:"left"]:=Module[{γ,ϵ,Λ,G,Ls = Length@W-2Lb},
{γ,ϵ,Λ}= ThermleadsDecomposeW[W,Lb,bath];
G=Which[
type=="particle"&&bath=="left",
SparseArray[{{Lb+1,j_}/;1<=j<=Lb:>Λ[[j]]},{Lb+Ls+Lb,Lb+Ls+Lb}],
type=="energy"&&bath=="left",
SparseArray[{{Lb+1,j_}/;1<=j<=Lb:>(Λ(ϵ-I γ/2))[[j]]},{Lb+Ls+Lb,Lb+Ls+Lb}],
type=="particle"&&bath=="right",
SparseArray[{{Lb+Ls,j_}/;Lb+Ls+1<=j<=2Lb+Ls:>Λ[[j-Lb-Ls]]},{Lb+Ls+Lb,Lb+Ls+Lb}],
type=="energy"&&bath=="right",
SparseArray[{{Lb+Ls,j_}/;Lb+Ls+1<=j<=2Lb+Ls:>(Λ(ϵ-I γ/2))[[j-Lb-Ls]]},{Lb+Ls+Lb,Lb+Ls+Lb}],
type=="particle"&&bath=="difference",
SparseArray[{
{Lb+1,j_}/;1<=j<=Lb:>Λ[[j]],
{Lb+Ls,j_}/;Lb+Ls+1<=j<=2Lb+Ls:>-Λ[[j-Lb-Ls]]
},{Lb+Ls+Lb,Lb+Ls+Lb}]
];
G=G-G\[ConjugateTranspose]
]

Clear[ThermleadsFCSCurrent];
ThermleadsFCSCurrent[𝒞_,W_,F_,Lb_,bath_:"left"]:=Module[{G,Ls = Length@W-2Lb},
G=ThermleadsFCSGMatrix[W,Lb,"particle",bath];
-I Tr[G.𝒞]//Chop
]

Clear[ThermleadsFCSNoise]
ThermleadsFCSNoise[𝒞_,W_,F_,Lb_,bath_:"left"]:=Module[{𝕀 = Eye[Length@W],𝒞t,Ls = Length@W-2Lb,G,ψ},
𝕀 = Eye[Lb+Ls+Lb];
G=ThermleadsFCSGMatrix[W,Lb,"particle",bath];
𝒞t = BDCovMat[W,- (1/2)((𝕀-𝒞).G.𝒞+ 𝒞.G.(𝕀-𝒞))];
2Tr[G.𝒞t]//Chop
]

Comparison with the Landauer-Büttiker formalism

h = TightBindingHamiltonian[Ls=1];
w=8.0;
γ = 0.1;
T = 1.0;
LB=LandauerButtiker[NEGFTransmissionFunction[h,γ],{T,T,w/8,-w/8},{"IN","ΔN"},w,30]//Quiet;
{W,F}=BDThermLeadMatrices[h,γ,{T,T,w/8,-w/8},Lb=200,w,"lin"];
𝒞 = BDCovMat[W,F];

Labeled[TableForm[
Chop@{ThermleadsFCSCurrent[𝒞,W,F,Lb,"left"] ,
ThermleadsFCSCurrent[𝒞,W,F,Lb,"right"] ,ThermleadsParticleCurrent[𝒞,W,F,Lb],LB["IN"]},
TableHeadings->{{"FCS left", "FCS right",  "Average current","Landauer-Büttiker"},None}],"Average particle current",Top]

Labeled[TableForm[
{ThermleadsFCSNoise[𝒞,W,F,Lb,"left"],ThermleadsFCSNoise[𝒞,W,F,Lb,"right"],LB["ΔN"]},
TableHeadings->{{"FCS left", "FCS right", "Landauer-Büttiker"},None}],"Noise in the particle current", Top]

(* Takes around 15 minutes *)
(*Clear[T,γ,Lb,simsTL,simsLB]*)
Clear[T,γ,Lb];
w = 8.0;
Ts = w logspace[-3,2,50];
Lbs = {100,150,200,300,400};
γs = {0.1,1};
h = TightBindingHamiltonian[Ls=1,w/8];
μL=w/16;
μR=-w/16;
do[

𝒯=NEGFTransmissionFunctionFiniteBand[h,γ,w,(10^2)];
LB=LandauerButtiker[𝒯,{T,T,μL,μR},{"IN","ΔN"},w]//Quiet;
simsLB[T,γ,"IN"]=LB["IN"];
simsLB[T,γ,"ΔN"]=LB["ΔN"];

Do[
{W,F}=BDThermLeadMatrices[h,γ,{T,T,μL,μR},Lb,w,"lin"];
𝒞 = BDCovMat[W,F];
simsTL[T,γ,Lb,"IN"]=ThermleadsFCSCurrent[𝒞,W,F,Lb,"left"] ; ;
simsTL[T,γ,Lb,"ΔN"]=ThermleadsFCSNoise[𝒞,W,F,Lb,"left"];
,{Lb,Lbs}];
,{T,Ts},{γ,γs}]//Quiet

plots=Table[Table[
ListLogLinearPlot[Prepend[
Table[{TL,simsTL[TL,γ,Lb,p]},{Lb,Lbs},{TL,Ts}],
Table[{TL,simsLB[TL,γ,p]},{TL,Ts}]],

FrameLabel->{"(Subscript[T, L])",p},
Joined->True,
AspectRatio->1.4,
PlotLabel->p<> " with γ = "<>ToString@γ,
ImageSize->300,
FrameTicks->{{Automatic,Automatic},{logticks[-3,3,1],Automatic}},
(*PlotLegends->If[p=="IN",legend[Prepend[Lbs,"L-B"],{0.15,0.65}],None],*)
PlotStyle->Join[{Directive[Black,Dashed]},COLORLIST[[1;;Length@Lbs]]]
]
,{p,{"IN","ΔN"}}]
,{γ,γs}];

Labeled[
grid[Flatten@plots,2],Style["Image (c) is the same as Fig. 6(c) of Marlon's PRX",20,FontFamily->"Times"],Top]

ThermleadsFCS: energy-resolved particle current

Clear[ThermleadsFCSCurrentEnergyResolved];
ThermleadsFCSCurrentEnergyResolved[𝒞_,W_,F_,Lb_,bath_:"left"]:=Module[{Λ,Ls = Length@W-2Lb},
Λ= Last@ThermleadsDecomposeW[W,Lb,bath];
If[bath=="left",
Table[2Λ[[j]] Im@𝒞[[j,Lb+1]],{j,Lb}],
Table[2Λ[[j]] Im@𝒞[[Lb+Ls+j,Lb+Ls]],{j,Lb}]
]//Chop
]

Clear[ThermleadsFCSGMatrixEnergyResolved];
ThermleadsFCSGMatrixEnergyResolved[W_,Lb_,lead_,bath_:"left",modifier_:"False"]:=Module[{γ,ϵ,Λ,G,Ls = Length@W-2Lb},
{γ,ϵ,Λ}= ThermleadsDecomposeW[W,Lb,bath];
G=Which[
bath=="left",
SparseArray[{{Lb+1,j_}/;j==lead(*1<=j<=Lb*):>Λ[[j]]},{Lb+Ls+Lb,Lb+Ls+Lb}],
bath=="right",
SparseArray[{{Lb+Ls,j_}/;j==Lb+Ls+lead(*Lb+Ls+1<=j<=2Lb+Ls*):>Λ[[j-Lb-Ls]]},{Lb+Ls+Lb,Lb+Ls+Lb}]
];
G=G-G\[ConjugateTranspose]
]


Clear[ThermleadsFCSParticleNoiseEnergyResolved]
ThermleadsFCSParticleNoiseEnergyResolved[𝒞_,W_,F_,Lb_,lead_,bath_:"left"]:=Module[{𝕀 = Eye[Length@W],𝒞t,Ls = Length@W-2Lb,G,ψ},
𝕀 = Eye[Lb+Ls+Lb];
G=ThermleadsFCSGMatrixEnergyResolved[W,Lb,lead,bath];
𝒞t = BDCovMat[W,- (1/2)((𝕀-𝒞).G.𝒞+ 𝒞.G.(𝕀-𝒞))];
2Tr[G.𝒞t]//Chop
]

Landauer-Büttiker and NEGF

NEGF transmission function

Suitable for both numeric and symbolic manipulations. 
Returns the transmission function 

𝒯(ϵ) = tr((Subscript[Γ, 1])(Subscript[GΓ, L])G†), 

in the wide-band limit, of a quantum non-interacting chain with Hamiltonian h. 

Input is a L×L matrix h, and a coupling constant γ (assumed the same for both baths).
Output is a function 𝒯(ϵ), which can be called for different ϵ.

(* 𝒯=tr((Subscript[Γ, 1])(Subscript[GΓ, L])G\[ConjugateTranspose]) = ⟨1|S(1/(Λ-i ϵ))(S^(-1))|L⟩⟨L| (S^(-1\[ConjugateTranspose]))(1/(Λ\[ConjugateTranspose]+i ϵ))S\[ConjugateTranspose]|1⟩ = |(∑_k) ((Subscript[(Subscript[S, 1k])((S^(-1))), kL])/((Subscript[Λ, k])-i ϵ))((|)^2) *)
NEGFTransmissionFunction[h_,γ_]:=Module[{L=Length@h,Γ1,ΓL,W,Λ,S,Sinv},
Γ1 = γ Proj[L,1];
ΓL = γ Proj[L,L];
(*W = I h + (Γ1 + ΓL)/2;*)
W = -(I/2)(Γ1+ΓL)+ h;
{Λ,S}=Quiet@Eigensystem[W];
S = S\[Transpose]//SparseArray;
Λ = I Λ//SparseArray;
Sinv = Inverse[S]//SparseArray;

Function[With[{u = S[[1]],v=Sinv[[All,L]],λ = Λ},((Abs[γ u.((1/(λ-I #)) v)])^2)]]

];

NEGFTransmissionFunction[V_,L_,γ_]:=NEGFTransmissionFunction[TightBindingHamiltonian[V,L],γ]
NEGFTransmissionFunction[V_,L_,γ_,J_]:=NEGFTransmissionFunction[TightBindingHamiltonian[V,L,J],γ]

Clear[NEGFTransmissionFunctionFiniteBand]
NEGFTransmissionFunctionFiniteBand[h_,γ_,bandwidth_,npts_:(10^2)]:=Module[{L=Length@h,Γ1,ΓL,W0,Λ0,ϵmin,ϵmax,G,ϵs,𝕀 = NEye[Length@h],tab},
{ϵmin,ϵmax} = If[ArrayQ[bandwidth],bandwidth,{-bandwidth,bandwidth}];
ϵs = Rest@Most@linspace[ϵmin,ϵmax,npts];
Γ1 = γ Proj[L,1];
ΓL = γ Proj[L,L];

W0 = h - (I/2)(Γ1+ΓL);
Λ0 = (1/(2π))(Γ1+ΓL);
tab=Table[
G = I Inverse[ϵ 𝕀 - W0 - Λ0 Log[((ϵ-ϵmin)/(ϵmax-ϵ))]]; 
{ϵ,Tr[Γ1.G.ΓL.G\[ConjugateTranspose]]}
,{ϵ,ϵs}];
AppendTo[tab,{ϵmax,0}];
PrependTo[tab,{ϵmin,0}];

tab//Interpolation
]

Example usage

Transmission function for a single quantum dot.

𝒯=NEGFTransmissionFunction[ϵ0,1,γ][ϵ]//cf

Transmission function for a resonant double quantum dot.

𝒯=FullSimplify[NEGFTransmissionFunction[0,2,2γ,Ω][ϵ],{ϵ0∈Reals,ϵ∈Reals,γ>0}]
Plot[𝒯/.{γ->0.1,Ω->1},{ϵ,-10,10}]

Transmission function for a homogeneous tight-binding chain

𝒯 = NEGFTransmissionFunction[1,10,0.4];
Plot[𝒯[ϵ],{ϵ,-2,4}]

Transmission function for the Aubry-André-Haper tight-binding model with 20 sites.

𝒯=NEGFTransmissionFunction[AubryAndreHarper[20],20,1];
Plot[𝒯[ϵ],{ϵ,-3,3},PlotRange->All]

Example SSH model (arxiv 1803.03609)

Based on https://arxiv.org/pdf/1803.03609.pdf

NEGFTransmissionFunction[SSHHamiltonian[20,1.0,0.5],0.3]

δτs = linspace[-1,1,200];
𝒯 = Association[];
Do[
𝒯[δτ]=NEGFTransmissionFunction[SSHHamiltonian[20,1.0,δτ,0],0.3],{δτ,δτs}]

Quiet@ListDensityPlot[Flatten[Table[{δτ,ϵ,𝒯[δτ][ϵ]},{δτ,δτs},{ϵ,-2,2,0.0181}],1],PlotRange->All,ColorFunction->ColorData[{"PigeonTones","Reverse"}],AspectRatio->3]

Finite bandwidth version

When the transmission function has a finite bandwidth [(Subscript[ϵ, min]), (Subscript[ϵ, max])], there is a Principal value correction that must be included in the Transmission function.
c.f. https://iopscience.iop.org/article/10.1088/1742-5468/ab02f4/pdf

Finite bandwidth at [-8,8]:

𝒯1 = NEGFTransmissionFunction[TightBindingHamiltonian[1],1];
𝒯2= NEGFTransmissionFunctionFiniteBand[TightBindingHamiltonian[1],1,8,(10^3)];
Plot[{𝒯1[ϵ],𝒯2[ϵ]},{ϵ,-8,8}]

Difference seems tiny, but at high temperatures this can be important, specially for the noise (Subscript[Δ, N]).

Clear[T,γ];
w = 8.0;
Ts = w logspace[-3,2,50];
γ = 1.0;
h = TightBindingHamiltonian[Ls=1,w/8];
μL=w/16;
μR=-w/16;
Clear[lbsims];

do[
𝒯=NEGFTransmissionFunction[h,γ];
LB=LandauerButtiker[𝒯,{T,T,μL,μR},{"IN","ΔN"},w]//Quiet;
lbsims[T,"IN","no bd"]=LB["IN"];
lbsims[T,"ΔN","no bd"]=LB["ΔN"];

𝒯=NEGFTransmissionFunctionFiniteBand[h,γ,w,(10^2)];
LB=LandauerButtiker[𝒯,{T,T,μL,μR},{"IN","ΔN"},w]//Quiet;
lbsims[T,"IN", "bd"]=LB["IN"];
lbsims[T,"ΔN", "bd"]=LB["ΔN"];

,{T,Ts}]//Quiet

grid[Table[
ListLogLinearPlot[{
Table[{TL,lbsims[TL,p,"no bd"]},{TL,Ts}],
Table[{TL,lbsims[TL,p, "bd"]},{TL,Ts}]},

FrameLabel->{"(Subscript[T, L])",p},
Joined->True,
AspectRatio->1.4,
PlotLabel->p<> " with γ = "<>ToString@γ,
ImageSize->300,
PlotLegends->legend[{"Without Principal Value", "With Principal Value"},{0.5,0.3}],
FrameTicks->{{Automatic,Automatic},{logticks[-3,3,1],Automatic}}]
,{p,{"IN","ΔN"}}],1]

LandauerButtiker: Landauer-Büttiker & Levitov-Lesovik for coherent transport

Clear[FermiEnergyRegion];
FermiEnergyRegion[T_?NumberQ,μ_?NumberQ,prec_:(10^(-8))]:=Module[{β=1/T,log,emin,emax,energ},
log = Log[prec];
emin = μ + log/β;
emax = μ - log/β;
{emin,emax}//N
]

FermiEnergyRegion[{TL_,TR_,μL_,μR_},prec_:(10^(-8))]:=Module[{rL,rR},
rL = FermiEnergyRegion[TL,μL,prec];
rR = FermiEnergyRegion[TR,μR,prec];
{Min[rL[[1]],rR[[1]]],Max[rL[[2]],rR[[2]]]}
]

LandauerButtikerAllAvailableProperties = {
"IN","IE","ΔN","ΔE","𝒞","Shyp","IQL","IQR","P","σ","ΔP","ΔQL","ΔQR","Δσ","turN","turE","turP","turQL","turQR","fcorr","SNRN","SNRE","SNRP","SNRQL","SNRQR","SNRσ","a","b","Slhyp","turlhyp","turhyp"
};

Clear[LandauerButtiker];
LandauerButtiker[𝒯_,{TL_,TR_,μL_,μR_},pprops_:All,em_:∞,pres_:MachinePrecision,maxrec_:∞]:=Module[{βL = 1/TL,βR=1/TR,δβ,δμ,δβμ,fL,fR,IN,IE,IQL,IQR,P,σ,ΔN,ΔE,𝒞,ΔP,ΔQL,ΔQR,Δσ,turN,turE,turP,turQL,turQR,a,b,Jlhyp,Δlhyp,SNRN,SNRE,SNRP,SNRQL,SNRQR,Slhyp,Shyp,hyperparameters,fcorr,turlhyp,turhyp,SNRσ,g,G,integralsNeeded,intsNeeded,𝕀,result,LandauerButtikerIntegrals,emm,tab,props},

props = Flatten@{pprops};
(* DEFINE AUXILIARY VARIABLES & FUNCTIONS *)
δβ = βL-βR;
δμ = μL-μR;
δβμ = βL μL - βR μR;
fL[ϵ_]:=(1/(Exp[Rationalize[βL,(10^(-8))](ϵ-Rationalize[μL,(10^(-8))])]+1)); 
fR[ϵ_]:=(1/(Exp[Rationalize[βR,(10^(-8))](ϵ-Rationalize[μR,(10^(-8))])]+1));  
g[ϵ_]:=fL[ϵ](1-fL[ϵ])+fR[ϵ](1-fR[ϵ]);
G[ϵ_]:=𝒯[ϵ](g[ϵ] + (((fL[ϵ]-fR[ϵ]))^2)(1-𝒯[ϵ]));

(* LIST ALL INTEGRALS NEEDED, BASED ON WHICH PROPS THE USER PASSED TO THE FUNCTION *)
integralsNeeded[prop_]:=Which[
prop==="IN",{"IN"},
prop==="IE",{"IE"},
prop==="ΔN",{"ΔN"},
prop==="ΔE",{"ΔE"},
prop==="𝒞",{"𝒞"},
prop==="Shyp",{"Shyp"},
prop==="IQL",{"IN","IE"},
prop==="IQR",{"IN","IE"},
prop==="P",{"IN"},
prop==="σ",{"IN","IE"},
prop==="ΔP",{"ΔN"},
prop==="ΔQL",{"ΔN","ΔE","𝒞"},
prop==="ΔQR",{"ΔN","ΔE","𝒞"},
prop==="Δσ",{"ΔN","ΔE","𝒞"},
prop==="turN",{"IN","IE","ΔN"},
prop==="turE",{"IN","IE","ΔE"},
prop==="turP",{"IN","IE","ΔN"},
prop==="turQL",{"IN","IE","ΔN","ΔE","𝒞"},
prop==="turQR",{"IN","IE","ΔN","ΔE","𝒞"},
prop==="fcorr",{"ΔN","ΔE","𝒞"},
prop==="SNRN",{"IN","ΔN"},
prop==="SNRE",{"IE","ΔE"},
prop==="SNRP",{"IN","ΔN"},
prop==="SNRQL",{"IN","IE","ΔN","ΔE","𝒞"},
prop==="SNRQR",{"IN","IE","ΔN","ΔE","𝒞"},
prop==="SNRσ",{"IN","IE","ΔN","ΔE","𝒞"},
prop==="a",{"IN","IE","ΔN","𝒞"},
prop==="b",{"IN","IE","ΔE","𝒞"},
prop==="Slhyp",{"IN","IE","ΔN","ΔE","𝒞"},
prop==="turlhyp",{"IN","IE","ΔN","ΔE","𝒞"},
prop==="turhyp",{"IN","IE","Shyp"},
prop===All,{"IN","IE","ΔN","ΔE","𝒞","Shyp"}
];
intsNeeded=DeleteDuplicates@Flatten@Map[integralsNeeded,Flatten@{props}];

emm = If[ArrayQ[em],em,{-em,em}];
(* COMPUTE SAID INTEGRALS *)
LandauerButtikerIntegrals[int_,emm_]:=Module[{func,ϵ},
func = Which[
int==="IN",𝒯[ϵ](fL[ϵ]-fR[ϵ]),
int==="IE",ϵ 𝒯[ϵ](fL[ϵ]-fR[ϵ]),
int==="ΔN",G[ϵ],
int==="ΔE",(ϵ^2)G[ϵ],
int==="𝒞",ϵ G[ϵ],
int==="Shyp",((𝒯[ϵ](((fL[ϵ]-fR[ϵ]))^2))/((fL[ϵ]+fR[ϵ]-2 fL[ϵ] fR[ϵ]-𝒯[ϵ](((fL[ϵ]-fR[ϵ]))^2)))) 
];
(1/(2π)) NIntegrate[func,{ϵ,emm[[1]],0},WorkingPrecision->pres,MaxRecursion->maxrec]
+(1/(2π)) NIntegrate[func,{ϵ,0,emm[[2]]},WorkingPrecision->pres,MaxRecursion->maxrec]
];

Do[𝕀[int]=LandauerButtikerIntegrals[int,emm],{int,intsNeeded}];


(* USE INTEGRALS TO CONSTRUCT ALL DESIRED RESULTS *)
result[prop_]:=Which[
prop==="IN",𝕀["IN"],
prop==="IE",𝕀["IE"],
prop==="ΔN",𝕀["ΔN"],
prop==="ΔE",𝕀["ΔE"],
prop==="𝒞",𝕀["𝒞"],
prop==="Shyp",𝕀["Shyp"],
prop==="IQL",𝕀["IE"] - μL 𝕀["IN"],
prop==="IQR",𝕀["IE"] - μR 𝕀["IN"],
prop==="P",-δμ 𝕀["IN"],
prop==="σ",-δβ 𝕀["IE"] + δβμ 𝕀["IN"],
prop==="ΔP",((δμ)^2) 𝕀["ΔN"],
prop==="ΔQL",𝕀["ΔE"] - 2 μL 𝕀["𝒞"] + ((μL)^2)𝕀["ΔN"],
prop==="ΔQR", 𝕀["ΔE"] - 2 μR 𝕀["𝒞"] + ((μR)^2)𝕀["ΔN"],
prop==="Δσ",((δβ)^2)𝕀["ΔE"] - 2 δβ δβμ 𝕀["𝒞"] + ((δβμ)^2) 𝕀["ΔN"],
prop==="turN",((𝕀["ΔN"])/((𝕀["IN"])^2)) result["σ"]//Quiet,
prop==="turE",((𝕀["ΔE"])/((𝕀["IE"])^2)) result["σ"]//Quiet,
prop==="turP",((result["ΔP"])/((result["P"])^2)) result["σ"]//Quiet, 
prop==="turQL",((result["ΔQL"])/((result["IQL"])^2)) result["σ"]//Quiet, 
prop==="turQR",((result["ΔQR"])/((result["IQR"])^2)) result["σ"]//Quiet, 
prop==="fcorr",𝕀["𝒞"]/(Sqrt[𝕀["ΔN"] 𝕀["ΔE"]]),
prop==="SNRN",(((𝕀["IN"])^2)/(𝕀["ΔN"])), 
prop==="SNRE",(((𝕀["IE"])^2)/(𝕀["ΔE"])),
prop==="SNRP",(((result["P"])^2)/(result["ΔP"])),
prop==="SNRQL",(((result["IQL"])^2)/(result["ΔQL"])),
prop==="SNRQR",(((result["IQR"])^2)/(result["ΔQR"])),
prop==="SNRσ",(((result["σ"])^2)/(result["Δσ"])),
(* Hyperaccurate results from arXiv:2108.05325 *)
prop==="a",𝕀["IE"] 𝕀["ΔN"] - 𝕀["IN"] 𝕀["𝒞"],
prop==="b",𝕀["IN"] 𝕀["ΔE"]-𝕀["IE"] 𝕀["𝒞"], 
prop==="Slhyp",((((result["a"] 𝕀["IE"] + result["b"] 𝕀["IN"]))^2)/(((result["a"])^2)𝕀["ΔE"]+((result["b"])^2)𝕀["ΔN"]+ 2 result["a"] result["b"] 𝕀["𝒞"])), 
prop==="turlhyp",((result["σ"])/(result["Slhyp"])),
prop==="turhyp",((result["σ"])/(𝕀["Shyp"]))
];

tab=If[pprops ===All,
Chop@Table[p->result[p],{p,LandauerButtikerAllAvailableProperties}],
Chop@Table[p->result[p],{p,props}]];
If[Length@props==1 && Not[pprops ===All],
tab[[1,2]],
Association[tab]
]

]

Usage

Transport across a single quantum dot

ϵ0 = 0.0;
γ = 0.1;
𝒯=NEGFTransmissionFunction[ϵ0,1,γ];
result=LandauerButtiker[𝒯,{0.1,0.3,1.1,-1.1}]

Default syntax computes a long list with all sorts of properties, as an Association:

Dataset`$DatasetTargetRowCount=40;
Dataset[result]

Individual properties can be retrived as follows

result["IN"]
result["ΔN"]

Alternatively: compute only specific properties you are interested in (which is faster if you have to do this many times):

LandauerButtiker[𝒯,{0.1,0.3,1.1,-1.1},"IN"]

LandauerButtiker[𝒯,{0.1,0.3,1.1,-1.1},"ΔN"]

If more than one property is passed to the function, the output is an association

LandauerButtiker[𝒯,{0.1,0.3,1.1,-1.1},{"IN","ΔN"}]

Ex: TUR violations in a boxcar and a double quantum dot (Ptaszyński, PRB, 98, 085425)

Clear[γ,Ω,ϵ0];
FullSimplify[NEGFTransmissionFunction[ϵ0,2,γ,Ω][ϵ]]

γ = 0.1;
ϵ0 = 0.0;
Ω = 0.05; 

𝒯 =NEGFTransmissionFunction[0,2,γ,Ω];
TL = TR = 1.0;
sims = Association[];
δμs = range[0.01,8,0.1];
PrettyTiming@Monitor[Do[
sims[δμ] = LandauerButtiker[𝒯,{TL,TR,δμ/2,-δμ/2}],
{δμ,δμs}],δμ]

Grid[{{
ListLinePlot[Table[{δμ,sims[δμ]["IN"]},{δμ,δμs}],
FrameLabel->{"δμ","(Subscript[I, N])"},AspectRatio->1,ImageSize->250,PlotLabel->Style["Current goes up",14]
],
ListLinePlot[Table[{δμ,sims[δμ]["ΔN"]},{δμ,δμs}],
FrameLabel->{"δμ","(Subscript[Δ, N]^2)"},AspectRatio->1,ImageSize->250,PlotLabel->Style["Fluctuations go down",14]
],
ListLinePlot[Table[{δμ,sims[δμ]["turN"]},{δμ,δμs}],
FrameLabel->{"δμ","Fano factor"},AspectRatio->1,ImageSize->250,GridLinesStyle->Directive[Black, Dashed],GridLines->{None,{2}},
PlotLabel->Style["But ((Subscript[Δ, N]^2)/(Subscript[I, N]^2))σ violates classical TUR",14]
]
}}]

𝒯 =Boxcar[-0.5,0.5];
TL = TR = 1.0;
sims2 = Association[];
δμs = range[0.01,8,0.1];
PrettyTiming@Monitor[Do[
sims2[δμ] = LandauerButtiker[𝒯,{TL,TR,δμ/2,-δμ/2},"turN",{-0.499,0.499}],
{δμ,δμs}],δμ]

ListLinePlot[{
Table[{δμ,sims[δμ]["turN"]},{δμ,δμs}],
Table[{δμ,sims2[δμ]},{δμ,δμs}]},
FrameLabel->{"δμ","Fano factor"},AspectRatio->1,ImageSize->250,GridLinesStyle->Directive[Black, Dashed],GridLines->{None,{2}},
PlotLabel->Style["((Subscript[Δ, W]^2)/(Subscript[I, W]^2))σ",14]
]

Ex: Conductance quantization in a quantum point contact

Based on https://journals.aps.org/prb/abstract/10.1103/PhysRevB.103.235120 
Eqs. (B1)-(B3) and (A.14)

(* Define transmission function *)
Clear[𝒯]
𝒯= Function[(1/4)Total@Table[Boxcar[n,100][#],{n,0,3,1}]];
Plot[𝒯[ϵ],{ϵ,-1,6}]

Simulate for different μ, with fixed (Subscript[T, L])=(Subscript[T, R]) and fixed (small) (Subscript[δ, μ]).

Clear[sims];
sims = Association[];

TL = 0.02;
TR = 0.02;
δμ = 0.005;
μs = Rest@range[0,4,0.05];
do[
sims[μ] = LandauerButtiker[𝒯,{TL,TR,μ+δμ/2,μ-δμ/2},"IN",{0,100},30],
{μ,μs}]

ListLinePlot[Table[{μ,sims[μ]/δμ},{μ,μs}],
FrameLabel->{"μ","(Subscript[J, N])"}
]

(* c.f. E.q. (4.53) of https://research.chalmers.se/en/publication/520374*)
(* They call it a "transmission probability", but it can easily go beyond 1, so probably not normalized *)
Clear[ϵ,γ,En];
En = V0 + ωy(n+1/2);
γ = ωx/(2π);
V0=1;
ωy = 1;
ωx = 0.1;
Plot[Sum[(1/(1+Exp[(En-ϵ)/γ])),{n,0,10}],{ϵ,0,10}]
Clear[ωx,ωy,γ,V0,En,ϵ]

NEGF full covariance matrix

Based on https://arxiv.org/pdf/1106.3207.pdf

Covariance matrix is given by Eq. (2.8)

C = ∫ ((dω)/(2π))((Subscript[GΓ, 1])G† (Subscript[f, 1]) +(Subscript[GΓ, L])G†(Subscript[f, L]))

where ((Subscript[Γ, i]),(Subscript[f, i])) are the coupling matrices and Fermi-Dirac distributions of the left (i=1) and right (i=L) baths, and 

G(ω)=(((W - iω))^(-1)) = (((i h +(( (Subscript[Γ, 1])+(Subscript[Γ, L]))/2)-i ω))^(-1))

is the NEGF. 

The function below assumes W is diagonalizable as W=((SΛS)^(-1)). 
The covariance matrix can then be written as 

C = S Y S†

where 

(Subscript[Y, ij])=(Subscript[(Subscript[γ, 1])((S^(-1))), i1])(Subscript[((S^(-1))), j1]^( * ))(Subscript[A, ij]^1) + (Subscript[(Subscript[γ, L])((S^(-1))), iL])(Subscript[((S^(-1))), jL]^( * ))(Subscript[A, ij]^L) 

where 

(Subscript[A, ij]) = ∫((dΩ)/(2π)) ((f(Ω))/((Ω+i (Subscript[λ, i]))(Ω-i (Subscript[λ, j]^*))))  = (1/(x-y))((i/2)+(1/(2π))ψ((1/2)-i(( β x)/(2π)))-(1/(2π))ψ((1/2)+i(( β y)/(2π)))),  (computable using residuals)

with  f(Ω) = (1/((e^(β(Ω-μ)))+1)) , x = i (Subscript[Λ, j]^( * ))-μ, y = (Subscript[iΛ, i])-μ and ψ(z) = Γ’(z)/Γ(z) being the digamma function. 

Below the matrices (Subscript[A, ij]) are written using a compiled function for speed.

(* Auxiliary function, pre-compiled for speed *)
Clear[NEGFAuxMat];
NEGFAuxMat= Compile[{{Λ,_Complex,1},{β,_Real},{μ,_Real}}, 

Module[{x,y,ψp,ψm},

x = I Λ\[Conjugate]-μ;
y=-I Λ-μ;
ψp = Table[PolyGamma[((I β y[[i]])/(2π))+1/2],{i,Length@Λ}];
ψm = Table[PolyGamma[-((I β x[[j]])/(2π))+1/2],{j,Length@Λ}];

Table[(1/(x[[j]]-y[[i]] ))((I/2)+(1/(2π))(ψm[[j]]-ψp[[i]])),{i,Length@Λ},{j,Length@Λ}]

](*,CompilationTarget->"C"*)
];

NEGFCovMat[h_,γ_,{TL_,TR_,μL_,μR_}]:=Module[{L = Length@h,Γ,W,Λ,S,Sinv,g,ppart,K,Y,ℐ,amat,Γ1,ΓL,A1,AL},

Γ1 = SparseArray[{{1,1}->γ},{L,L}];
ΓL = SparseArray[{{L,L}->γ},{L,L}];
Γ = Γ1+ΓL;
W = -I (Γ/2)+ h;
{Λ,S}=Quiet@Eigensystem[W];
S = S\[Transpose]//SparseArray;
Λ = I Λ//SparseArray;
Sinv = Inverse[S]//SparseArray;
A1 =SparseArray@NEGFAuxMat[Normal@Λ,1/TL,μL];
AL=SparseArray@NEGFAuxMat[Normal@Λ,1/TR,μR];
Y = A1 (Sinv.Γ1.Sinv\[ConjugateTranspose])+AL (Sinv.ΓL.Sinv\[ConjugateTranspose]);
S.Y.S\[ConjugateTranspose]//Chop
]

NEGFCurrents[V_,L_,γ_,βL_,βR_,μL_,μR_]:=Module[{𝒞,JN,JE,JQL,JQR,P,σ,v,i=2},

𝒞 = NEGFCovMat[V,L,γ,βL,βR,μL,μR];
JN =  -I (𝒞[[2,1]]-𝒞[[1,2]])//Chop;
v = If[VectorQ[V],V[[1]],V]//Chop;
JE = I v ((𝒞[[i-1,i]]-𝒞[[i,i-1]])-(𝒞[[i+1,i]]-𝒞[[i,i+1]]))+ I (𝒞[[i+1,i-1]]-𝒞[[i-1,i+1]])//Chop;
JQL = JE - μL JN//Chop;
JQR = JE - μR JN//Chop;
P = -(μL-μR) JN//Chop;
σ = -(βL-βR) JE + (βL μL - βR μR) JN//Chop;
<|"JN"->JN,"JE"->JE,"JQL"->JQL,"JQR"->JQR,"P"->P,"σ"->σ|>
]

Example usage

h = TightBindingHamiltonian[4];
𝒞=NEGFCovMat[h,1,{0.1,0.1,0,0}]//mf;

(* Compare with the thermal state when γ -> 0 *)
𝒞=NEGFCovMat[h,0.000001,{0.1,0.1,0,0}];
𝒞th=Inverse[MatrixExp[h/0.1]+Eye[4]]//Quiet;
Norm[𝒞-𝒞th]

Comparison with Landauer-Büttiker

h = TightBindingHamiltonian[4,V=3.0];
𝒞=NEGFCovMat[h,γ = 0.6,{TL=0.9,TR=0.3,μL=0.3,μR=0}]//mf;
𝒯=NEGFTransmissionFunction[h,γ];
LB=LandauerButtiker[𝒯,{TL,TR,μL,μR}];

(* Particle current *) 
-I  (𝒞[[2,1]]-𝒞[[1,2]])//Chop
LB["IN"]

JE = I (V(𝒞[[i-1,i]]-𝒞[[i,i-1]]) + (𝒞[[i+1,i-1]]-𝒞[[i-1,i+1]]))//Chop
LB["IE"]

Example: coherence in a double quantum dot

Clear[T,γ,ϵ,eV,μL,μR,g,gs,𝒞];
T = 100;
γ = 1.0;
ϵ=0;
eV = 625; 
μL = eV/2;
μR = -eV/2;
gs = linspace[0.001,4,100];

Clear[𝒞,g];
Do[
𝒞[g] = NEGFCovMat[(({{ϵ, g}, {g, ϵ}})),γ,{T,T,μL,μR}],{g,gs}]

ListLinePlot[Table[{g,𝒞[g][[1,2]]//Abs},{g,gs}],
FrameLabel->{"g/γ","|(Subscript[𝒞, 12])((|)^2)"},
PlotLabel->"Coherence"
]

Conditional dynamics

Waiting time distribution (PRB)

Based on https://arxiv.org/pdf/2108.11850.pdf

Clear[FermionicChainWaitingTimeDistributionVacuum];
FermionicChainWaitingTimeDistributionVacuum[W_,F_,trange_,{i_,diri_},j_]:=Module[{L = Length@W,𝒞,EM,EmM,Q,Γ,EX,EZ,P,γ},

Q = W - F;
Γ = Tr[F];
γ = If[diri =="-",2 Re@W[[i,i]]-F[[i,i]],F[[i,i]]];

If[diri=="-",
Table[
EX = MatrixExp[-Q t];
EZ = EX\[ConjugateTranspose];
{t,γ (E^(-Γ t)) EX [[i,j]] EZ[[j,i]]},{t,trange}],

Table[
EX = MatrixExp[-Q t];
EZ = EX\[ConjugateTranspose];
{t,γ (E^(-Γ t)) ((EZ.EX)[[j,j]] - EX [[i,j]] EZ[[j,i]])},{t,trange}]]//Chop

]

Clear[FermionicChainWaitingTimeDistribution];
FermionicChainWaitingTimeDistribution[WW_,FF_,ttrange_,{i_,diri_},{j_,dirj_},CC_:"ss",pres_:MachinePrecision]:=Module[{L = Length@WW,W,F,𝒞,EM,EmM,Q,X,Γ,c,𝕀,𝒯,𝔻,γ,deno,trange,𝒵,EX,EmX,EZ,EmZ},

trange = SetPrecision[Rationalize@ttrange,pres];
W =SparseArray@SetPrecision[Rationalize@Normal@WW,pres];
F =SparseArray@SetPrecision[Rationalize@Normal@FF,pres];
𝕀 = Eye[L];

If[CC=="vac",Return[FermionicChainWaitingTimeDistributionVacuum[W,F,trange,{i,diri},j]]];

𝒞=If[CC==="ss",Chop@LyapunovSolve[W,F],CC];
EM = Inverse[𝒞]-𝕀;
EmM = Inverse[EM];

Q = W - F;
𝒵 = Det[𝕀 + EmM];
Γ = Tr[F];

γ = If[diri =="-",2 Re@W[[i,i]]-F[[i,i]],F[[i,i]]];
c = If[dirj=="-",𝒞[[j,j]],1-𝒞[[j,j]]];

Table[
X = -Q t;
(*Z = - Q\[ConjugateTranspose] t; (* X\[ConjugateTranspose] *)*)
EX = MatrixExp[X];
EmX = MatrixExp[-X];
EZ = EX\[ConjugateTranspose] (* ℰ[Z]*);
EmZ=EmX\[ConjugateTranspose];

𝒯 = Inverse[EmZ.EM.EmX+𝕀];
𝔻 = Det[𝕀 + EX.EmM.EZ];


{t,(γ/c)((Exp[-Γ t])/𝒵)  𝔻 Which[
(* (Subscript[c, i]^\[ConjugateTranspose])(Subscript[c, i]) and (Subscript[c, j]^\[ConjugateTranspose])(Subscript[ρc, j]) *)diri=="-" && dirj=="+",  
((EM.EmX.𝒯.EX)[[j,j]] 𝒯[[i,i]] + (𝒯.EmZ.EM)[[i,j]] (EM.EmX.𝒯)[[j,i]]),
(* (Subscript[c, i])(Subscript[c, i]^\[ConjugateTranspose]) and (Subscript[c, j]^\[ConjugateTranspose])(Subscript[ρc, j]) *)diri=="+" && dirj=="+", 
((EM.EmX.𝒯.EX)[[j,j]] (𝕀[[i,i]]-𝒯[[i,i]]) - (𝒯.EmZ.EM)[[i,j]] (EM.EmX.𝒯)[[j,i]]),
(* (Subscript[c, i]^\[ConjugateTranspose])(Subscript[c, i]) and (Subscript[c, j])(Subscript[ρc, j]^\[ConjugateTranspose]) *)diri=="-" && dirj=="-", 
(𝒯[[i,i]] (EmM[[j,j]]-(EmX.𝒯.EX.EmM)[[j,j]]) - (𝒯.EmZ)[[i,j]] (EmX.𝒯)[[j,i]]),
(* (Subscript[c, i])(Subscript[c, i]^\[ConjugateTranspose]) and (Subscript[c, j])(Subscript[ρc, j]^\[ConjugateTranspose]) *)diri=="+" && dirj=="-", 
((𝕀[[i,i]]-𝒯[[i,i]]) (EmM[[j,j]]-(EmX.𝒯.EX.EmM)[[j,j]]) + (𝒯.EmZ)[[i,j]] (EmX.𝒯)[[j,i]])
]},
{t,trange}]//Chop

]

FermionicChainWaitingTimeDistribution[V_,L_,γ_,{f1_,fL_},ttrange_,{i_,diri_},{j_,dirj_},CC_:"ss",pres_:MachinePrecision]:=Module[{W,F},
{W,F} = BDMatrices[V,L,γ,{f1,fL}];
FermionicChainWaitingTimeDistribution[W,F,ttrange,{i,diri},{j,dirj},CC,pres]]

Example usage

ts = linspace[0,80,200];
ϵ = 1.0;
L = 5;
γ = 0.1;
fs = {1,0};

PL=FermionicChainWaitingTimeDistribution[ϵ,L,γ,fs,ts,{L,"-"},{1,"+"}];
P1=FermionicChainWaitingTimeDistribution[ϵ,L,γ,fs,ts,{1,"+"},{1,"+"}];

ListLinePlot[{PL},PlotRange->All]
ListLinePlot[{P1},PlotRange->All]

ProbChannel[wdist_]:=Module[{Δt = First@Differences@wdist[[All,1]]},Trapz[wdist[[All,2]],Δt]]
ProbChannel[PL]+ProbChannel[P1]

Basis[10,1]//mf;

MatrixForm/@Chop@BDMatricesBasic[TightBindingHamiltonianPBC[10],0.1 Basis[10,1],Basis[10,1]]

FermionicChainWaitingTimeDistribution

L = 50;
{W,F} = BDMatricesBasic[TightBindingHamiltonianPBC[L],0.1 Basis[L,1],0 Basis[L,1]];
P = FermionicChainWaitingTimeDistributionVacuum[W,F,ts,{1,"-"},1];
ListLinePlot[P]

SSH model

(* Takes around 1 minute to run *)
ts = linspace[0,70,200];
Ls = {5,8,10,20,30};
Clear[P]
P = Association[];

Do[
h = SSHHamiltonian[L,1.0,-0.5];
{W,F} = BDMatrices[h,0.1,{1,0}];
P[L]=FermionicChainWaitingTimeDistribution[W,F,ts,{L,"-"},{1,"+"},"ss",30];
,{L,Ls}]

ListLinePlot[{P[5],P[8]},PlotRange->All]

ListLinePlot[{P[8],P[10]},PlotRange->All]

ListLinePlot[{P[20],P[30]},PlotRange->All]

ts = linspace[0,70,200];
Ls = {5,8,10,20,30};
Clear[Pv]
Pv = Association[];

Do[
h = SSHHamiltonian[L,1.0,-0.5];
{W,F} = BDMatrices[h,0.1,{1,0}];
Pv[L]=FermionicChainWaitingTimeDistribution[W,F,ts,{L,"-"},{1,"+"},"vac",30];
,{L,Ls}]

ListLinePlot[{Pv[5],Pv[8]},PlotRange->All]

ListLinePlot[{Pv[8],Pv[10]},PlotRange->All]

ListLinePlot[{Pv[20],Pv[30]},PlotRange->All]

Aubry-André-Haper model

ts = linspace[0,150,300];
Ls = {(*5,8,10,20,*)30};
Clear[Pv]
Pv = Association[];
λs = {0,1.0,1.9,2.0,2.2};

Do[
h = TightBindingHamiltonian[L,λ AubryAndreHarper[L]];
{W,F} = BDMatrices[h,0.1,{1,0}];
Pv[{L,λ}]=FermionicChainWaitingTimeDistribution[W,F,ts,{L,"-"},{1,"+"},"vac",30];
,{L,Ls},{λ,λs}]

Row@Evaluate@Table[ListLinePlot[{Pv[{30,λ}]},ImageSize->200,PlotRange->All,BaseStyle->{12},
ImagePadding->{{80,10},{20,10}},AspectRatio->1,
FrameTicks->{{Automatic,Automatic},{None,None}},
FrameLabel->{"time","prob 1 -> L"},
(*PlotLegends->legend[{"λ = " <> ToString@λ},{0.75,0.65}],*)
Epilog->Text["λ = " <> ToString@λ,Scaled[{0.65,0.85}]],
PlotStyle->red
],{λ,λs}]

No-jump conditional dynamics

Computes the no-jump distribution (Subscript[P, no]) = tr( (e^((Subscript[ℒ, 0])t))(Subscript[ρ, 0])) for a fermionic chain (no pairing terms), assuming all channels are monitored.
Notation similar to https://arxiv.org/pdf/2108.11850.pdf

Clear[FermionicChainNoJump];
FermionicChainNoJump[WW_,FF_,ttrange_,CC_:"ss",pres_:MachinePrecision]:=Module[{L = Length@WW,trange,W,F,𝕀,𝒞,EM,EmM,Q,𝒵,Γ,EX},
trange = SetPrecision[Rationalize@ttrange,pres];
W =SparseArray@SetPrecision[Rationalize@Normal@WW,pres];
F =SparseArray@SetPrecision[Rationalize@Normal@FF,pres];
𝕀 = Eye[L];

𝒞=If[CC==="ss",Chop@LyapunovSolve[W,F],CC];
EM = Inverse[𝒞]-𝕀;
EmM = Inverse[EM];

Q = W - F;
𝒵 = Det[𝕀 + EmM];
Γ = Tr[F];

Table[
EX = MatrixExp[-Q t];
{t,((E^(-Γ t))/𝒵) Det[𝕀 + EX.EmM.EX\[ConjugateTranspose]]},{t,trange}]//Chop
]

FermionicChainNoJump[V_,L_,γ_,{f1_,fL_},ttrange_,CC_,pres_:MachinePrecision]:=Module[{W,F},
{W,F} = BDMatrices[V,L,γ,{f1,fL}];
FermionicChainNoJump[W,F,ttrange,CC,pres]]

Example usage

ts = linspace[0,50,100];
L = 10;
h = TightBindingHamiltonian[L];
{W,F} = BDMatrices[h,0.1,{1,0}];
P1=FermionicChainNoJump[W,F,ts,"ss"];
ListLogPlot[P1,PlotRange->All,Joined->True]

ts = linspace[0,50,100];
L = 10;
h = SSHHamiltonian[L,1.0,-0.5];;
{W,F} = BDMatrices[h,0.1,{1,0}];
P2=FermionicChainNoJump[W,F,ts,"ss"];
ListLogPlot[{P1,P2},PlotRange->All,Joined->True]

ts = linspace[0,50,100];
L = 10;
h = TightBindingHamiltonian[L];
{W,F} = BDMatrices[h,ConstantArray[0.1,L],ConstantArray[0.5,L]];
P1=FermionicChainNoJump[W,F,ts,"ss"];

(* SSH model *)
ts = linspace[0,50,100];
L = 10;
h = SSHHamiltonian[L,1.0,-0.5];
{W,F} = BDMatrices[h,ConstantArray[0.1,L],ConstantArray[0.5,L]];
P2=FermionicChainNoJump[W,F,ts,"ss"];
ListLogPlot[{P1,P2},PlotRange->All,Joined->True]

Riccati solver

Solves
a†x + x a - x b (r^(-1))b† x + q = 0

Similar to Mathematica’s RiccatiSolve[], but you only have to pass the matrix (br^(-1))b†, instead of b and r individually.

Clear[RiccatiEigen];
RiccatiEigen[a_,q_,brb_]:=Module[{Z,U,d,U11,U21},

Z =ArrayFlatten[(({{a, -brb}, {-q, -a\[ConjugateTranspose]}}))];
(*U = Eigvecs[Z,Length[Z]/2];*)
U=Transpose[(Reverse@Eigenvectors[Z + (10^5) Eye@Length@Z,-Length[Z]/2])];
d=Length[Z]/2;
U11 = U[[1;;d,1;;d]];
U21 = U[[d+1;;2d,1;;d]];
U21.Inverse[U11]
]

Example usage

{a,b,q,r}={(({{-3, 2}, {1, 1}})),(({{0}, {1}})),(({{1., -1.}, {-1., 1.}})),(({{3}}))};
x=RiccatiSolve[{a,b},{q,r}]//mf;

RiccatiEigen[a,q,b.Inverse[r].b\[ConjugateTranspose]]//mf;

RiccatiSolve[{a=(({{-1, 0, 0}, {0, -4, 0}, {0, 0, -6}})),b=(({{3}, {1}, {-1}}))},{q=(({{4, 2, 0}, {2, 4, 0}, {0, 0, 1}})),{{1.}}}]//mf;
RiccatiEigen[a,q,b.b\[ConjugateTranspose]]//mf;

Conditional Lyapunov dynamics for fermions

Clear[ConditionalFermionicDynamics];
ConditionalFermionicDynamics[H_,γ_,f_,{ηm_,ηp_},tf_,CC_:"ss",solver_:"NDSolve",dt_:0.01]:=Module[{L,W,Υ,𝒲,ℱ,γp,γm,ℂ,𝒞,𝒞0,𝒜m,𝒜p,Θ0,Θ,𝕀,Φ},

L=Length[ηm];
{W,γp} = BDMatrices[Eye[L],γ,f];
γm = W+W\[ConjugateTranspose]-γp;
𝒜m = Normal@DiagonalMatrix[ηm];
𝒜p = Normal@DiagonalMatrix[ηp];

If[L==Length@H,
W = I H + W;
(𝒞0=Normal@If[CC==="ss",Chop@LyapunovSolve[W,γp],CC];
If[solver ==="NDSolve",
NDSolveValue[{
𝒞'[t]==-(W.𝒞[t] + 𝒞[t].W\[ConjugateTranspose]) + γp+ 𝒞[t].γm.𝒜m.𝒞[t]-γp.𝒜p+ γp.𝒜p.𝒞[t]+ 𝒞[t].γp.𝒜p-𝒞[t].γp.𝒜p.𝒞[t] ,
𝒞[0]==𝒞0},𝒞,{t,0,tf}],
Interpolation@RK4[-(W.# + #.W\[ConjugateTranspose]) + γp+ #.γm.𝒜m.#-γp.𝒜p+ γp.𝒜p.#+ #.γp.𝒜p-#.γp.𝒜p.#&,𝒞0,dt,tf]
]),
(
Υ = (1/4)ArrayFlatten[(({{γp+γm, I(γp-γm)}, {-I (γp-γm), γp+γm}}))];
𝒲 = I H + Υ+Υ\[Transpose];
ℱ = - 2(Υ-Υ\[Transpose]);

Θ0 = Normal@If[CC==="ss",Chop@LyapunovSolve[𝒲,ℱ],CC];
 Φ=(1/4)ArrayFlatten[(({{γp.𝒜p+γm.𝒜m, I(γp.𝒜p-γm.𝒜m)}, {-I (γp.𝒜p-γm.𝒜m), γp.𝒜p+γm.𝒜m}}))];
𝒲 = 𝒲 -( Φ+Φ\[Transpose]);
ℱ = ℱ + Φ - Φ\[Transpose];
If[solver ==="NDSolve",
NDSolveValue[{
Θ'[t]==-(𝒲.Θ[t] + Θ[t].𝒲\[ConjugateTranspose]) + ℱ+Θ[t].(Φ-Φ\[Transpose]).Θ[t],
Θ[0]==Θ0},Θ,{t,0,tf}],
Interpolation@RK4[-(𝒲.# + #.𝒲\[ConjugateTranspose]) + ℱ+#.(Φ-Φ\[Transpose]).#&,Θ0,dt,tf]
]
)]
];

Clear[ConditionalFermionicNoJumpDistribution];
ConditionalFermionicNoJumpDistribution[H_,γ_,f_,{ηm_,ηp_},tf_,Δt_,𝒞_]:=Module[{λ,γp,γm,𝒜m,𝒜p,𝕀,Z0,ζ,Zt,Pno,L,W},
L=Length[ηm];
{W,γp} = BDMatrices[Eye[L],γ,f];
γm = W+W\[ConjugateTranspose]-γp;
𝕀 = Eye[L];
𝒜m = Normal@DiagonalMatrix[ηm];
𝒜p = Normal@DiagonalMatrix[ηp];

λ=If[L==Length@H,
Table[Tr[γp.𝒜p.(𝕀-𝒞[t]) + γm.𝒜m.𝒞[t]],{t,0,tf,Δt}],Table[Tr[γp.𝒜p.(𝕀-FermionsReducedC@𝒞[t]) + γm.𝒜m.FermionsReducedC@𝒞[t]],{t,0,tf,Δt}]
];
(*{Range[Δt,tf,Δt],Table[Exp[-Trapz[λ[[1;;j]],Δt]],{j,2,Length@λ}]}\[Transpose]//Chop*)
{Range[Δt,tf,Δt],Table[-Trapz[λ[[1;;j]],Δt],{j,2,Length@λ}]}\[Transpose]//Chop
]

Clear[ConditionalFermionicSteadyState];
ConditionalFermionicSteadyState[H_,γ_,f_,{ηm_,ηp_},pres_:MachinePrecision]:=Module[{a,γp,γm,W,𝒜p,𝒜m,L,Υ,𝒲,ℱ,Φ},
L=Length[ηm];
{W,γp} = BDMatrices[Eye[L],γ,f];
γm = W+W\[ConjugateTranspose]-γp;
𝒜m = Normal@DiagonalMatrix[ηm];
𝒜p = Normal@DiagonalMatrix[ηp];

If[L==Length@H,
W = I H + W;
(*RiccatiEigen[- W\[ConjugateTranspose]+γp.𝒜p, γp-γp.𝒜p, -(γm.𝒜m-γp.𝒜p)]*)
RiccatiSolve[{- W\[ConjugateTranspose]+γp.𝒜p,Chop@Sqrt[-(γm.𝒜m-γp.𝒜p)]},{ γp-γp.𝒜p,-NEye[L]} ]
,
Υ = (1/4)ArrayFlatten[(({{γp+γm, I(γp-γm)}, {-I (γp-γm), γp+γm}}))];
𝒲 = SetPrecision[I H + Υ+Υ\[Transpose],pres];
ℱ = SetPrecision[- 2(Υ-Υ\[Transpose]),pres];
 Φ=SetPrecision[(1/4)ArrayFlatten[(({{γp.𝒜p+γm.𝒜m, I(γp.𝒜p-γm.𝒜m)}, {-I (γp.𝒜p-γm.𝒜m), γp.𝒜p+γm.𝒜m}}))],pres];
(*RiccatiEigen[-𝒲\[ConjugateTranspose]+(Φ+Φ\[Transpose]),ℱ+Φ-Φ\[Transpose],-(Φ-Φ\[Transpose])]*)
RiccatiSolve[{-𝒲\[ConjugateTranspose]+(Φ+Φ\[Transpose]),Chop@Sqrt[-(Φ-Φ\[Transpose])]},{ℱ+Φ-Φ\[Transpose],kron[σx,NEye[L]]}]
]
]

Verification by comparing with full calculation

(* 2 sites *)

CM[ρ_]:=Chop@Table[Tr[cd[j].c[i].ρ],{i,2},{j,2}];

(* Full calculation using definitions *)
LoadFermionicOperators[2];
V = 1.;
H = cd[1].c[1] + cd[2].c[2] + V (cd[1].c[2]+cd[2].c[1]);
γ = 0.5;
f1 = 0.2;
f2 = 0.45;
ℒ = Liouvillian[H,{c[1],cd[1],c[2],cd[2]},{γ(1-f1),γ f1,γ(1-f2),γ f2}];
ρ = SteadyState[ℒ];
ηm = {0.8,0.65};
ηp = {0.4,0.9};
ℒ1 = γ(1-f1) ηm[[1]] JumpOp[c[1]] + γ f1 ηp[[1]] JumpOp[cd[1]]+ γ(1-f2) ηm[[2]] JumpOp[c[2]] + γ f2 ηp[[2]] JumpOp[cd[2]];
ℒ0 = ℒ-ℒ1;
ts = range[0,tf=20,0.1];
ρnos = Table[
tmp=Unvec@MatrixExp[ℒ0 t,Vec[ρ]];
tmp/Tr[tmp]
,{t,ts}];

Pno = Table[{t,Tr@Unvec@MatrixExp[ℒ0 t,Vec[ρ]]},{t,ts}];
𝒞 = Table[CM[ρ],{ρ,ρnos}]//Chop;

(* Result using our function implementations *)
{W,F} = BDMatrices[1,2,γ,{f1,f2}];
(*𝒞2=ConditionalLyapunov[W,F,ηm,ηp,tf];*)
𝒞2=ConditionalFermionicDynamics[TightBindingHamiltonian[2],γ,{f1,f2},{ηm,ηp},tf]
Pno2 = ConditionalFermionicNoJumpDistribution[TightBindingHamiltonian[2],γ,{f1,f2},{ηm,ηp},tf,0.1,𝒞2];

Show[
ListLinePlot[{ts,𝒞[[All,1,1]]}\[Transpose],PlotStyle->Red],
Plot[𝒞2[t][[1,1]],{t,0,tf},PlotStyle->Dashed]]

ListLinePlot[{Pno,Pno2},PlotStyle->{Red,Directive[Blue,Dashed]}]

tmp=cd[1].cd[2].c[2].c[1](*+cd[2].c[1]+cd[1].c[2]*)//mf;

(* Non-Gaussian state *)
(* Full calculation using definitions *)
LoadFermionicOperators[2];
V = 1.;
H = cd[1].c[1] + cd[2].c[2] + V (cd[1].c[2]+cd[2].c[1]);
γ = 0.5;
f1 = 0.2;
f2 = 0.45;
ℒ = Liouvillian[H,{c[1],cd[1],c[2],cd[2]},{γ(1-f1),γ f1,γ(1-f2),γ f2}];
(*ρ = c[1].SteadyState[ℒ].cd[1];
ρ = ρ/Tr[ρ];
*)
ρ =SteadyState[ℒ];
ρ = MatrixExp[I tmp].ρ.MatrixExp[-I tmp];
ρ = ρ/Tr[ρ];
(*S = RandomReal[{0,10},{4,4}];
ρ = ((S\[ConjugateTranspose].S)/(Tr[S\[ConjugateTranspose].S]));
*)
ηm = {0.8,0.65};
ηp = {0.4,0.9};
ℒ1 = γ(1-f1) ηm[[1]] JumpOp[c[1]] + γ f1 ηp[[1]] JumpOp[cd[1]]+ γ(1-f2) ηm[[2]] JumpOp[c[2]] + γ f2 ηp[[2]] JumpOp[cd[2]];
ℒ0 = ℒ-ℒ1;
ts = range[0,tf=20,0.1];
ρnos = Table[
tmp=Unvec@MatrixExp[ℒ0 t,Vec[ρ]];
tmp/Tr[tmp]
,{t,ts}];

Pno = Table[{t,Tr@Unvec@MatrixExp[ℒ0 t,Vec[ρ]]},{t,ts}];
𝒞 = Table[CM[ρ],{ρ,ρnos}]//Chop;

(* Result using our function implementations *)
{W,F} = BDMatrices[1,2,γ,{f1,f2}];
𝒞2=ConditionalLyapunov[W,F,ηm,ηp,tf,CM[ρ]];
Pno2 = GaussianNoJumpDistribution[W,F,ηm,ηp,tf,0.1,𝒞2];

Show[
ListLinePlot[{ts,𝒞[[All,1,1]]}\[Transpose],PlotStyle->Red],
Plot[𝒞2[t][[1,1]],{t,0,tf},PlotStyle->Dashed]]
Show[
ListLinePlot[{ts,𝒞[[All,2,2]]}\[Transpose],PlotStyle->Red],
Plot[𝒞2[t][[2,2]],{t,0,tf},PlotStyle->Dashed]]

ListLinePlot[{Pno,Pno2},PlotStyle->{Red,Directive[Blue,Dashed]},PlotRange->All]

Example usage

h = TightBindingHamiltonian[3,2.]/2//mf;
ηm = {1,0.5,1};
ηp = {0,0,1};
tf = 100;
𝒞=ConditionalFermionicDynamics[h,γ=0.6,{f1=0.3,fL=0.5},{ηm,ηp},tf];
𝒞ss = ConditionalFermionicSteadyState[h,γ=0.6,{f1=0.3,fL=0.5},{ηm,ηp}]
Plot[Diagonal[𝒞[t]],{t,0,tf},GridLines->{None,Re@Diagonal@𝒞ss}]

𝒞[tf]//mf;

Pno = ConditionalFermionicNoJumpDistribution[h,γ,{f1,fL},{ηm,ηp},tf,0.1,𝒞];
ListLinePlot[Pno,PlotRange->All]

Comparing no-pairing vs. pairing implementations

h = TightBindingHamiltonian[3,2.]/2;
ηm = {1,0.5,1};
ηp = {0,0,1};
tf = 100;
𝒞=ConditionalFermionicDynamics[h,γ=0.6,{f1=0.3,fL=0.5},{ηm,ηp},tf,"ss"];

𝒯 =MajoranaXY[L=3,-1.0,0.0];
tf = 100;
Θ=ConditionalFermionicDynamics[𝒯,γ=0.6,{f1=0.3,fL=0.5},{ηm,ηp},tf,"ss"];

𝒞[3.0]//mf;

FermionsReducedC@Θ[3.]//mf;

Plot[Diagonal[FermionsReducedC@Θ[t]],{t,0,tf}]

Pno1 = ConditionalFermionicNoJumpDistribution[h,γ,{f1,fL},{ηm,ηp},tf,0.1,𝒞];

Pno2 = ConditionalFermionicNoJumpDistribution[𝒯,γ,{f1,fL},{ηm,ηp},tf,0.1,Θ];

ListLinePlot[{Pno1,Pno2},PlotRange->All,PlotStyle->{Black,Directive[Red,Dashed]}]

ConditionalFermionicSteadyState[h,γ=0.6,{f1=0.3,fL=0.5},{ηm,ηp}]//mf;
ConditionalFermionicSteadyState[𝒯,γ=0.6,{f1=0.3,fL=0.5},{ηm,ηp}]//mf;
FermionsReducedC@ConditionalFermionicSteadyState[𝒯,γ=0.6,{f1=0.3,fL=0.5},{ηm,ηp}]//mf;

Example with pairing terms (XY model)

𝒯 =MajoranaXY[L=10,h0=0.0,κ=0.0];
ηm = ConstantArray[1,L];
ηp = ConstantArray[1,L];
tf = 290;
Θ1=ConditionalFermionicDynamics[𝒯,γ=0.8,{f1=0.3,fL=0.5},{ηm,ηp},tf];
Θ1ss=ConditionalFermionicSteadyState[𝒯,γ=0.1,{f1=0.3,fL=0.5},{ηm,ηp}];
(*Plot[Re@Diagonal[FermionsReducedC@Θ1[t]],{t,0,tf},PlotRange->All]*)
tab1 = Table[Re@Diagonal[FermionsReducedC@Θ1[t]],{t,0,tf,0.1}];
ListLinePlot[tab1\[Transpose],GridLines->{None,Re@Diagonal@FermionsReducedC@Θ1ss}]
Pno1 = ConditionalFermionicNoJumpDistribution[𝒯,γ,{f1,fL},{ηm,ηp},tf,0.05,Θ1];

𝒯 =MajoranaXY[L,0.0,0.9];
Θ2=ConditionalFermionicDynamics[𝒯,γ,{f1,fL},{ηm,ηp},tf,"ss"];
(*Plot[Re@Diagonal[FermionsReducedC@Θ2[t]],{t,0,tf},PlotRange->All]*)
tab2 = Table[Re@Diagonal[FermionsReducedC@Θ2[t]],{t,0,tf,0.1}];
ListLinePlot[tab2\[Transpose]]
Pno2 = ConditionalFermionicNoJumpDistribution[𝒯,γ,{f1,fL},{ηm,ηp},tf,0.05,Θ2];

Θ2ss=ConditionalFermionicSteadyState[𝒯,γ=0.1,{f1=0.3,fL=0.5},{ηm,ηp},40];
Re@Diagonal@FermionsReducedC@Θ2ss

ListLinePlot[{{#[[1]],#[[2]]/#[[1]]}&/@Pno1,{#[[1]],#[[2]]/#[[1]]}&/@Pno2},PlotRange->All]

𝒯 =MajoranaXY[L=10,h0=1.0,κ=0.9];
Θss=ConditionalFermionicSteadyState[𝒯,γ=0.1,{f1=0.3,fL=0.5},{ηm,ηp},40];
Re@Diagonal@FermionsReducedC@Θss

Comparison with the full monitoring expression from the PRB

h = TightBindingHamiltonian[3];
ηm = {1,1,1};
ηp = {1,1,1};
tf = 150;
𝒞=ConditionalFermionicDynamics[h,γ=0.1,{f1=0.3,fL=0.5},{ηm,ηp},tf];
Pno1 = GaussianNoJumpDistribution[h,γ,{f1,fL},{ηm,ηp},tf,0.1,𝒞];
{W,F}=BDMatrices[h,γ,{f1,fL}];
Pno2 = FermionicChainNoJump[W,F,Range[0,tf,0.02]];

ListLinePlot[{Pno1,{#[[1]],#[[2]] 0.95}&/@Pno2},PlotRange->All]

Dark states for a particle in a ring

L = 10;
h = TightBindingHamiltonianPBC[L];

(prob=Table[
{W,F} = BDMatrices[h,Basis[L,1],0];
𝒞 = ConditionalLyapunov[W,F,ηm=Basis[L,1],ηp=Basis[L,1],tf=100,𝒞0 = Proj[L,p,p]];
{p,1-GaussianNoJumpDistribution[W,F,ηm,ηp,tf,0.1,𝒞][[-1,2]]},{p,2,L}])//TableForm

ListLinePlot[prob]

Gaussian (Fermionic & Bosonic)

Gaussian bosonic systems

Syntax for the covariance matrix

All quantities are written for the operator ordering R = ((Subscript[q, 1]),(Subscript[p, 1]),(Subscript[q, 2]),(Subscript[p, 2])).
The covariance matrix is defined as 

σ = (({{⟨(Subscript[q, 1]^2)⟩, (1/2)⟨{(Subscript[q, 1]),(Subscript[p, 1])}⟩, ⟨(Subscript[q, 1])(Subscript[q, 2])⟩, ⟨(Subscript[q, 1])(Subscript[p, 2])⟩}, {(1/2)⟨{(Subscript[q, 1]),(Subscript[p, 1])}⟩, ⟨(Subscript[p, 1]^2)⟩, ⟨(Subscript[p, 1])(Subscript[q, 2])⟩, ⟨(Subscript[p, 1])(Subscript[p, 2])⟩}, {⟨(Subscript[q, 1])(Subscript[q, 2])⟩, ⟨(Subscript[p, 1])(Subscript[q, 2])⟩, ⟨(Subscript[q, 2]^2)⟩, (1/2)⟨{(Subscript[q, 2]),(Subscript[p, 2])}⟩}, {⟨(Subscript[q, 1])(Subscript[p, 2])⟩, ⟨(Subscript[p, 1])(Subscript[p, 2])⟩, (1/2)⟨{(Subscript[q, 2]),(Subscript[p, 2])}⟩, ⟨(Subscript[p, 2]^2)⟩}}))

The vacuum is 1/2. 
If your vacuum is 1, then call the functions with σ/2 instead; that is,

function(σ/2)

and so on.

Gaussian partial trace

Input is the list you wish to trace out

Clear[GPTr];
GPTr[σ_,list_]:=Module[{blist,clist,L = Length[σ]/2},

blist = Riffle[2list-1,2list];
clist = Complement[Range[1,2L],blist];
If[2Length@list==Length@σ,σ,σ[[clist,clist]]]
]

Example usage

(* CM for a 2-mode squeezed state of 1 and 2, plus an independent mode 3, with additional noise in mode 1 *)
Θ = (({{(1/2)+n+nth, 0, (Sqrt[n (1+n)]), 0, 0, 0}, {0, (1/2)+n+nth, 0, -(Sqrt[n (1+n)]), 0, 0}, {(Sqrt[n (1+n)]), 0, (1/2)+n, 0, 0, 0}, {0, -(Sqrt[n (1+n)]), 0, (1/2)+n, 0, 0}, {0, 0, 0, 0, (1/2)+n3, 0}, {0, 0, 0, 0, 0, (1/2)+n3}}));

(* Trace over mode 2 *)
GPTr[Θ,{2}]//mf;

(* Trace over mode 1 *)
GPTr[Θ,{1}]//mf;

(* Trace over modes 1 and 2 *)
GPTr[Θ,{1,2}]//mf;

Symplectic stuff, Bona fide, purity

BonaFide has to be ≥ 0 for a real state

Clear[SymplecticForm];
SymplecticForm[𝒩_]:=kron[Eye[𝒩],{{0,1},{-1,0}}];

Clear[SymplecticEigenvalues];
SymplecticEigenvalues[σ_]:=Module[{𝒩 = Length[σ]/2,Ω},
Ω = SymplecticForm[𝒩];
Chop@Drop[Sort@Quiet@Eigenvalues[N[I Ω.σ]],𝒩]
]

(* Valid CM should have BonaFide ≥ 0 *)
Clear[BonaFide];
BonaFide[σ_]:=Module[{Ω,𝒩 = Length[σ]/2},
Ω = SymplecticForm[𝒩];
First@Sort@Eigenvalues[N[σ+I Ω/2]]//Chop
]

(* Transforms from (a,a\[ConjugateTranspose]) to quadratures *)
Clear[ModeQuadratureRotation];
ModeQuadratureRotation[𝒩_]:=kron[Eye[𝒩],(1/(Sqrt[2]))(({{1, 1}, {-I, I}}))];

Clear[GaussianPurity]
GaussianPurity[σ_]:=(1/(Sqrt[Det[2σ]]));

Example usage

σ = (1/2)(({{(E^(2r)), 0}, {0, (E^(-2r))}}));

SymplecticEigenvalues[σ]

GaussianPurity[σ]

(* Symplectic form for 2 modes*)
Ω = SymplecticForm[2]//mf;

(* CM for a 2-mode squeezed state with additional noise in one of the modes only *)
Θ = (({{(1/2)+n+nth, 0, (Sqrt[n (1+n)]), 0}, {0, (1/2)+n+nth, 0, -(Sqrt[n (1+n)])}, {(Sqrt[n (1+n)]), 0, (1/2)+n, 0}, {0, -(Sqrt[n (1+n)]), 0, (1/2)+n}}));

GaussianPurity[Θ]//Simplify
%/.nth->0

(* For pure states (nth = 0) the symplectic eigenvalues are 1/2, same as the vacuum *)
SymplecticEigenvalues[Θ/.{n->0.8,nth->0}]

SymplecticEigenvalues[Θ/.{n->0.8,nth->0.3}]

Θ/.{n->0.8,nth->0}

(* Bona-fide is zero for pure states (nth = 0) *)
BonaFide[Θ/.{n->0.8,nth->0}]

(* It is positive for mixed states *)
BonaFide[Θ/.{n->0.8,nth->0.9}]

(* Transforms the CM written in terms of quadratures into the CM written in terms of (a,a\[ConjugateTranspose]) *)
L = ModeQuadratureRotation[2]//mf;

L.Θ.L\[ConjugateTranspose]//Simplify//mf;

Williamson’s theorem

Based on PhysRevA_79_052327
Williamson’s diagonalization: 

σ = SWSᵀ where 

-  W = diag((Subscript[ν, 1]),(Subscript[ν, 1]),(Subscript[ν, 2]),(Subscript[ν, 2]),...,(Subscript[ν, N]),(Subscript[ν, N]))  contains the symplectic eigenvalues

-  S is symplectic:  SΩSᵀ = Ω

The function outputs W, S as well as error the error in (Θ - SWSᵀ) and (Ω - SΩSᵀ)

Williamson[σ_]:=Module[{𝒩=Length[σ]/2,Ω,W,V,vals,vecs,list,perm,X,U,γ,Γ,S,P,error1,error2},
(*PhysRevA_79_052327*)
Ω=SymplecticForm[𝒩];
Γ = ModeQuadratureRotation[𝒩];
W =DiagonalMatrix@Abs@Eigenvalues[I Ω.σ];

V = MatrixPower[σ,-1/2];
X=V.Ω.V;
{vals,vecs}=Chop@Eigensystem[X];

list=I Reverse[ Abs@vals Table[(((-1))^i),{i,0,2𝒩-1}]];
perm=FindPermutation[vals,list];
U=Permute[vecs,perm]\[Transpose];
S=Inverse@((Sqrt[W]).(Γ.U\[ConjugateTranspose]).V);
error1 = Max@Flatten@Abs[S.W.S\[Transpose]-σ]//Chop;
error2 = Max@Flatten@Abs[S.Ω.S\[Transpose]-Ω]//Chop;
{W,Chop@S,{error1,error2}}
]

Example usage

σ = (1/2)(({{(E^(2r)), 0}, {0, (E^(-2r))}}))/.r->0.8;
{W,S,errors}=Williamson[σ];
errors
W//Diagonal
S//mf;

σ-S.W.S\[Transpose]//Chop//mf;

Θ = (({{0.6, 0.1}, {0.1, 0.99}}));
(* Check if the CM is valid *)
BonaFide[Θ]

{W,S,errors}=Williamson[Θ];
errors
W//Diagonal
S//mf;

(* A 3-mode CM *)
Θ = (({{(1/2)+n+nth, 0, (Sqrt[n (1+n)]), 0, 0, 0}, {0, (1/2)+n+nth, 0, -(Sqrt[n (1+n)]), 0, 0}, {(Sqrt[n (1+n)]), 0, (1/2)+n, 0, 0, 0}, {0, -(Sqrt[n (1+n)]), 0, (1/2)+n, 0, 0}, {0, 0, 0, 0, (1/2)+n3, 0}, {0, 0, 0, 0, 0, (1/2)+n3}}));

{W,S,errors}=Williamson[Θ/.{n->0.3,nth->0.9,n3->0.77}];
W//Diagonal
S//mf;
errors

von Neumann and Rényi entropy for Gaussian states

GaussianVonNeumann[σ_]:=Module[{h,g,𝒩=Length[σ]/2,Ω,νs},h[x_]:=If[x==0||x==1,0,x Log[x]];
g[x_]:=h[(x+1)/2]-h[(x-1)/2];
Ω=kron[Eye[𝒩],{{0,1},{-1,0}}];
(*νs=Chop@Drop[Sort@Quiet@Eigenvalues[I 2 Ω.σ],𝒩];*)
νs = 2 SymplecticEigenvalues[σ];
Total@Table[g[ν],{ν,νs}]//Chop
];

GaussianRenyiEntropy[σ_,α_]:=Module[{𝒩=Length[σ]/2,Ω,νs},
Ω=kron[Eye[𝒩],{{0,1},{-1,0}}];
(*νs=Chop@Drop[Sort@Quiet@Eigenvalues[I 2 Ω.σ],𝒩];*)
νs = 2 SymplecticEigenvalues[σ];
If[α==1,GaussianVonNeumann[σ],
(1/(α-1))Total@Table[Log[(((((ν+1)/2)))^α)-(((((ν-1)/2)))^α)],{ν,νs}]]

]

Example usage

σ = (1/2)(({{(E^(2 r)), 0}, {0, (E^(-2 r))}}))/.r->0.5;

GaussianVonNeumann[σ]//Simplify

Gaussian Mutual Information

GaussianMutualInformation[σ_,Alist_,Blist_]:=GaussianVonNeumann[GPTr[σ,Blist]]+GaussianVonNeumann[GPTr[σ,Alist]]-GaussianVonNeumann[σ]

GaussianMutualInformation[σ_,Alist_,Blist_,α_]:=GaussianRenyiEntropy[GPTr[σ,Blist],α]+GaussianRenyiEntropy[GPTr[σ,Alist],α]-GaussianRenyiEntropy[σ,α]

Quantum Negentropy: Measure of non-Gaussianity using the Kullback-Leibler divergence

Given an arbitrary state ρ, this function computes S(ρ||(Subscript[ρ, G])) where (Subscript[ρ, G]) is a Gaussian state with the same 1st and 2nd moments as ρ. 
Based on M. G. Genoni and M. G. A. Paris, Phys. Rev. A 82, 052341 (2010).

Here it is ony implemented for a single mode.

nGmeasure[ρ_]:=Module[{σ,𝒩,a,X,P},
𝒩= Length@ρ;
a = SparseArray@Table[(Sqrt[n])KroneckerDelta[m,n-1],{m,0,𝒩-1},{n,0,𝒩-1}];
X = (1/(Sqrt[2]))(a\[ConjugateTranspose]+a);
P = (I/(Sqrt[2]))(a\[ConjugateTranspose]-a);

σ = (({{Tr[ρ.X.X]-((Tr[ρ.X])^2), (1/2)Tr[ρ.(X.P+P.X)]-Tr[ρ.X] Tr[ρ.P]}, {(1/2)Tr[ρ.(X.P+P.X)]-Tr[ρ.X] Tr[ρ.P], Tr[ρ.P.P]-((Tr[ρ.P])^2)}}));
GaussianVonNeumann[σ]-vonNeumann[ρ]
]

Example Usage

Here is the ground-state of a non-Gaussian Hamiltonian

LoadBosonicOperators[30];
(* λ = 0 is Gaussian *)
λ = 0.0;
H = a\[ConjugateTranspose].a + (a+a\[ConjugateTranspose]).(a+a\[ConjugateTranspose])+ λ a\[ConjugateTranspose].a\[ConjugateTranspose].a.a;
ψ0 = First@Eigenvectors[H,-1];
nGmeasure[out[ψ0,ψ0]]

(* λ ≠ 0 is not *)
λ = 0.1;
H = a\[ConjugateTranspose].a + (a+a\[ConjugateTranspose]).(a+a\[ConjugateTranspose])+ λ a\[ConjugateTranspose].a\[ConjugateTranspose].a.a;
ψ0 = First@Eigenvectors[H,-1];
nGmeasure[out[ψ0,ψ0]]

λ = 0.2;
H = a\[ConjugateTranspose].a + (a+a\[ConjugateTranspose]).(a+a\[ConjugateTranspose])+ λ a\[ConjugateTranspose].a\[ConjugateTranspose].a.a;
ψ0 = First@Eigenvectors[H,-1];
nGmeasure[out[ψ0,ψ0]]

λ = 0.5;
H = a\[ConjugateTranspose].a + (a+a\[ConjugateTranspose]).(a+a\[ConjugateTranspose])+ λ a\[ConjugateTranspose].a\[ConjugateTranspose].a.a;
ψ0 = First@Eigenvectors[H,-1];
nGmeasure[out[ψ0,ψ0]]

Canonical form for 2-mode matrices

Any 2-mode CM of the form 

(Subscript[σ, AB])= (({{(Subscript[σ, A]), ξ}, {ξᵀ, (Subscript[σ, B])}}))

can be put, via local operations only, in canonical form

(Subscript[σ, AB]) = (({{a, 0, (SubPlus[c]), 0}, {0, a, 0, (SubMinus[c])}, {(SubPlus[c]), 0, b, 0}, {0, (SubMinus[c]), 0, b}}))

where, in order for (Subscript[σ, AB]) to be bona fide, one must have a,b > 1/2 and 

((a^2)-1/4)((b^2)-1/4)-(SubMinus[c])(SubPlus[c])/2 - a b((Subscript[c, -]^2)+(Subscript[c, +]^2)) + (Subscript[c, -]^2)(Subscript[c, +]^2) ≥ 0.

One also has the freedom to always choose (SubPlus[c])≥ |(SubMinus[c])| .

The function below returns the canonical form of a generic CM (Subscript[σ, AB]), as well as the symplectic matrix which does the job.

(* vacuum is 1/2 *)
TwoModeCanonicalForm[σ_]:=Module[{σA,σB,ξ,DA,VA,ZA,DB,VB,ZB,M,Σ,UA,UB,S,σcanon},
σA = σ[[1;;2,1;;2]];
σB = σ[[3;;4,3;;4]];
ξ = σ[[1;;2,3;;4]];

{DA,VA} = Eigensystem[σA];
VA = VA\[Transpose];
ZA = DiagonalMatrix[{(((DA[[2]]/DA[[1]]))^(1/4)),(((DA[[2]]/DA[[1]]))^(-1/4))}];

{DB,VB} = Eigensystem[σB];
VB = VB\[Transpose];
ZB = DiagonalMatrix[{(((DB[[2]]/DB[[1]]))^(1/4)),(((DB[[2]]/DB[[1]]))^(-1/4))}];

M= ZA.VA\[Transpose].ξ.VB.ZB\[Transpose];

(*{UA,ΣA,UB} = SingularValueDecomposition[ZA.VA\[Transpose].ξ.VB.ZB\[Transpose]];*)
(*UA = UA\[ConjugateTranspose]; *)
(*UB = UB\[ConjugateTranspose];*)

{Σ,UA} = Eigensystem[M.M\[Transpose]];
{Σ,UB} = Eigensystem[M\[Transpose].M];
S = ArrayFlatten[(({{UA.ZA.VA\[Transpose], 0}, {0, UB.ZB.VB\[Transpose]}}))];
σcanon = S.σ.S\[Transpose];
{σcanon,S}//Chop
]

Theory behind the function

Local operations mean, at the level of the CM, a local symplectic 

S = (({{(Subscript[S, A]), 0}, {0, (Subscript[S, B])}})).

The goal is to choose (Subscript[S, A]) and (Subscript[S, B]) such that 

(Subscript[Sσ, AB])Sᵀ = (Subscript[σ, AB]^canonical) 

Due to Euler’s theorem, the symplectic matrices (Subscript[S, A]) and (Subscript[S, B]) can always be decomposed as 

(Subscript[S, i]) = (Subscript[U, i])(Subscript[Z, i])(Subscript[V, i])ᵀ 

where (Subscript[U, i]),(Subscript[V, i]) are orthogonal matrices and (Subscript[Z, i ])= (({{(Subscript[z, i]), 0}, {0, (1/(Subscript[z, i]))}})). The goal is then to choose (Subscript[U, A]), (Subscript[Z, A]), (Subscript[V, A]), (Subscript[U, B]), (Subscript[Z, B]), (Subscript[V, B])

Choosing (Subscript[Z, i]) and (Subscript[V, i]):
First and foremost, (Subscript[S, A]) must be such that 

(Subscript[S, A])(Subscript[σ, A])(Subscript[S, A])ᵀ = (({{a, 0}, {0, a}})) 

Now consider the standard diagonalization of (Subscript[σ, A]):

(Subscript[σ, A])= (Subscript[O, A])(Subscript[D, A])(Subscript[O, A])ᵀ,               (Subscript[D, A]) = (({{(Subscript[d, A1]), 0}, {0, (Subscript[d, A2])}}))

We can solve the problem if we choose (Subscript[V, A]) = (Subscript[O, A]) and (Subscript[z, A]) = ((((Subscript[d, A2])/(Subscript[d, A1])))^(1/4)).
For any choice of (Subscript[U, A]), this will put (Subscript[σ, A]) in canonical form 

(Subscript[S, A])(Subscript[σ, A])(Subscript[S, A])ᵀ = (({{(Sqrt[(Subscript[d, A1])(Subscript[d, A2])]), 0}, {0, (Sqrt[(Subscript[d, A1])(Subscript[d, A2])])}})),                  so a = (Sqrt[(Subscript[d, A1])(Subscript[d, A2])])

Identical results hold for B.

Choosing (Subscript[U, i]):
Next we still have the freedom to choose (Subscript[U, A]) and (Subscript[U, B]). Note that 

(Subscript[Sσ, AB])Sᵀ = (({{(Subscript[S, A])(Subscript[σ, A])(Subscript[S, A]^( ᵀ)), (Subscript[S, A])ξ (Subscript[S, B]^( ᵀ))}, {(Subscript[S, B])ξᵀ(Subscript[S, A]^( ᵀ)), (Subscript[S, B])(Subscript[σ, B])(Subscript[S, B]^( ᵀ))}}))

We must therefore choose (Subscript[U, A]) and (Subscript[U, B]) such that (Subscript[S, A])ξ (Subscript[S, B]^( ᵀ)) = (({{(SubPlus[c]), 0}, {0, (SubMinus[c])}})) is a diagonal matrix. 
But 

(Subscript[S, A])ξ (Subscript[S, B]^( ᵀ))  = (Subscript[U, A]) ((Subscript[Z, A])(Subscript[V, A]^ᵀ)ξ (Subscript[V, B])(Subscript[Z, B]^( ᵀ))) (Subscript[U, B]^ᵀ)

We may thus choose (Subscript[U, A]) and (Subscript[U, B]) to be the singular value matrices of  the (non-Hermitian) matrix 

M=((Subscript[Z, A])(Subscript[V, A]^ᵀ)ξ (Subscript[V, B])(Subscript[Z, B]^( ᵀ))).

That is, we decompose 

M = (Subscript[U, A]^( ᵀ)) Σ (Subscript[U, B])

where Σ is a diagonal matrix containing the non-negative singular values. 
Note that 

MMᵀ = (Subscript[U, A]^†) (Σ^2)(Subscript[U, A])

so that (Subscript[U, A]^( ᵀ)) is also the eigenvector matrix of MMᵀ. Similarly, 

MᵀM = (Subscript[U, B]^( ᵀ)) (Σ^2) (Subscript[U, B]) 

so (Subscript[U, B]^( ᵀ)) is the eigenvector matrix of MᵀM.

Example usage

(* Construct a random covariance matrix *)
tmp = RandomReal[{0,1},{4,4}];
σ = tmp.tmp\[Transpose]+1.1 Eye[4]//mf;

mf/@({σcanon,S}=TwoModeCanonicalForm[σ]);

(* Local symplectics do not affect any correlations *)
{Det[σ],Det[σcanon]}

(* Transformation is indeed symplectic *)
ω=SymplecticForm[2];
S.ω.S\[Transpose]-ω//Chop//mf;

Gaussian entanglement of formation for 2 modes

Based on “10.1103/PhysRevA.69.052320”. 
Assumes vacuum is 1/2.

Returns Rényi-2 EoF, 

 (1/2)log|2(Subscript[σ, A])|
 
 and the optimal CM (Subscript[γ, p]), which minimizes any EoF monotone.

Clear[GaussianEoF];
GaussianEoF[σbare_]:=Module[{σ,θ,na,nb,kq,kp,L,Cp,Cq,X,sol,det1,det2,tab1,tab2,opt1,opt2,x0,x,θmin,detmin,Xmin,γp},
LoadPauliMatrices[];
σ = First@TwoModeCanonicalForm[2σbare]; (* Factor of 2 because the calculations are done with vacuum being 1.*)

na = σ[[1,1]];
nb = σ[[3,3]];
kq = σ[[1,3]];
kp = σ[[2,4]];

L = (({{1, 0, 0, 0}, {0, 0, 1, 0}, {0, 1, 0, 0}, {0, 0, 0, 1}}));
Cq = (({{na, kq}, {kq, nb}}));
Cp = (({{na, kp}, {kp, nb}}));
X = x0 σ0 + x Cos[θ] σz + x Sin[θ] σx;

sol=Quiet@Solve[{Det[Cq-X]==0,Det[X-Inverse[Cp]]==0},{x0,x}];
{det1,det2} = X[[1,1]] Inverse[X][[1,1]]/.sol//Simplify;

tab1 =Select[ Table[{θ,det1},{θ,linspace[(10^(-5)),π-(10^(-5)),1000]}],Im[#[[2]]]==0.&];
opt1=First@MinimalBy[tab1,Last];

tab2 =Select[ Table[{θ,det2},{θ,linspace[(10^(-5)),π-(10^(-5)),1000]}],Im[#[[2]]]==0&];
(*Print[tab2];*)
opt2=First@MinimalBy[tab2,Last];

(*Print[{opt1,opt2}];*)
If[opt1[[2]] < opt2[[2]],
(
{θmin,detmin} = opt1; 
Xmin = X/.sol[[1]]/.θ->θmin
),
(
{θmin,detmin} = opt2; 
Xmin = X/.sol[[2]]/.θ->θmin
)
];

γp = L\[Transpose].ArrayFlatten[(({{Xmin, 0}, {0, Inverse[Xmin]}}))].L//Chop;

{(1/2)Log[Abs@detmin](*detmin*),γp/2}//Chop
(* 1st term has no 2 inside det because we were working with 2σ*)
(* 2nd term is divided by 1/2 to get back to vacuum being 1/2 *)

]

Example usage

σ = (({{na, 0, kq, 0}, {0, na, 0, kp}, {kq, 0, nb, 0}, {0, kp, 0, nb}}))/.{na->.6,nb->.9,kq->0.35,kp->-0.05}//mf;
GaussianEoF[σ]

σ= (({{(1/2)+n+nth, 0, (Sqrt[n (1+n)]), 0}, {0, (1/2)+n+nth, 0, -(Sqrt[n (1+n)])}, {(Sqrt[n (1+n)]), 0, (1/2)+n, 0}, {0, -(Sqrt[n (1+n)]), 0, (1/2)+n}}))/.{n->1.};

GaussianEoF[σ/.nth->0.1]

tab=Table[{nnth,First@GaussianEoF[σ/.nth->nnth]},{nnth,0.05,1.5,0.1}]
ListLinePlot[%,PlotMarkers->Automatic]

Squeezed Thermal State

Squeezed thermal states are a bit tricky to implement numerically because (e^((z a†a†-z* a a)/2)) is not itself a trace-class operator (meaning if we take the matrix exponential, things explode).

The above implementation is both simple and numerically stable.

Input: Hilbert space size nmax, thermal occupation number 𝒩 and squeezing parameters (r,θ) (which appear in z = r (e^(i θ)))

Clear[SqueezedThermalState];
SqueezedThermalState[nmax_,𝒩_,r_,θ_:0]:=Module[{β,Z,b},
If[nmax>0,LoadBosonicOperators[nmax]];
β =Log[((1+𝒩)/𝒩)];
Z=((E^β)/(-1+(E^β)));
b = a Cosh[r] + a\[ConjugateTranspose] (E^(I θ))Sinh[r];
(1/Z)MatrixExp[-β b\[ConjugateTranspose].b]
]

(* Technical note: if input is nmax<0, the function will not load the bosonic operators. *)
(*This is useful when this function is being used within other calculations, which already used LoadBosonicOperators[nmax] *)

Example usage

ρ = SqueezedThermalState[nmax=200,𝒩=2.0,r=1.0,θ=0.0]

Tr[ρ.a\[ConjugateTranspose].a]//Chop
𝒩 Cosh[2r] + ((Sinh[r])^2)

One has to use a sufficiently large nmax in order to ensure convergence. 
Here is the same example, with nmax = 100. In this case there is a mismatch

ρ = SqueezedThermalState[nmax=100,𝒩=2.0,r=1.0,θ=0.0];
Tr[ρ.a\[ConjugateTranspose].a]//Chop
𝒩 Cosh[2r] + ((Sinh[r])^2)

The value of nmax that has to be used depends sensibly on 𝒩 and r.

Classical information and discord for 2 modes (experimental)

(* class corr von neumann *)
GaussianClassicalCorrelations[CM_]:=Module[{I1,I2,I3,I4,Δ,dm,h,f,dp,cc=2CM},
I1=Det[cc[[1;;2,1;;2]]];
I2=Det[cc[[3;;4,3;;4]]];
I3=Det[cc[[1;;2,3;;4]]];
I4=Det[cc[[1;;4,1;;4]]];

h[x_]:=If[x==0||x==1,0,x Log[x]];
f[x_]:=h[(x+1)/2]-h[(x-1)/2];


Return[{f[(Sqrt[I1])]-f[√If[(((-I1 I2+I4))^2)<(1+I2) (I3^2) (I1+I4),((2 (I3^2)+(I2-1) (I4-I1)+2 Abs[I3] (Sqrt[(I3^2)+(I2-1) (I4-I1)]))/(((I2-1))^2)),((I2 I1-(I3^2)+I4-(Sqrt[(I3^4)+(((I4-I2 I1))^2)-2 (I3^2) (I4+I2 I1)]))/(2 I2))]],f[(Sqrt[I2])]-f[√If[(((-I1 I2+I4))^2)<(1+I1) (I3^2) (I2+I4),((2 (I3^2)+(I1-1) (I4-I2)+2 Abs[I3] (Sqrt[(I3^2)+(I1-1) (I4-I2)]))/(((I1-1))^2)),((I2 I1-(I3^2)+I4-(Sqrt[(I3^4)+(((I4-I2 I1))^2)-2 (I3^2) (I4+I2 I1)]))/(2 I1))]]}]]

GaussianQuantumDiscord[CM_] := GaussianMutualInformation[CM,{1},{2}] - GaussianClassicalCorrelations[CM]

QFI and SLD for Gaussian states (applicable to very large systems)

Based on 1303.3682, but adapted slightly. 

The function GaussianQFI has been highly optimized and is now extremely efficient. 
An older, more “pedagogical” version, is kept below.

(* This is only a part of the SLD actually. It is the part called (L^((2))) in 1303.3682 *)
Clear[GaussianSLD]
GaussianSLD[σ_,dσ_]:=Module[{Ω},
Ω = SymplecticForm[Length[σ]/2];
Unvec@LinearSolve[2 kron[σ\[Transpose],σ] + (1/2)kron[Ω\[Transpose],Ω],Vec[dσ]]
]

GaussianQFI[σ_,dσ_]:=Module[{W,S,w,errors,Ω,M,vec,𝒟},
{W,S,errors}=Williamson[2*σ];
Ω = SymplecticForm[Length[W]/2];
M = Ω.S\[Transpose].Ω;
vec = Vec[M.dσ.(M^\[Transpose])];

w = SparseArray[W];
𝒟 = (1/2)(kron[w,w]-kron[Ω,Ω]);
vec\[Conjugate].LinearSolve[𝒟,vec]
]

GaussianQFI[σ_,dσ_,dμ_]:=dμ.LinearSolve[σ,dμ] + GaussianQFI[σ,dσ]

Example usage

σana = (({{(1/2)+n+nth, 0, Cos[θ](Sqrt[n (1+n)]), 0}, {0, (1/2)+n+nth, 0, -Sin[θ](Sqrt[n (1+n)])}, {Cos[θ](Sqrt[n (1+n)]), 0, (1/2)+n, 0}, {0, -Sin[θ](Sqrt[n (1+n)]), 0, (1/2)+n}}));

σ = σana/.{nth->0.96,n->1.1,θ->0.3}//mf;
dσ = D[σana,θ]/.{nth->0.66,n->1.1,θ->0.3}//mf;

GaussianSLD[σ,dσ]//mf;

GaussianQFI[σ,dσ]

Old version (pedagogical)

(* Pedagogical, but much slower *)
Clear[GaussianQFIpegagogical]
GaussianQFIpegagogical[σ_,dσ_]:=Module[{Ω,L},
Ω = SymplecticForm[Length[σ]/2];
L = GaussianSLD[σ,dσ];
Tr[L.dσ]
]

GaussianQFIpegagogical[σ,dσ]

Gaussian fermionic systems

C,S (L×L)  ↔  Θ (2L×2L)

FermionicFullCM[𝒞_,S_:0]:=Module[{L = Length[𝒞],vp={1,I},vm={1,-I}},
-kron[σy,Eye[L]] + kron[out[vp,vp],𝒞\[Transpose]]-kron[out[vm,vm],𝒞] +If[MatrixQ[S], kron[out[vm,vp],S]+kron[out[vp,vm],S\[ConjugateTranspose]],0]
]

(* Recovers the reduced (L×L) covariance matrix from the full (2L×2L) one *)
(* Still need to implement the local version *)
Clear[FermionsReducedC];
FermionsReducedC[Θ_,ord_:"global"]:=Module[{L=Length[Θ]/2},
If[ord==="global",
-(1/4)PTr[kron[(({{1, I}, {-I, 1}})),Eye[L]].(Θ+kron[σy,Eye[L]]),{1},{2,L}]]
];

Clear[FermionsReducedS];
FermionsReducedS[Θ_,ord_:"global"]:=Module[{L=Length[Θ]/2},
If[ord==="global",
(1/4)PTr[kron[(({{1, I}, {I, -1}})),Eye[L]].(Θ+kron[σy,Eye[L]]),{1},{2,L}]]
];

Example usage

Generate a random Fermionic state for 3 sites

LoadFermionicOperators[L=3,"global"];
tmp = RandomReal[{-10,10},{(2^L),(2^L)}]+I RandomReal[{-10,10},{(2^L),(2^L)}];
ρ = ((tmp\[ConjugateTranspose].tmp)/(Tr[tmp\[ConjugateTranspose].tmp]));

𝒞 = Table[Tr[cd[j].c[i].ρ],{i,L},{j,L}]//Chop//mf;
𝒮 = Table[Tr[c[i].c[j].ρ] ,{i,L},{j,L}]//Chop//mf;

Θ = (1/2) Table[Tr[(Γ[i].Γ[j]-Γ[j].Γ[i]).ρ] ,{i,2L},{j,2L}]//Chop//mf;

(* 𝒞,S -> Θ *)
Θ- FermionicFullCM[𝒞,𝒮]//mf;

(* Θ -> C,S *)
FermionsReducedC[Θ]-𝒞//mf;

FermionsReducedS[Θ]-𝒮//mf;

q[1] = out[vp,vp];
q[2] = out[vm,vm];
q[3] = out[vm,vp];
q[4] = out[vp,vm];

Table[Tr[q[i].q[j]],{i,4},{j,4}]//mf;

Residual correlator

(Subscript[Σ, l,m]) = ⟨(Subscript[σ, l]^z)(Subscript[σ, m]^z)⟩ - ⟨(Subscript[σ, l]^z)⟩⟨(Subscript[σ, m]^z)⟩

ResidualCorrelator[Θ_]:=Module[{𝒞 = FermionsReducedC[Θ],S = FermionsReducedS[Θ],𝕀 = Eye[Length[Θ]/2]},
4 (𝒞 𝕀-𝒞 𝒞\[Transpose]- S S\[ConjugateTranspose])]

(* Used to compute the residual correlator of 0805.2878 *)
ProzenMask[L_]:=SparseArray[{{i_,j_}/;Abs[i-j]>L/2->1},{L,L}];

Example usage

L=3;
M =  RandomReal[{-5,5},{2L,2L}];
M = I (M - M\[Transpose]);
LoadFermionicOperators[L,"global"]
ρ = MatrixExp[(1/4)Sum[M[[i,j]] Γ[i].Γ[j],{i,2L},{j,2L}]];
ρ = ρ/Tr[ρ];
𝕀 = Eye[2L];
4Table[Tr[cd[l].c[l].cd[m].c[m].ρ]-Tr[cd[l].c[l].ρ]Tr[cd[m].c[m].ρ],{l,L},{m,L}]//mf;

Θ = (1/2) Table[Tr[(Γ[i].Γ[j]-Γ[j].Γ[i]).ρ] ,{i,2L},{j,2L}]//Chop;
ResidualCorrelator[Θ]//mf;

Plotting & auxiliary functions

Plot styling & visualization functions

grid: makes a grid of plots with automatic ImagePadding and figure numbering

Clear[grid];
grid[plots_,nrows_:1,lettpos_:{0.92,0.9},tight_:True]:=Module[{i,p2,LettList,tab,pads,L,R,T,B,ncols,imgsize},

ncols = Length[plots]/nrows;
imgsize=Max/@Transpose@Table[ImageSize/.AbsoluteOptions[p,ImageSize],{p,plots}];
tab=Table[Flatten[ImagePadding/.AbsoluteOptions[p,ImagePadding]],{p,plots}];
{L,R,B,T}=tab\[Transpose];
B = Max[B];
T = Max[T];
R = Max[R];

If[tight===False,
L = ConstantArray[Max[L],Length@plots],
(L = Transpose@Partition[L,ncols];
L = Flatten@Transpose@Table[ConstantArray[Max[L[[i]]],nrows],{i,ncols}])];

LettList  = "("<>#<>")"&/@CharacterRange["a","z"];
p2 = Table[Show[plots[[i]],
ImageSize->{Automatic,imgsize[[2]]},
ImagePadding->{{L[[i]],R},{B,T}},
Epilog->Text[LettList[[i]],Scaled[lettpos]]
],{i,Length@plots}];
Grid@PartitionIn[p2,nrows]
]

Example usage

p1 = Plot[Sin[x],{x,0,10}];
p2 = Plot[Tan[x],{x,-10,10},PlotRange->All,FrameLabel->{"x","y"}];
p3 = Plot[Exp[x],{x,-10,80},PlotRange->All,FrameLabel->{"x","y"}];
p4 = Plot[Sec[x],{x,0,1},PlotRange->All];

If we try to make a standard grid, the figure sizes become super ugly

Grid[{{p1,p2},{p3,p4}}]

“grid” fixes this

grid[{p1,p2,p3,p4},2]

Make plots in a single row:

grid[{p1,p2,p3,p4}]
(* Same as grid[{p1,p2,p3,p4},1] *)

Change the position of the legends. Default is (0.92,0.9). 
Positions should be scaled from 0 to 1

(* This puts (a),(b),(c),(d) on the left *)
grid[{p1,p2,p3,p4},2,{0.1,0.9}]

By default, y axes are tight

grid[{p1,p2,p3,p4},2,{0.92,0.9},True]

Make them tight (2nd col is pushed more towards the left)

grid[{p1,p2,p3,p4},2,{0.92,0.9},False]

RandomChoice[{0,10}]

Plot[Exp[-10x],{x,0,2}]

plots=Table[Plot[Evaluate@Exp[RandomChoice[{-10,10}]x],{x,0,2},ImageSize->120],{24}];

grid[plots,4]

Default styling for graphs

I prefer framed plots, for instance. 
The function below loads this and other basic plot styling options for most relevant plots.

LoadPlotStyling[]:=Module[{},
Clear[LettList,blue,blue2,blue3,navy,yellow,purple,purple2,green,red,orange,Custom,opts];

(*LettList  = "("<>#<>")"&/@CharacterRange["a","z"];*)
blue = RGBColor[0.368417, 0.506779, 0.709798];
blue2 = RGBColor[(68/256),(151/256),(151/256)];
blue3 = RGBColor[(205/256),(205/256),(222/256)];
navy = RGBColor[{65,97,150}/255];

yellow=RGBColor[1, 0.75, 0];
purple = RGBColor[{158,137,183}/255];
purple2 = RGBColor[(158/256),(67/256),(149/256)];
green = Darker[RGBColor[{123,216,187}/255],.1];
red=RGBColor[{238,105,105}/255];
orange = RGBColor[(224/256),(148/256),(57/256)];
graphite = RGBColor[{95,95,95}/255];

(*nicePalette={Black,purple,navy,green,graphite,red};*)

opts = {
BaseStyle->{FontFamily->"Times",17},
PlotStyle->Automatic,
Axes->False,
ImageSize->330,
GridLinesStyle->Directive[Black,Dashed],
PlotRangePadding->None,
Frame->True,
FrameStyle->Black,
FrameTicksStyle->{FontFamily->"Times"(*,Black*)}
};
SetOptions[ListLinePlot,opts];
SetOptions[ListPlot,opts];
SetOptions[ListLogPlot,opts];
SetOptions[ListLogLinearPlot,opts];
SetOptions[ListLogLogPlot,opts];
SetOptions[Plot,opts];
SetOptions[LogPlot,opts];
SetOptions[LogLinearPlot,opts];
SetOptions[LogLogPlot,opts];
SetOptions[ParametricPlot,opts];
SetOptions[DiscretePlot,opts];
(*SetOptions[Graphics,opts];*)
];

legend: A nicer plot legend

Easier to call and prettier.

Clear[legend];
legend[labels_,pos_,OptionsPattern[{
FontSize->16,
LegendMarkerSize->20,
LegendLayout->"Column",
framed->True,
BackgroundColor->Gray,
FrameColor->Gray
}]]:=Placed[LineLegend[Automatic,labels,
LabelStyle->{
FontFamily->"Times",
FontSize->OptionValue[FontSize]},
LegendLayout->OptionValue[LegendLayout],
LegendMarkerSize->{OptionValue[LegendMarkerSize],2},LegendFunction->If[OptionValue[framed],(Framed[#,RoundingRadius->4,FrameStyle->OptionValue[FrameColor],Background->Lighter[OptionValue[BackgroundColor],0.9]]&),None]],Scaled[pos]]

Clear[pointlegend];
pointlegend[labels_,pos_,OptionsPattern[{
FontSize->16,
LegendMarkerSize->10,
LegendLayout->"Column",
BackgroundColor->Gray,
FrameColor->Gray
}]]:=Placed[PointLegend[Automatic,labels,
LabelStyle->{
FontFamily->"Times",
FontSize->OptionValue[FontSize]},
Joined->False,
LegendLayout->OptionValue[LegendLayout],
LegendMarkerSize->OptionValue[LegendMarkerSize],LegendFunction->(Framed[#,RoundingRadius->4,FrameStyle->OptionValue[FrameColor],Background->Lighter[OptionValue[BackgroundColor],0.9]]&)],Scaled[pos]]

Example usage

1st argument is the list of labels.
2nd is position, in scaled coordinates; i.e., x,y ∈ [0,1]

Plot[{(x^2),(x^3),(x^4)},{x,-1,1},
PlotLegends->legend[{"(x^2)","(x^3)","(x^4)"},{0.87,0.3}]]

Optional arguments: FontSize, LegendLayout and LegendMarkerSize.

Plot[{(x^2),(x^3),(x^4)},{x,-1,1},
PlotLegends->legend[{"(x^2)","(x^3)","(x^4)"},{0.87,0.3},FontSize->10]]

LegendMarkerSize modifies the size of the dashed lines.

Plot[{(x^2),(x^3),(x^4)},{x,-1,1},
PlotLegends->legend[{"(x^2)","(x^3)","(x^4)"},{0.87,0.3},LegendMarkerSize->10]]

Plot[{(x^2),(x^3),(x^4)},{x,-1,1},
PlotLegends->legend[{"(x^2)","(x^3)","(x^4)"},{0.57,0.3},LegendLayout->"Row"]]

The specific number of rows or columns can also be specified

Plot[Evaluate@Table[(x^n),{n,1,10}],{x,-1,1},
PlotLegends->legend[Range[1,10],{0.55,0.2},LegendLayout->{"Row",2}]]

Plot[{(x^2),(x^3)},{x,-1,1},
PlotLegends->legend[{"(x^2)","(x^3)"},{0.87,0.3}]]

Ticks for logscale plots (somewhat crappy)

Mathematica has horrible labels for logscale plots, because it mixes (10^5) with 10000, and so on.. 
This provides a way to build better scale and ticks.
There is a package called CustomTicks, which also does this, in a more professional way.

Syntax: logsticks[i,f,δ] makes ticks from (10^i) to (10^f) in steps of (10^δ)

(* Ticks for logscale plots *)
(* Output appropriate for functions like FrameTicks or Ticks *)
(*logticks[i_,f_,δ_,log_:False]:=
Table[{k,Superscript["10",ToString[k]]},{k,i,f,δ}] *)

Clear[logticks];
logticks[i_,f_,δ_,ts_:0.8,label_:1]:=
Flatten[Table[{
{(10^k),If[label==1,Superscript["10",ToString[k]],""],ts{0.026,0}},
{0.9 (10^k),"",ts{0.012,0}},
{0.8 (10^k),"",ts{0.011,0}},
{0.7 (10^k),"",ts{0.010,0}},
{0.6 (10^k),"",ts{0.009,0}},
{0.5 (10^k),"",ts{0.008,0}},
{0.4 (10^k),"",ts{0.007,0}},
{0.3 (10^k),"",ts{0.006,0}},
{0.2 (10^k),"",ts{0.005,0}}
},{k,i,f,δ}],1]

(* Experimental: does the same for linear ticks *)
Clear[linticks];
linticks[i_,f_,δ_,sub_:4,ts_:0.8,label_:1]:=
Flatten[Table[
Join[
{{k,If[label==1,ToString[k],""],ts{0.026,0}}},
Table[{N[(n/sub)δ +k],"",ts{0.012,0}},{n,1,sub}]
]
,{k,i,f,δ}],1]

Example usage

Notice how (10^6) is mixed with 1000. 
In scientific publications, this is often not even accepted.

LogLogPlot[x^2+x^3,{x,1,100}]

logticks solves this

LogLogPlot[x^2+x^3,{x,1,100},FrameTicks->{{logticks[1,6,1],None},{logticks[0,2,1],None}}]

LogLogPlot[x^2+x^3,{x,1,100},Ticks->{Automatic,logticks[1,6,2]}]

The output of loglist is just an ugly list of ticks and labels

logticks[1,3,1]

Rasterize plots to reduce the size of the notebook

Notebooks with too many plots can become quite large. Use this to create lower definition images on the plots.

rasta[plot_,res_:100,sz_:400]:=Rasterize[plot,ImageResolution->res,ImageSize->sz];

Example usage

The plot below has a huge number of datapoints, and would be quite heavy without “rasta”

plot=ArrayPlot[Table[Sin[x y],{x,-400,400},{y,-400,400}]];

ByteCount[plot]

rasta@plot

(* Takes only 5% of the space *)
((ByteCount[rasta@plot])/(ByteCount[plot]))//N

Drawing  Bloch’s Sphere

BlochSphere[labels_:True]:=Module[{splineCircle,pointsAndConnection,surroundingCircles,texKet},
(*Needs["MaTeX`"];*)

splineCircle[m_List,r_,angles_List: {0,2 π}]:=Module[{seg,ϕ,start,end,pts,w,k},{start,end}=Mod[angles//N,2 π];
If[end≤start,end+=2 π];
seg=Quotient[end-start//N,π/2];
ϕ=Mod[end-start//N,π/2];
If[seg==4,seg=3;ϕ=π/2];
pts=r RotationMatrix[start].#&/@Join[Take[{{1,0},{1,1},{0,1},{-1,1},{-1,0},{-1,-1},{0,-1}},2 seg+1],RotationMatrix[seg π/2].#&/@{{1,Tan[ϕ/2]},{Cos[ϕ],Sin[ϕ]}}];
If[Length[m]==2,pts=m+#&/@pts,pts=m+#&/@Transpose[Append[Transpose[pts],ConstantArray[0,Length[pts]]]]];
w=Join[Take[{1,1/Sqrt[2],1,1/Sqrt[2],1,1/Sqrt[2],1},2 seg+1],{Cos[ϕ/2],1}];
k=Join[{0,0,0},Riffle[#,#]&@Range[seg+1],{seg+1}];
BSplineCurve[pts,SplineDegree->2,SplineKnots->k,SplineWeights->w]]/;Length[m]==2||Length[m]==3;

pointsAndConnection[points_]:=Sequence@@{Sequence@@Point/@#,Line@#}&@points;

surroundingCircles=GeometricTransformation[splineCircle[{0,0,0},1],{{RotationMatrix[0,{1,0,0}],{0,0,0}},{RotationMatrix[Pi/2,{1,0,0}],{0,0,0}},{RotationMatrix[Pi/2,{0,1,0}],{0,0,0}}}];

texKet[n_]:=Text@Style[StringTemplate["\!\(\*TemplateBox[{\"`1`\"},\n\"Ket\"]\)"][ToString@n] ,FontFamily->"Times",20];

Graphics3D[{White,Opacity@0.3,Sphere[{0,0,0},1],Opacity@1,Thickness@0.004,PointSize@0.02,Red,pointsAndConnection@{{0,0,1},{0,0,-1}},Blue,pointsAndConnection@{{1,0,0},{-1,0,0}},Darker@Green,pointsAndConnection@{{0,1,0},{0,-1,0}},Black,Point[{0,0,0}],
If[labels==True,
{Text[texKet[0],{0,0,1.2}],Text[texKet[1],{0,0,-1.2}],Text[texKet["+"],{1.2,0,0}],Text[texKet["-"],{-1.2,0,0}],Text[texKet["L"],{0,1.2,0}],Text[texKet["R"],{0,-1.2,0}]}],Gray,Thin,surroundingCircles},Boxed->False,PlotRange->ConstantArray[{-1.2,1.2},3],ImageSize->500,RotationAction->"Clip"]
]

Example usage

BlochSphere[]

BlochSphere[False]

Clear[ψ0,ρ,γ,f];
ψ0={Cos[(π/8)],Exp[I (π/4)]Sin[(π/8)]};
γ=0.1;
f=0.3;
sol=First@NDSolve[
{D[ρ[t],t]==-(I/2)(σz.ρ[t]-ρ[t].σz)+ γ(1-f)Lindbladian[σm][ρ[t]]+γ f Lindbladian[σp][ρ[t]],ρ[0]==out[ψ0,ψ0]},ρ,{t,0,tf=1000}];

s[ρ_]:=Chop@2{((ρ[[2,1]]+ρ[[1,2]])/2),((ρ[[2,1]]-ρ[[1,2]])/(2I)), ρ[[1,1]]-(1/2)}
Show[BlochSphere[],Graphics3D[{Black,Thickness[Medium],Line[Chop@Table[s[(ρ/.sol)[t]],{t,0,100,0.1}]]}]]

Clear[s,ψ0,ρ,γ,n,f,sol]

Original code also  containing  tools for drawing angles and states (not as initialization cells)

Needs["MaTeX`"]
ClearAll[splineCircle];
splineCircle[m_List,r_,angles_List: {0,2 π}]:=Module[{seg,ϕ,start,end,pts,w,k},{start,end}=Mod[angles//N,2 π];
If[end≤start,end+=2 π];
seg=Quotient[end-start//N,π/2];
ϕ=Mod[end-start//N,π/2];
If[seg==4,seg=3;ϕ=π/2];
pts=r RotationMatrix[start].#&/@Join[Take[{{1,0},{1,1},{0,1},{-1,1},{-1,0},{-1,-1},{0,-1}},2 seg+1],RotationMatrix[seg π/2].#&/@{{1,Tan[ϕ/2]},{Cos[ϕ],Sin[ϕ]}}];
If[Length[m]==2,pts=m+#&/@pts,pts=m+#&/@Transpose[Append[Transpose[pts],ConstantArray[0,Length[pts]]]]];
w=Join[Take[{1,1/Sqrt[2],1,1/Sqrt[2],1,1/Sqrt[2],1},2 seg+1],{Cos[ϕ/2],1}];
k=Join[{0,0,0},Riffle[#,#]&@Range[seg+1],{seg+1}];
BSplineCurve[pts,SplineDegree->2,SplineKnots->k,SplineWeights->w]]/;Length[m]==2||Length[m]==3

ClearAll@qubitPrettyPrint;
Options[qubitPrettyPrint]={normalized->False,magnification->2,prefix->""};

qubitPrettyPrint[c1_,c2_,OptionsPattern[]]:=If[!TrueQ@OptionValue@normalized,MaTeX[StringTemplate["`3`\\left(`1`\\right)\\left|0\\right\\rangle + \\left(`2`\\right)\\left|1\\right\\rangle"][ToString@TeXForm[c1],ToString@TeXForm[c2],ToString@OptionValue@prefix],Magnification->OptionValue@magnification],With[{nCoefficients=Normalize[{c1,c2}]},MaTeX[StringTemplate["`3`\\left(`1`\\right)\\left|0\\right\\rangle + \\left(`2`\\right)\\left|1\\right\\rangle"][Sequence@@(ToString@*TeXForm/@nCoefficients),ToString@OptionValue@prefix],Magnification->OptionValue@magnification]]]

printStateFromPoint[pt_,useMatex_: True]:=If[TrueQ@useMatex,Panel@qubitPrettyPrint[With[{θ=ArcCos[pt[[3]]],ϕ=ArcTan[If[pt[[1]]==0,0,pt[[2]]/pt[[1]]]]},Sequence@@{Cos[θ/2],Exp[I ϕ] Sin[θ/2]}],prefix->"\\left| \\psi \\right\\rangle = ",magnification->1.6],Panel@With[{θ=ArcCos[pt[[3]]],ϕ=ArcTan[If[pt[[1]]==0,0,pt[[2]]/pt[[1]]]]},Style["\!\(\*TemplateBox[{\"ψ\"},\n\"Ket\"]\) = "~~ToString@Cos[θ/2]~~"\!\(\*TemplateBox[{\"0\"},\n\"Ket\"]\) + ("~~ToString[Exp[I ϕ] Sin[θ/2]]~~") \!\(\*TemplateBox[{\"1\"},\n\"Ket\"]\)",texStyle]]]

pointsAndConnection[points_]:=Sequence@@{Sequence@@Point/@#,Line@#}&@points

surroundingCircles=GeometricTransformation[splineCircle[{0,0,0},1],{{RotationMatrix[0,{1,0,0}],{0,0,0}},{RotationMatrix[Pi/2,{1,0,0}],{0,0,0}},{RotationMatrix[Pi/2,{0,1,0}],{0,0,0}}}];

ClearAll@texKet;
texKet[n_,magnification_: 2,useMatex_: True]:=If[TrueQ@useMatex,MaTeX["\\left|"~~ToString@n~~"\\right\\rangle",Magnification->magnification],Text@Style[StringTemplate["\!\(\*TemplateBox[{\"`1`\"},\n\"Ket\"]\)"][ToString@n] ,texStyle]]


blochSphere=Graphics3D[{White,Opacity@0.3,Sphere[{0,0,0},1],Opacity@1,Thickness@0.004,PointSize@0.02,Red,pointsAndConnection@{{0,0,1},{0,0,-1}},Blue,pointsAndConnection@{{1,0,0},{-1,0,0}},Darker@Green,pointsAndConnection@{{0,1,0},{0,-1,0}},Black,Point[{0,0,0}],Text[texKet[0],{0,0,1.2}],Text[texKet[1],{0,0,-1.2}],Text[texKet["+"],{1.2,0,0}],Text[texKet["-"],{-1.2,0,0}],Text[texKet["L"],{0,1.2,0}],Text[texKet["R"],{0,-1.2,0}],Gray,Thin,surroundingCircles},Boxed->False,PlotRange->ConstantArray[{-1,1},3],ImageSize->500,RotationAction->"Clip"];

ClearAll@intersectionsWithSphere
intersectionsWithSphere[pt1_,pt2_]:=With[{p=Norm[pt1],q=Norm[pt2],c=Cos@VectorAngle[pt1,pt2]},{(-p^2+c p q-Sqrt[p^2-2 c p q+q^2-p^2 q^2+c^2 p^2 q^2])/(-p^2+2 c p q-q^2),(-p^2+c p q+Sqrt[p^2-2 c p q+q^2-p^2 q^2+c^2 p^2 q^2])/(-p^2+2 c p q-q^2)}]
intersectionsWithSphere[{pt1_,pt2_}]:=intersectionsWithSphere[pt1,pt2]

drawThetaAngle[pt_]:=With[{θ=VectorAngle[{0,0,1},pt],θ2=VectorAngle[{pt[[1]],pt[[2]],0},pt],ϕ=VectorAngle[{1,0,0},{pt[[1]],pt[[2]],0}]},Function[plot,GeometricTransformation[plot,RotationMatrix[#,{0,0,1}]&@If[pt[[2]]>0,ϕ,-ϕ].RotationMatrix[Pi/2,{1,0,0}].RotationMatrix[#,{0,0,1}]&@If[pt[[3]]<0,-θ2,θ2,0]]]/@{splineCircle[{0,0,0},.2,{0,θ}],RevolutionPlot3D[0,{t,0,.2},{theta,0,θ},Mesh->None,PlotStyle->Directive[Yellow]][[1]]}]
drawPhiAngle[pt_]:=With[{ϕ=VectorAngle[{1,0,0},{pt[[1]],pt[[2]],0}]},{splineCircle[{0,0,0},.2,{0,#}],RevolutionPlot3D[0,{t,0,.2},{θ,0,#},Mesh->None,PlotStyle->Directive[Cyan]][[1]]}&@If[pt[[2]]>0,ϕ,2 Pi-ϕ]]

DynamicModule[{pt={0,1/Sqrt[2]//N,1/Sqrt[2]//N}},Row[{EventHandler[Show[blochSphere,Graphics3D[Dynamic@{Opacity@1,PointSize@0.02,Point@pt,Dashed,Thin,Purple,Line@{{0,0,0},pt,{pt[[1]],pt[[2]],0},{0,0,0}},Dashing[{}],Thickness@0.004,Red,drawThetaAngle[pt],Dashing[{}],Thickness@0.004,Blue,Sequence@@drawPhiAngle[pt]}](*,RotationAction->"Clip"*)],{"MouseClicked":>(Module[{p1,p2},{p1,p2}=MousePosition["Graphics3DBoxIntercepts"];
With[{newPt=(1-λ) p1+λ p2/.λ->intersectionsWithSphere[p1,p2][[2]]},If[Norm[newPt]==1,pt=newPt]]])},PassEventsDown->True],Dynamic@printStateFromPoint[pt]}]]

Colors

ColorData[12,"ColorList"]

Table[ColorData[n,"ColorList"],{n,1,30}]//TableForm

Clear[COLORLIST];
COLORLIST=Join[ColorData[3,"ColorList"][[{1,2,4,6,8,9}]],ColorData[7,"ColorList"][[{-1}]],ColorData[4,"ColorList"][[{6}]],ColorData[3,"ColorList"][[{5}]],ColorData[17,"ColorList"][[{-1}]]]

Length@COLORLIST

Plot[Evaluate@Table[Sin[n x],{n,1,Length@COLORLIST}],{x,0,π/2},PlotStyle->COLORLIST]

Auxiliary functions

Print all variables defined in a given Kernel (excluding functions)

(* Can also be adapted to show all defined functions *)
Clear[ListAllVariables]
ListAllVariables[]:=Module[{names = Names["Global`*"],variables,functions},
variables = Select[names,ToExpression[#,StandardForm,Function[sym,OwnValues[sym]=!={},HoldAll]]&];
functions = Complement[names,variables];
(*{variables,functions}*)
variables
]

ListAllVariables[]

matchString: matches two strings even if they are a bit different

(* Matches two strings even if they are just a little bit different *)

matchString[str1_,str2_]:=StringMatchQ[str1,str2,SpellingCorrection->True]

Example usage

matchString["Homodyne","homodyne"]

matchString["Homodyne","Hmodyne"]

matchString["Homodyne","Homodne"]

matchString["Homodyne","Homodyn"]

matchString["Homodyne","Hmodyn"]

matchString[{"Discrete","Oi"},"discrete"]

Cheat sheet

Plot axes with arrows

Ticks->None,
Frame->False,
Axes->True,
AxesStyle->Directive[Arrowheads[0.05],Black],
PlotRangePadding->Scaled[.05]

Inset plot

ImageSize->110,
AspectRatio->1,
PlotStyle->Black,
(*Ticks->None,*)
Frame->False,
Axes->True,
AxesStyle->Directive[Arrowheads[0.08],Black],
AxesLabel->{"x","y"},
PlotRangePadding->Scaled[.05]

ExponentialSearch: roots of monotonic functions

ExponentialSearch is a very good algorithm for finding the root of functions which are known to be monotonically increasing.

Since it is not compiled, it is not necessarily faster than FindRoot. 
But I put it here since it is not difficult to make a Compiled version for specific applications.

(* Algorithm for finding the roots of a function which is monotonically increasing in x *)
ExponentialSearch[f_,xx0_,tol_:(10^(-3.0)),ΔΔx_:0.1]:=Module[{x0=xx0,Δx=ΔΔx,x1,f0,f1,c,fc,entrou=False},
f0 = f[x0];
x1 = x0-Sign[f0] Δx;
f1 = f[x1];
While[f0 f1>0,(Δx=2Δx;entrou = True;x1 = x0-Sign[f0] Δx;f1 = f[x1])];

x0=If[entrou==True,x1+Sign[f0] Δx/2,x0];
f0 = f[x0];
While[
Abs[f1-f0]>tol,(
c = (x0+x1)/2.0;
fc = f[c];
If[f0 fc <0,(x1=c; f1=fc),(x0=c; f0=fc)];
)];
c
]

Example usage

Clear[f];
f[x_]:=Exp[x]-3;
Plot[f[x],{x,0,2}]

AbsoluteTiming[FindRoot[f[x],{x,1}]]

AbsoluteTiming[ExponentialSearch[f,1]]

TwoAxes plot

This functionality is now built-in version 13. 
But I still prefer this more rudimentary way. 
One can also change ListLinePlot to Plot, and configure the whole thing at will.

TwoAxisListLinePlot[{f_,g_}]:=Module[{fgraph,ggraph,frange,grange,fticks,gticks},{fgraph,ggraph}=MapIndexed[ListLinePlot[#,Axes->True,PlotStyle->COLORLIST[[#2[[1]]]]]&,{f,g}];{frange,grange}=(PlotRange/. AbsoluteOptions[#,PlotRange])[[2]]&/@{fgraph,ggraph};fticks=N@FindDivisions[frange,5];
gticks=Quiet@Transpose@{fticks,ToString[NumberForm[#,2],StandardForm]&/@Rescale[fticks,frange,grange]};
Show[fgraph,ggraph/. Graphics[graph_,s___]:>Graphics[GeometricTransformation[graph,RescalingTransform[{{0,1},grange},{{0,1},frange}]],s],Axes->False,Frame->True,FrameStyle->{COLORLIST[[{1,2}]](*ColorData[1]/@{1,2}*),{Automatic,Automatic}},FrameTicks->{{fticks,gticks},{Automatic,Automatic}}]]

Density plot with control over negative and positive values

First define zmax and zmin. Then

func=Function[z,If[z>0,
ColorData["TemperatureMap"][Rescale[z,{0,zmax},{1/2,1}]],
ColorData["TemperatureMap"][Rescale[z,{zmin,0},{0,0.5}]]]]

ListDensityPlot[tab,
ColorFunction->func,
ColorFunctionScaling->False,
PlotLegends->Automatic
]

xkcd plots

xkcdStyle={FontFamily->"Comic Sans MS",16};

xkcdLabel[{str_,{x1_,y1_},{xo_,yo_}}]:=Module[{x2,y2},x2=x1+xo;y2=y1+yo;
{Inset[Style[str,xkcdStyle],{x2,y2},{1.2 Sign[x1-x2],Sign[y1-y2] Boole[x1==x2]}],Thick,BezierCurve[{{0.9 x1+0.1 x2,0.9 y1+0.1 y2},{x1,y2},{x2,y2}}]}];

xkcdRules={EdgeForm[ef:Except[None]]:>EdgeForm[Flatten@{ef,Thick,Black}],Style[x_,st_]:>Style[x,xkcdStyle],Pane[s_String]:>Pane[Style[s,xkcdStyle]],{h_Hue,l_Line}:>{Thickness[0.02],White,l,Thick,h,l},Grid[{{g_Graphics,s_String}}]:>Grid[{{g,Style[s,xkcdStyle]}}],Rule[PlotLabel,lab_]:>Rule[PlotLabel,Style[lab,xkcdStyle]]};

xkcdShow[p_]:=Show[p,AxesStyle->Thick,LabelStyle->xkcdStyle]/.xkcdRules

xkcdShow[Labeled[p_,rest__]]:=Labeled[Show[p,AxesStyle->Thick,LabelStyle->xkcdStyle],rest]/.xkcdRules

xkcdDistort[p_]:=Module[{r,ix,iy},r=ImagePad[Rasterize@p,10,Padding->White];
{ix,iy}=Table[RandomImage[{-1,1},ImageDimensions@r]~ImageConvolve~GaussianMatrix[10],{2}];
ImagePad[ImageTransformation[r,#+15 {ImageValue[ix,#],ImageValue[iy,#]}&,DataRange->Full],-5]];

xkcdConvert[x_]:=xkcdDistort[xkcdShow[x]]

Filling styles

(* Filling from A to B with different directives for positive and negative *)
Filling->{1->{{3},{Directive[COLORLIST[[3]],Opacity[0.0]],Directive[COLORLIST[[3]],Opacity[0.4]]}}}

Distribute

Distribute[{{1,2,3},{4,5,6}},List]

Rescale[] function; so confusing!

tmp=Rescale[x,{a,b},{ym,yp}]//cf

tmp/.x->a//cf
tmp/.x->b//cf

MaTeX cheat sheet

(* Automatically install *)
ResourceFunction["MaTeXInstall"][]

(* Load MaTeX *)
Needs["MaTeX`"]

MaTeX["\\bm{\\zeta/\\Delta}",FontSize->18,"Preamble"->{"\\usepackage{bm}"}]

MaTeX["N_{\\rm th}",FontSize->18]

matex[symbol_]:=MaTeX[symbol,FontSize->18,"Preamble"->{"\\usepackage{bm}"}];

Automatically open init.m

NotebookOpen[$UserBaseDirectory<>"/Kernel/init.m"]

Testing Wick’s theorem for fermions

L=3;
M =  RandomReal[{-5,5},{2L,2L}];
M = I (M - M\[Transpose]);
LoadFermionicOperators[L,"global"]
ρ = MatrixExp[(1/4)Sum[M[[i,j]] Γ[i].Γ[j],{i,2L},{j,2L}]];
ρ = ρ/Tr[ρ];
𝕀 = Eye[2L];

Chop@Tr[cd[2].c[2].cd[1].c[1].ρ]
Tr[cd[2].c[2].ρ] Tr[cd[1].c[1].ρ]-Tr[cd[2].cd[1].ρ] Tr[c[2].c[1].ρ]+ Tr[cd[2].c[1].ρ] Tr[c[2].cd[1].ρ]//Chop

L=6;
M = RandomReal[{-3,3},{L,L}];
M = M + M\[Transpose];
LoadFermionicOperators[L];
ρ = MatrixExp[-Sum[M[[i,j]] cd[i].c[j],{i,L},{j,L}]];
ρ = ρ/Tr[ρ];
(*{i,j,k,l} = RandomInteger[{1,4},4];*)
{i,j,k,l} =RandomSample[Range[1,L],4];
Chop@Tr[cd[i].cd[j].c[k].c[l].ρ]
-Tr[cd[i].c[k].ρ] Tr[cd[j].c[l].ρ] + Tr[cd[i].c[l].ρ] Tr[cd[j].c[k].ρ]//Chop

{i,j,k,l} =RandomSample[Range[1,L],4];
Chop@Tr[cd[i].c[j].cd[k].c[l].ρ]
Tr[cd[i].c[j].ρ] Tr[cd[k].c[l].ρ] + Tr[cd[i].c[l].ρ] Tr[c[j].cd[k].ρ]//Chop

{i,j,k,l} =RandomSample[Range[1,L],4];
Chop@Tr[c[i].cd[j].c[k].cd[l].ρ]
Tr[c[i].cd[j].ρ] Tr[c[k].cd[l].ρ] + Tr[c[i].cd[l].ρ] Tr[cd[j].c[k].ρ]//Chop

{i,j,k,l} =RandomSample[Range[1,L],4];
Chop@Tr[cd[i].c[j].c[k].cd[l].ρ]
Tr[cd[i].c[j].ρ] Tr[c[k].cd[l].ρ] - Tr[cd[i].c[k].ρ] Tr[c[j].cd[l].ρ]//Chop

{i,j,k,l} =RandomSample[Range[1,L],4];
Chop@Tr[c[i].cd[j].cd[k].c[l].ρ]
Tr[c[i].cd[j].ρ] Tr[cd[k].c[l].ρ] - Tr[c[i].cd[k].ρ] Tr[cd[j].c[l].ρ]//Chop

Implementing a stochastic master equation using Mathematica’s ItoProcess

Clear[DiffusionUnravelling];
DiffusionUnravelling[H_,c_,ψ0_,seed_:0]:=Module[{L,variables,X,wVariables,w,xave,afunc,bfunc,wiener,system,process,𝕀,Y},
Clear[t];
If[seed!=0,SeedRandom[seed]];
L=Length@H;
variables=Table[Unique["x"],{L}];
X[t_]=#[t]&/@variables;
(*wVariables=Table[Unique["w"],{1}];*)
wVariables=Table[Unique["w"],{2}];
w[t_]=#[t]&/@wVariables;
xave = X[t]\[Conjugate].(c+c\[ConjugateTranspose]).X[t];
𝕀 = NEye[L];
afunc = - I H.X[t]-(1/2)(c\[ConjugateTranspose].c-2(xave/2) c+(((xave/2))^2)𝕀).X[t];
bfunc = (c-(xave/2) 𝕀).X[t];
wiener=#\[Distributed]WienerProcess[]&/@(wVariables);
system= \[DifferentialD]X[t][[#]]==(afunc[[#]] \[DifferentialD]t+bfunc[[#]] \[DifferentialD](w[t])[[1]])&/@Range[L];
(*process = ItoProcess[system, X[t], {variables, ψ0}, t, wiener]*)
process = ItoProcess[system, xave, {variables, ψ0}, t, wiener]
(*process = ItoProcess[Append[system,\[DifferentialD]Y[t]== xave \[DifferentialD]t+\[DifferentialD](w[t])[[2]]], Y[t], {Append[variables,Y], Append[ψ0,0]}, t, wiener]*)
]

HomodyneCurrent[sim_,bundle_:1]:=Module[{dt,newTimes,newX},
dt = sim["Path"][[2,1]]-sim["Path"][[1,1]];
newTimes = Mean/@Partition[sim["Path"][[All,1]],bundle];
newX = Mean/@Partition[sim["Path"][[All,2]],bundle];
{newTimes,+(1/(Sqrt[bundle dt]))RandomVariate[NormalDistribution[0,1],Length@newTimes]}\[Transpose]//Chop
]

Plotting in Bloch’s sphere

BlochSpherePlot[sim_]:=Module[{
sx=Chop@Table[Tr[σx.ρ],{ρ,sim["ρ"]}],
sy=Chop@Table[Tr[σy.ρ],{ρ,sim["ρ"]}],
sz=Chop@Table[Tr[σz.ρ],{ρ,sim["ρ"]}]
},
Show[BlochSphere[],
ListLinePlot3D[{sx,sy,sz}\[Transpose],PlotStyle->Black,PlotRange->All,AspectRatio->1],PlotRange->All,AspectRatio->1,ImageSize->270]
]

Region of integration for integrals involving the Fermi function

Plot[(1/((E^x)+1)),{x,-10,10}]

All functions only need to be integrated over a certain region of space where f ≠ 0,1. 
Let p denote the absolute precision we are interested (e.g. p ∼ (10^(-8)))
On the right (positive energies) we have a fermi function close to zero:

Solve[(1/((E^x)+1))==p]

Using x = β(ϵ-μ) we then get 

(Subscript[ϵ, max])≈ μ + (1/β)ln(((1-p)/p)) ≈ μ -(1/β)ln(p)

On the left, we have something close to 1:

Solve[(1/((E^x)+1))==1-p,x]

Hence 

(Subscript[ϵ, min ])≈ μ +(1/β)ln((p/(1-p))) ≈ μ + (1/β)ln(p)

Clear[FermiEnergyRegion];
FermiEnergyRegion[T_?NumberQ,μ_?NumberQ,prec_:(10^(-8))]:=Module[{β=1/T,log,emin,emax,energ},
log = Log[prec];
emin = μ + log/β;
emax = μ - log/β;
{emin,emax}//N
]

FermiEnergyRegion[{TL_,TR_,μL_,μR_},prec_:(10^(-8))]:=Module[{rL,rR},
rL = FermiEnergyRegion[TL,μL,prec];
rR = FermiEnergyRegion[TR,μR,prec];
{Min[rL[[1]],rR[[1]]],Max[rL[[2]],rR[[2]]]}
]

FermiEnergyRegion[1,2,(10^(-8))]

FermiEnergyRegion[{1,1,-1,1},(10^(-8))]

Manipulate[Plot[(1/(Exp[βL(ϵ-μL)]+1))-(1/(Exp[βR(ϵ-μR)]+1)),{ϵ,-pr,pr},
GridLines->{FermiEnergyRegion[{1/βL,1/βR,μL,μR},(10^(-prec))],None},
PlotLabel->FermiEnergyRegion[{1/βL,1/βR,μL,μR},(10^(-prec))]
]
,{{βL,1},0,3}
,{{βR,1},0,3}
,{{μL,-1},-3,3}
,{{μR,1},-3,3}
,{{pr,30},5,100}
,{{prec,8},Range[1,15],ControlType->Slider}
]

Random functions that don’t have a place yet

Order/rev

order/rev is based on the response from SquareOne in 
https://mathematica.stackexchange.com/questions/243776/combine-sortby-with-reversesortby/243815#243815

LoadDataScienceFunctions[]:=Module[{},

(* Allows combining SortBy and ReverseSortBy in the same search entry *)
Clear[order,rev];
order[rev[x_],rev[y_]]:=-Order[x,y];
order[x_,y_]:=Order[x,y];

]

Example usage

ds=Dataset[{
<|"a"->1,"b"->"x","c"->{1}|>,
<|"a"->2,"b"->"y","c"->{2,3}|>,
<|"a"->3,"b"->"z","c"->{3}|>,
<|"a"->4,"b"->"x","c"->{4,5}|>,
<|"a"->5,"b"->"y","c"->{5,6,7}|>,
<|"a"->6,"b"->"z","c"->{}|>}]

(* Sort in ascending order, first on "b", then using "a" to untie *)
SortBy[ds,{#b&,#a&}]

(* Descending order *)
ReverseSortBy[ds,{#b&,#a&}]

(* Mathematica currently has no functionality for mixing the two *)
(* This is where rev/order comes from *)

LoadDataScienceFunctions[]

SortBy[ds,{rev[#b]&,#a&},order]

Linear difference equations

LinearDifferenceEquation[α_,g_,ψi_,n_,m_:0]:=(α^(n-m))ψi + Sum[(α^(n-r-1))g[r],{r,m,n-1}]

ψs=Table[LinearDifferenceEquation[α,g,ψi,n,1],{n,1,4}]

ψs[[2;;-1]] - α ψs[[1;;-2]] //Simplify

Cross product matrix

https://en.wikipedia.org/wiki/Cross_product#Conversion_to_matrix_multiplication

CrossProductMatrix[u_]:=Sum[Normal@out[Cross[u,Basis[3,i]] ,Basis[3,i]],{i,3}]

CrossProductMatrix[{ux_,uy_,uz_}]:=(({{0, -uz, uy}, {uz, 0, -ux}, {-uy, ux, 0}}))

General rotation around an axis

https://en.wikipedia.org/wiki/Rotation_matrix

Clear[R]
R[{nx_,ny_,nz_},θ_]:=(({{Cos[θ] + (nx^2)(1-Cos[θ]), nx ny (1-Cos[θ])-nz Sin[θ], nx nz (1-Cos[θ])+ny Sin[θ] }, {ny nx (1-Cos[θ]) + nz Sin[θ], Cos[θ] + (ny^2)(1-Cos[θ]), ny nz (1-Cos[θ]) -nx Sin[θ]}, {nz nx (1-Cos[θ]) - ny Sin[θ], nz ny (1-Cos[θ]) + nx Sin[θ], Cos[θ] + (nz^2)(1-Cos[θ])}}))

r = R[{nx,ny,nz},θ]

FullSimplify[r\[Transpose].r,{0<θ<π,(nx^2)+(ny^2)+(nz^2)==1}]//mf;

R2[n_,θ_]:=Cos[θ] Eye[3] + Sin[θ] CrossProductMatrix[n]+ (1-Cos[θ])out[n,n]

R2[{nx,ny,nz},θ]-r//cf//mf;

Application to a spin S system

LoadArbitrarySpinMatrices[2,"a"]

λx = 0.3;
λy = 0.9;
λz = -0.2;
G = λx Sx + λy Sy+λz Sz;
λ = (Sqrt[((λx)^2)+((λy)^2)+((λz)^2)]);
nx = λx/λ;
ny = λy/λ;
nz = λz/λ;

ϕ = ArcTan[nx,ny];
θ = ArcTan[nz,(Sqrt[(nx^2)+(ny^2)])];
(*{nx,ny,nz}-{Sin[θ] Cos[ϕ],Sin[θ] Sin[ϕ],Cos[θ]}//Chop*)

r = R[{nx,ny,nz},-I λ];
SS[1] = Sx;
SS[2] = Sy;
SS[3] = Sz;
tmp1 = Table[MatrixExp[G].SS[i].MatrixExp[-G],{i,3}];

tmp2 = Table[Sum[r[[i,j]] SS[j],{j,3}],{i,3}];
tmp2-tmp1//ChopCheck

r2 =R[{0,1,0},-θ].R[{0,0,1},-ϕ]//Inverse;
SSs = Table[Sum[r2[[i,j]] SS[j],{j,3}],{i,3}];
exp2=Chop@Table[Tr[SSs[[i]].ρ0],{i,3}]

exp1-exp2//Chop

ρ = MatrixExp[-G]/Tr@MatrixExp[-G];
exp1=Chop@Table[Tr[SS[i].SS[j].ρ],{i,3},{j,3}];

r2 =R[{0,0,1},ϕ].R[{0,1,0},θ];
SSs = Table[Sum[r2[[i,j]] SS[j],{j,3}],{i,3}];
exp2=Chop@Table[Tr[SSs[[i]].SSs[[j]].ρ0],{i,3},{j,3}];
exp1-exp2//Chop

Clear[𝒩,S]

expr=((Sum[(m^2)Exp[-μ m],{m,S,-S,-1}])/(Sum[Exp[-μ m],{m,S,-S,-1}]))//cf

FullSimplify[expr,S∈Integers]