PermutationsAndDiagrams.nb
Author
Behnam Farid
Title
PermutationsAndDiagrams.nb
Description
Supplementary notebook for "Many-body perturbation expansions without diagrams. I. Normal states"
Category
Academic Articles & Supplements
Keywords
URL
http://www.notebookarchive.org/2020-02-b2t1tpc/
DOI
https://notebookarchive.org/2020-02-b2t1tpc
Date Added
2020-02-24
Date Last Modified
2020-02-24
File Size
123.32 kilobytes
Supplements
Rights
Redistribution rights reserved
Download
Open in Wolfram Cloud
(*PermutationsandDiagrams|ThefollowingcodeshavebeenlargelyincludedinappendicesB,C,andDofthepublicationMany-bodyperturbationexpansionswithoutdiagrams.I.Normalstates,byBehnamFarid-30Nov.2019|©2019Allprograms,algorithms,andmethodspresentedhere,aswellasinthepublicationjustindicated,areintellectualpropertyoftheauthor.Anycommercialuseofthesewithouthiswrittenpermissionisstrictlyprohibited.Allacademicandnon-commercialusesofthecodesinthisnotebook,ormodificationsthereof,mustappropriatelyciteboththisworkandtheabove-mentionedpublication.|Donotmodifythisheading.*)
(*Whenusingthisnotebookforthefirsttime,usepreferablyEvaluateNotebook*)
In[]:=
Needs["Combinatorica`"]
In[]:=
(*-IncludedinappendixBoftheabove-mentionedpublication-*)
In[]:=
Clear[Gnu];Gnu[nu_]:=Module[(*Calculatesallconnecteddiagramscontributingtotheone-particleGreenfunctionGatthenu-thorderoftheperturbationtheory.Itprintssomerelevantdataandreturnsthelexicographicranksofallthe2nu-permutationsof(1,2,...,2nu}describingtherelevantdiagrams,alongwiththecorrespondingweightsLambda_{r,s}^{(l;nu)}.Forthereasonsspecifiedinthepaper(B.Farid,Many-bodyperturbationexpansionswithoutdiagrams.I.Normalstates,appendixB),thethreepairs(r,s)=(1,1),(1,2)and(1,3)suffice.*){tx,G11,G12,G13,m11,m12,m13,num,m,T},tx[n_]:=Module[{ld,t},ld=Last[IntegerDigits[n]];t=Which[ld1,"st",ld2,"nd",ld3,"rd",ld>3,"th"];t];G11=ConnG[1,1,nu];G12=ConnG[1,2,nu];m11=Last[G11];m12=Last[G12];If[nu>1,(G13=ConnG[1,3,nu];m13=Last[G13]),(m13=0)];m=m11+m12+m13;(*Fortheexactvaluesofmtobeprintedbelow,consulte.g.Eq.(3.34)andthe2ndcolumnfromleftofTableIofthepaperbyCvitanovićetal.(Phys.Rev.D18,1939(1978)).Inthelatterpublication,`order'kcoincideswithour2nusothatfornu=1,2,3,...theoutputvalueofmmustbeequaltorespectively2,10,74,....*)Print["The total number m of the ",nu,tx[nu],"-order diagrams contributing to G(a,b): ",m];Print["The total number m = ",m," is the sum of m11: ",m11,", m12: ",m12,", and m13: ",m13];T=Table[{G11[[j]],G11[[m11+j]]},{j,1,m11}];T=Append[T,Table[{G12[[j]],G12[[m12+j]]},{j,1,m12}]];If[nu>1,(T=Append[T,Table[{G13[[j]],G13[[m13+j]]},{j,1,m13}]])];T=Flatten[T];num={m11,m12,m13,m};T=Flatten[Append[T,num]];T]
In[]:=
Clear[ConnG];ConnG[r_,s_,nu_]:=Module[(*Firstdeterminesall2nu-permutationsof{1,2,...,2nu}correspondingtoallconnecteddiagramscontributingtoG^{(nu)}(a,b)onbeinglinkedtotheexternalverticesaandbbymeansofG_0(a,s^+)andG_0(r,b).Theintegersrands,whichmayormaynotbeequal,mustbeelementsof{1,2,...,2nu}.AlltheabovepermutationssatisfyP(r)=s.Subsequentlysubjectstherelevantcomponentsofthesepermutationstoall2nu-permutationsappropriatelydeterminedbyPerm(whichcruciallyreliesonRangeX)andselectstherepresentativesofthedisjointclassesoftheformer2nu-permutationsthatarerelatedbythelatter2nu-permutations.Generally,herebythefactor1/nu!intherelevantexpressionforG^{(nu)}(a,b)ispartiallycompensated,throughthesymmetryfactorsLambda_{r,s}^{(l;nu)}(belowcollectedinthelistW).ThelastelementoftheoutputlistTisthenumbermofindependentdiagrams;thefirstmelementsarethelexicographicranksoftheindependentpermutationsof{1,2,...,2nu},andthefollowingmelementstherelevantsymmetryfactors{Lambda_{r,s}^{(l;nu)}|l}.Thus,T[[j]]andT[[m+j]],withjin{1,2,...,m},correspondtoeachother.TheonebutlastelementofTisequaltothenumberofconnectednu-th-orderdiagramsconnectedtoG_0(a,s^+)andG_0(r,b)WITHOUTsymmetryreduction,characterisedbyLambda_{r,s}^{(l;nu)}=1foralll.*){j,l,li,ls,k,n,rank,U,P,gr,QX,Q,T,W},U=Range[1,2nu];k=0;Do[(*l*)P=Permutations[U][[l]];If[P[[r]]s,(gr=GraphG[P,r,s];If[ConnectedQ[gr,Weak],(k=k+1;rank[k]=RankPermutation[P]+1)])],{l,1,(2nu)!}];T=Table[rank[j],{j,1,k}];W=Table[1,{j,1,k}];m=k;Do[(*j*)If[j≤m,P=Permutations[U][[T[[j]]]],Break[]];Do[(*l*)Do[(*li*)QX=Perm[P,l,li,r,s];Q=QX[[1]];If[QX[[2]],(If[Q≠P,(n=RankPermutation[Q]+1;Do[(*i*)If[i≤m,If[T[[i]]n,(T=Delete[T,i];W=Delete[W,m];m=m-1;W[[j]]=W[[j]]+1;Break[])]],{i,1,k}])])],{li,0,2^nu-1}],{l,1,nu!}],{j,1,k}];Do[T=Append[T,W[[j]]],{j,1,m}];T=Append[T,k];T=Append[T,m];T]
In[]:=
Clear[GraphG];GraphG[P_,r_,s_]:=Module[(*ReturnsthegraphcorrespondingtothecontributiontoG^{(nu})(a,b)describedbythe2nu-permutationsPof{1,2,...,2nu},satisfyingP(r)=s.TheintegersrandscorrespondtotheverticesinG_0(a,s^+)andG_0(r,b),thelatterconnectingthegraphwiththeexternalverticesaandb.*){i,j,Q,gr,ex},Q=ToCycles[P];gr=GraphGX[P];ex={s,r};Do[(*j*)T=Table[(*i*)P[[Q[[j,i]]]],{i,1,Length[Q[[j]]]}];If[MemberQ[T,r]&&MemberQ[T,s],gr=DeleteEdge[gr,ex]],{j,1,Length[Q]}];gr]
In[]:=
Clear[GraphGX];GraphGX[P_]:=Module[(*Returnsthegraphcorrespondingtotheone-particleGreenfunctionassociatedwiththe2nu-permutationPof{1,2,...,2nu}.Includesthedirectededge{s,r}(fromstor)representingtheG_0(r,s^+)(notethechangeinthepositionsofsandr)thatistobeidentifiedwith1inthecaseofrandsbelongingtothesamecycleofP.ThistaskiscarriedoutbyGraphG.NotethatPistosatisfyP(r)=s.*){tnu,i,j,Q,gr},tnu=Length[P](*=2nu*);Q=ToCycles[P];gr=MakeGraph[Range[1,tnu],(Mod[#2,2]0&-1==#1)&];Do[T=Table[{Q[[j,i]],P[[Q[[j,i]]]]},{i,1,Length[Q[[j]]]}];gr=AddEdges[gr,T],{j,1,Length[Q]}];gr]
Clear[Perm];Perm[Pin_,l_,li_,r_,s_]:=Module[(*ReturnsPout,the2nu-permutationof{1,2,...,2nu}deducedfromPinbysubjectingnuentriesofthistoanu-permutationspecifiedbytheinputslandli(withlin{1,2,...,nu!}andliin{0,1,...,2^nu-1}),andtheremainingnuentriestothenu-permutationattendanttotheformerpermutation.VariationofliovertheentirerelevantsetisnecessaryonaccountofthealgorithmicdesignofConnG.Italsoreturnsaflag,whichisFalseifthediagramrepresentedbyPoutamountstoanon-topologicaltransformationofthediagramrepresentedbyPin(eveninthecaseofflag=False,PoutsatisfiesP(r)=s).*){nu,i,j,k,A,T,flag,Pout},nu=Length[Pin]/2;A=ToCycles[Pin];Q=Flatten[Permutations[RangeX[li,nu]][[l]]];T=Table[Table[Q[[A[[j,i]]]],{i,1,Length[A[[j]]]}],{j,1,Length[A]}];Pout=FromCycles[T];flag=If[Q[[r]]≠r||Q[[s]]≠s,False,True];T={Pout,flag};T]
In[]:=
Clear[RangeX];RangeX[li_,nu_]:=Module[(*Returnsapermutationofnupairs,eachofwhichisoftheform(2j-1,2j)or(2j,2j-1),dependingonthevalueofli.Theintegerlibelongstotheset{0,1,...,2^nu-1}.Allpairsareoftheform(2j-1,2j)inthespecificcaseofli=0,andoftheform(2j,2j-1)inthespecificcaseofli=2^nu-1.*){j,k,A,R},A=IntegerDigits[li,2]+1;k=Length[A];If[k<nu,Do[A=Prepend[A,1],{j,k+1,nu}]];R=Table[Permutations[{2j-1,2j}][[A[[j]]]],{j,1,nu}];R]
In[]:=
(*Test*)
In[]:=
ClearAll[nu,GF,j,k,sym,p,gr];nu=3;GF=Gnu[nu]
In[]:=
j=1(*j-thdiagramfortheone-particleGreenfunction*);k=GF[[2j-1]]
In[]:=
sym=GF[[2j]](*Symmetryfactor*)
In[]:=
(*Forvisualisation*)
In[]:=
p=Permutations[Range[1,2nu]][[k]]
In[]:=
gr=GraphG[p,r,s];ShowGraph[gr,VertexNumberTrue,VertexStyleRed]
GraphPlot[gr,DirectedEdgesTrue,VertexLabelingTrue]
In[]:=
(*-IncludedinappendixCoftheabove-mentionedpublication-*)
In[]:=
Clear[Snu];Snu[nu_]:=Module[(*ReturnsthepermutationsandtheassociatedweightsLambda_{r,s}^{(l;nu)}correspondingtoG-skeletonself-energydiagramsassociatedwiththethreerelevantpairs(r,s)=(1,1),(1,2),(1,3).Italsoprintssomerelevantdetails.*){tx,S11,S12,S13,m11,m12,m13,num,m,T},tx[n_]:=Module[{ld,t},ld=Last[IntegerDigits[n]];t=Which[ld1,"st",ld2,"nd",ld3,"rd",ld>3,"th"];t];S11=SkeletonS[1,1,nu];S12=SkeletonS[1,2,nu];m11=Last[S11];m12=Last[S12];If[nu>1,(S13=SkeletonS[1,3,nu];m13=Last[S13]),(m13=0)];m=m11+m12+m13;(*Fortheexactvaluesofmprintedbelow,consulte.g.Eq.(17)ofthepaperbyMolinariandManini(Eur.Phys.J.B51,331(2006)).Thus,fornu=1,2,3,4,...thembelowmustbeequaltorespectively2,2,10,82,...(byleavingouttheHartree,orthetadpole,diagram,themfornu=1wouldbe1).Fornu>1,m11andm12mustbeequalto0.Tosavecomputationtimeinthecasesofnu>1,itisadvisabletocommentouttheinstructionsbelowthatconcernS11,m11,andS12,m12.*)Print["The total number m of the ",nu,tx[nu],"-order G-skeleton diagrams contributing to Σ(a,b): ",m];Print["The total number m = ",m," is the sum of m11: ",m11,", m12: ",m12,", and m13: ",m13];T=Table[{S11[[j]],S11[[m11+j]]},{j,1,m11}];T=Append[T,Table[{S12[[j]],S12[[m12+j]]},{j,1,m12}]];If[nu>1,(T=Append[T,Table[{S13[[j]],S13[[m13+j]]},{j,1,m13}]])];T=Flatten[T];num={m11,m12,m13,m};T=Flatten[Append[T,num]];T]
In[]:=
Clear[SkeletonS];SkeletonS[r_,s_,nu_]:=Module[(*Byconsideringthenu-th-orderconnectedGreen-functiondiagramsthatthroughtheGreenfunctionsG_0(a,s^+)andG_0(r,b)arelinkedtotheexternalverticesaandb,selectsouttheΣ^{(nu)}(s,r)thatareG-skeleton.Returnsthecorresponding2nu-permutationsof{1,2,...,2nu}(theirlexicographicranks)andtheassociatedweightsLambda_{r,s}^{(l;nu)}.*){m,n,v,R,U,T,P,rS,wS},R=Range[1,2nu];U=ConnG[r,s,nu];m=Last[U];n=0;Do[(*j*)P=Permutations[R][[U[[j]]]];v=SkeletonG[P,r,s][[2]];If[v,(n=n+1;rS[n]=U[[j]];wS[n]=U[[m+j]])],{j,1,m}];T=Table[rS[j],{j,1,n}];T=Flatten[Append[T,Table[wS[j],{j,1,n}]]];T=Append[T,n];T]
In[]:=
Clear[SkeletonG];SkeletonG[P_,r_,s_]:=Module[(*ReturnsTrueiftheself-energydiagramcontributingtoΣ(s,r)isG-skeleton,Falseotherwise.*){i,j,k,l,ex,e1,e2,Q,v,gr,grx},Q=ToCycles[P];gr=GraphG[P,r,s];ex={s,r};v=True;Do[(*k*)Do[(*l*)e2={Q[[k,l]],P[[Q[[k,l]]]]};If[e2≠ex,(Do[(*i*)Do[(*j*)e1={Q[[i,j]],P[[Q[[i,j]]]]};If[e1≠ex,If[e1≠e2,(grx=DeleteEdges[gr,{e1,e2}];v=ConnectedQ[grx,Weak];If[vFalse,Goto[end]])]],{j,1,Length[Q[[i]]]}],{i,1,Length[Q]}])],{l,1,Length[Q[[k]]]}],{k,1,Length[Q]}];Label[end];T={gr,v};T]
In[]:=
(*Test*)
In[]:=
ClearAll[nu,Sigma,j,k,sysm,p,gr];nu=3;Sigma=Snu[nu]
In[]:=
j=1(*j-thdiagramfortheG-Skeletonself-energyfunction*);k=Sigma[[2j-1]]
In[]:=
sym=Sigma[[2j]](*Symmetryfactor*)
In[]:=
(*Forvisualisation*)
In[]:=
p=Permutations[Range[1,2nu]][[k]]
In[]:=
gr=GraphG[p,r,s];ShowGraph[gr,VertexNumberTrue,VertexStyleRed]
GraphPlot[gr,DirectedEdgesTrue,VertexLabelingTrue]
In[]:=
(*-IncludedinappendixDoftheabove-mentionedpublication-*)
In[]:=
Clear[A2num1];A2num1[ir_,is_,nu_,S_]:=Module[(*ReturnsA_{alpha_ir,alpha_is}^{(2nu-1)}(alpha_1,alpha_2,....,alpha_{2nu})insymbolicformforgivenvaluesofir,is,nu,andthespinconfigurationS={sigma_1,sigma_2,...,sigma_{2nu}}.Theintegersirandisareelementsof{1,2,...,2nu}.Withi=l_it_i,andj=l_jt_j,intheoutputitisassumedthatthesecondargumentjinG_{sigma_i}(i,j)representsj^+,signifyingl_jt_j+0^+.Further,thesymbolG_{sigma_i}(i,j)generallyrepresentsthenon-interactingone-particleGreenfunction.HereG_{sigma_i}(i,j)isdefinedonthebasisoftheequalityG_{sigma_i,sigma_j}(i,j)=G_{sigma_i}(i,j)delta_{sigma_i,sigma_j}.*){g,thetj,Gx,j,l,sum,sumx,R,P},g[ix_,jx_,Tx_]:=If[Tx[[ix]]Tx[[jx]],1,0];thetj[jx_]:=Floor[(jx+1)/2];Gx[nx_,lx_]:=If[lx0,Table["G↓"[ix,jx],{ix,1,nx},{jx,1,nx}],Table["G↑"[ix,jx],{ix,1,nx},{jx,1,nx}]];R=Range[1,2nu];sum=0;Do[(*l*)P=Permutations[R][[l]];If[P[[ir]]is,(sumx=Signature[P]Product[If[j≠ir,(g[j,P[[j]],S]Gx[nu,S[[j]]][[thetj[j],thetj[P[[j]]]]]),1],{j,1,2nu}]),(sumx=0)];sum=sum+sumx,{l,1,(2nu)!}];sum]
In[]:=
Clear[Arr];Arr[S_]:=Module[(*ReturnsaspinconfigurationSgeneratedbySgenorSgenPPinarrownotation.*){l,li,y,S1},l=Length[S];Do[y[li]=If[S[[li]]0,"",""],{li,1,l}];S1=Table[y[li],{li,1,l}];S1]
In[]:=
Clear[Sgen];Sgen[nu_,li_]:=Module[(*Returnstheli-thspinconfigurationS={sigma_1,sigma_2,...,sigma_{2nu}},outofthepossible2^{nu}distinctspinconfigurations,for2nuspin-1/2particles,satisfyingsigma_{2j}=1-sigma_{2j-1}.Heresigma_j=0representsspin-down,andsigma_j=1spin-up.*){k,j,A,B,S},A=IntegerDigits[li,2];k=Length[A];If[k<nu,Do[A=Prepend[A,0],{j,k+1,nu}]];B=Table[(1-A[[j]]),{j,1,nu}];S=Riffle[A,B];S]
In[]:=
Clear[SgenPP];SgenPP[ir_,is_,sigir_,sigis_,S_]:=Module[(*GiventhespinconfigurationS={sigma_1,sigma_2,...,sigma_{2nu}},wheresigma_j=0standsforspin-down,andsigma_j=1forspin-up,andwhereinthepresentapplicationtheindicessatisfysigma_{2j}=1-sigma_{2j-1},replacessigma_{ir}bysigirandsigma_{is}bysigis.Subsequentlyadjuststherelevantneighbouringspinsinsuchawaythattheindicesintheresultingspinconfiguration,tobereturned,satisfysigma_{2j}=1-sigma_{2j-1}.*){Spp},Spp=S;If[Mod[ir,2]0,(Spp=ReplacePart[Spp,{ir-11-sigir,irsigir}]),(Spp=ReplacePart[Spp,{irsigir,ir+11-sigir}])];If[Mod[is,2]0,(Spp=ReplacePart[Spp,{is-11-sigis,issigis}]),(Spp=ReplacePart[Spp,{issigis,is+11-sigis}])];Spp]
In[]:=
(*Set1*)
In[]:=
nu=3;Do[(*sigir*)sigis=sigir;Do[(*r*)ir1=2r-1;is1=2r-1;ir2=2r;is2=2r;Print["ir1, is1: ",ir1,", ",is1,"; ir2, is2: ",ir2,", ",is2];Do[(*li*)S=Sgen[nu,li];Spp1=SgenPP[ir1,is1,sigir,sigis,S];Spp2=SgenPP[ir2,is2,sigir,sigis,S];Print["li: ",li,". :",Arr[{sigir}],", :",Arr[{sigis}],", S: ",Arr[S],", Spp1: ",Arr[Spp1],", Spp2: ",Arr[Spp2]];A1=A2num1[ir1,is1,nu,Spp1];Print["A1: ",A1];A2=A2num1[ir2,is2,nu,Spp2];Print["A2: ",A2];Print["→ A1-A2: ",Simplify[A1-A2]],{li,0,2^nu-1}],{r,1,nu}],{sigir,0,1}]
σ
ir
σ
is
In[]:=
(*Set2*)
In[]:=
nu=3;Do[(*sigir*)Do[(*sigis*)Do[(*r*)Do[(*s*)If[rs,Goto[end]];ir1=2r-1;is1=2s-1;ir2=2r;is2=2s-1;Print["ir1, is1: ",ir1,", ",is1,"; ir2, is2: ",ir2,", ",is2];Do[(*li*)S=Sgen[nu,li];Spp1=SgenPP[ir1,is1,sigir,sigis,S];A1=A2num1[ir1,is1,nu,Spp1];Print["A1: ",A1];Spp2=SgenPP[ir2,is2,sigir,sigis,S];Print["li: ",li,". :",Arr[{sigir}],", :",Arr[{sigis}],", Spp1: ",Arr[Spp1],", Spp2: ",Arr[Spp2]];A2=A2num1[ir2,is2,nu,Spp2];Print["A2: ",A2];Print["→ A1-A2: ",Simplify[A1-A2]],{li,0,2^nu-1}];Label[end],{s,1,nu}],{r,1,nu}],{sigis,0,1}],{sigir,0,1}]
σ
ir
σ
is
In[]:=
(*Set3*)
nu=3;Do[(*sigir*)Do[(*sigis*)Do[(*r*)ir1=2r-1;is1=2r;ir2=2r-1;is2=2r;Print["ir1, is1: ",ir1,", ",is1,"; ir2, is2: ",ir2,", ",is2];Do[(*li*)S=Sgen[nu,li];Print["li: ",li,". :",Arr[{sigir}],", :",Arr[{sigis}],", S: ",Arr[S]];A1=A2num1[ir1,is1,nu,S];Print["A1: ",A1];A2=A2num1[ir2,is2,nu,S];Print["A2: ",A2];Print["→ A1-A2: ",Simplify[A1-A2]],{li,0,2^nu-1}],{r,1,nu}],{sigis,0,1}],{sigir,0,1}]
σ
ir
σ
is
(*-EndofPermutationsandDiagrams-*)
Cite this as: Behnam Farid, "PermutationsAndDiagrams.nb" from the Notebook Archive (2020), https://notebookarchive.org/2020-02-b2t1tpc
Download
