Gamma Entropy Gradient Flows

Needs["VectorAnalysis`"]

Needs["VectorFieldPlots`"]

GamEntContMuK=ContourPlot[κ-Log[(κ/μ)]+Log[Gamma[κ]]-(-1+κ) PolyGamma[0,κ], {μ,0.001,6},{κ,0.001,6},Contours->50,ColorFunction->(Hue[#]&), ClippingStyle->Automatic];

GradFlowMuK=GradientFieldPlot[κ-Log[(κ/μ)]+Log[Gamma[κ]]-(-1+κ) PolyGamma[0,κ], {μ,0.001,6},{κ,0.001,6},GridLines->Automatic];

Show[GamEntContMuK,GradFlowMuK]

Solving grad flow curves in μ, κ

NDSolve[{x'[t]==(1/(x[t])),y'[t]==-(((-1+y[t]) (-1+PolyGamma[1,y[t]] y[t]))/(y[t])),x[0]==.1,y[0]==1},{x[t],y[t]},{t,0,50}]
k0110=ParametricPlot[Evaluate[{x[t],y[t]}/.%],{t,0,50},Frame->True,GridLines->Automatic,PlotStyle->Thickness[0.015],PlotRange->{{0,6},{0,4}}]

NDSolve[{x'[t]==(1/(x[t])),y'[t]==-(((-1+y[t]) (-1+PolyGamma[1,y[t]] y[t]))/(y[t])),x[0]==.1,y[0]==.1},{x[t],y[t]},{t,0,10}]
k0101=ParametricPlot[Evaluate[{x[t],y[t]}/.%],{t,0,20},Frame->True,GridLines->Automatic,PlotStyle->Thickness[0.015],PlotRange->{{0,6},{0,4}}]

NDSolve[{x'[t]==(1/(x[t])),y'[t]==-(((-1+y[t]) (-1+PolyGamma[1,y[t]] y[t]))/(y[t])),x[0]==.1,y[0]==2},{x[t],y[t]},{t,0,20}]
k0120=ParametricPlot[Evaluate[{x[t],y[t]}/.%],{t,0,20},Frame->True,GridLines->Automatic,PlotStyle->Thickness[0.015],PlotRange->{{0,6},{0,4}}]

NDSolve[{x'[t]==(1/(x[t])),y'[t]==-(((-1+y[t]) (-1+PolyGamma[1,y[t]] y[t]))/(y[t])),x[0]==.1,y[0]==3},{x[t],y[t]},{t,0,20}]
k0130=ParametricPlot[Evaluate[{x[t],y[t]}/.%],{t,0,20},Frame->True,GridLines->Automatic,PlotStyle->Thickness[0.015],PlotRange->{{0,6},{0,4}}]

NDSolve[{x'[t]==(1/(x[t])),y'[t]==-(((-1+y[t]) (-1+PolyGamma[1,y[t]] y[t]))/(y[t])),x[0]==.1,y[0]==4},{x[t],y[t]},{t,0,20}]
k0140=ParametricPlot[Evaluate[{x[t],y[t]}/.%],{t,0,20},Frame->True,GridLines->Automatic,PlotStyle->Thickness[0.015],PlotRange->{{0,6},{0,6}}]

NDSolve[{x'[t]==(1/(x[t])),y'[t]==-(((-1+y[t]) (-1+PolyGamma[1,y[t]] y[t]))/(y[t])),x[0]==.1,y[0]==5},{x[t],y[t]},{t,0,20}]
k0150=ParametricPlot[Evaluate[{x[t],y[t]}/.%],{t,0,20},Frame->True,GridLines->Automatic,PlotStyle->Thickness[0.015],PlotRange->{{0,6},{0,6}}]

NDSolve[{x'[t]==(1/(x[t])),y'[t]==-(((-1+y[t]) (-1+PolyGamma[1,y[t]] y[t]))/(y[t])),x[0]==.1,y[0]==6},{x[t],y[t]},{t,0,20}]
k0160=ParametricPlot[Evaluate[{x[t],y[t]}/.%],{t,0,20},Frame->True,GridLines->Automatic,PlotStyle->Thickness[0.015],PlotRange->{{0,6},{0,6}}]

NDSolve[{x'[t]==(1/(x[t])),y'[t]==-(((-1+y[t]) (-1+PolyGamma[1,y[t]] y[t]))/(y[t])),x[0]==1,y[0]==.1},{x[t],y[t]},{t,0,20}]
k1001=ParametricPlot[Evaluate[{x[t],y[t]}/.%],{t,0,20},Frame->True,GridLines->Automatic,PlotStyle->Thickness[0.015],PlotRange->{{0,6},{0,4}}]

NDSolve[{x'[t]==(1/(x[t])),y'[t]==-(((-1+y[t]) (-1+PolyGamma[1,y[t]] y[t]))/(y[t])),x[0]==2,y[0]==.1},{x[t],y[t]},{t,0,20}]
k2001=ParametricPlot[Evaluate[{x[t],y[t]}/.%],{t,0,20},Frame->True,GridLines->Automatic,PlotStyle->Thickness[0.015],PlotRange->{{0,6},{0,4}}]

NDSolve[{x'[t]==(1/(x[t])),y'[t]==-(((-1+y[t]) (-1+PolyGamma[1,y[t]] y[t]))/(y[t])),x[0]==3,y[0]==.1},{x[t],y[t]},{t,0,20}]
k3001=ParametricPlot[Evaluate[{x[t],y[t]}/.%],{t,0,20},Frame->True,GridLines->Automatic,PlotStyle->Thickness[0.015],PlotRange->{{0,6},{0,4}}]

NDSolve[{x'[t]==(1/(x[t])),y'[t]==-(((-1+y[t]) (-1+PolyGamma[1,y[t]] y[t]))/(y[t])),x[0]==4,y[0]==.1},{x[t],y[t]},{t,0,20}]
k4001=ParametricPlot[Evaluate[{x[t],y[t]}/.%],{t,0,20},Frame->True,GridLines->Automatic,PlotStyle->Thickness[0.015],PlotRange->{{0,6},{0,4}}]

GamEntFlowMuK=Show[k0110,k1001,k2001,k3001,k4001,k0101,k0160,k0150,k0140,k0130,k0101,k0120,PlotRange->{{0,6},{0,6.1}}]

Limkappa=ParametricPlot[{{t,1},{t,3.7},{t,5.6} ,{t,4.25}},{t,0,20},Frame->True,GridLines->Automatic,PlotStyle->Thickness[0.01],PlotRange->{{0,6},{0,6.1}}]

Show[GamEntContMuK,GradFlowMuK,GamEntFlowMuK,Limkappa]

ESurfMuK=Plot3D[κ-Log[(κ/μ)]+Log[Gamma[κ]]-(-1+κ) PolyGamma[0,κ], {μ,0.00,6},{κ,0.1,6},PlotRange->{-6,3},AxesLabel->{μ,κ},Mesh->None,LabelStyle->Directive[Medium,Bold]]