3D Plot with the Manipulate Command

Question

I'm trying to make a 3D Plot using the Manipulate command. The code is:

ClearAll["Global`*"]

G = 0.01;
β = 1;
ωc = 50;
J = 1;
ϕ = 0;
θ = π/2;
η = Exp[I ϕ]*Tan[θ/2];

integralgamma[ω_, τ_] := 
  4 G ω Exp[-ω/ωc] ((1 - 
    Cos[ω τ])/ω^(2)) Coth[β ω/2]; 

integraldelta[ω_, τ_] := 
 4 G ω Exp[-ω/ωc] (Sin[ω τ] - \
  ω τ)/ω^2;

ψ = Exp[I α] * Tan[χ/2];

old[τ_] :=    (Abs[η]/(1 + Abs[η]^2) )^(4 J) * 
 Sum[Binomial[2 J, J + m] * Binomial[2 J, J + p] * 
  Abs[η]^(2 m + 2 p) * 
   Exp[-NIntegrate[
    integralgamma[ω, τ], {ω, 0, 70000}, 
     Method -> "LocalAdaptive", MaxRecursion -> 15]* (m - p)^2] * 
      Exp[- I * 
       NIntegrate[
        integraldelta[ω, τ], {ω, 0, 70000}, 
         Method -> "LocalAdaptive", 
          MaxRecursion -> 15]* (m^2 - p^2)]  , {m, -1, 1, 1}, {p, -1, 
           1, 1}];

new[\[Alpha]_, \[Chi]_, \[Tau]_] := (Abs[ψ]/(1 + 
 Abs[ψ]^2) )^(2 J)*(Abs[η]/(1 + 
  Abs[η]^2) )^(2 J) * 
   Sum[Binomial[2 J, J + m] * Binomial[2 J, J + p] * 
    Abs[ψ]^(2 m + 2 p) * Abs[η]^(2 m + 2 p) * 
     Exp[-NIntegrate[
      integralgamma[ω, τ], {ω, 0, 70000}, 
       Method -> "LocalAdaptive", MaxRecursion -> 15]* (m - p)^2] * 
        Exp[- I * 
         NIntegrate[
          integraldelta[ω, τ], {ω, 0, 70000}, 
           Method -> "LocalAdaptive", 
            MaxRecursion -> 15]* (m^2 - p^2)]  , {m, -1, 1, 1}, {p, -1, 
             1, 1}];

Manipulate[
 Plot3D[Evaluate[new[\[Alpha], \[Chi], \[Tau]]] - 
  Evaluate[old[\[Tau]]], {\[Alpha], 0, 2 \[Pi]}, {\[Chi], 
   0, \[Pi]}], {\[Tau], 0, 1}]

I get the result:

Help, please. Thanks.

Answer 1

Updated using mem: as suggested by Simon Woods.

Perhaps using Plot3D at a couple of intervals of tau will be enlightening. The results seems plausible based on the fact that old is a 1D function.

ClearAll["Global`*"]

G = 0.01;
β = 1;
ωc = 50;
j = 1;
ϕ = 0;
θ = π/2;

η = Exp[I ϕ] Tan[θ/2];

Clear[ψ]
ψ[α_, χ_] := Exp[I α]*Tan[χ/2];

integralgamma[ω_, τ_] := 4 G ω Exp[-ω/ωc] ((1 - Cos[ω τ])/ω^(2)) Coth[β ω/2] 
integraldelta[ω_, τ_] := 4 G ω Exp[-ω/ωc] (Sin[ω τ] - ω τ)/ω^2

mem :δ[τ_]:= mem=NIntegrate[integraldelta[ω, τ], {ω, 0, Infinity}, PrecisionGoal -> 3]
mem :γ[τ_]:= mem=NIntegrate[integralgamma[ω, τ], {ω, 0, Infinity}, PrecisionGoal -> 3]

old[τ_] := -(1/τ) Log[
  (Abs[η]/(1 + Abs[η]^2))^(4 j) 
   Sum[Abs[η]^(2 m + 2 p) 
   Binomial[2 j, j + m] Binomial[2 j, j + p] 
   Exp[-I δ[τ] (m^2 - p^2)] Exp[-γ[τ] (m - p)^2], 
   {m, -j, j, 1}, {p, -j, j, 1}]]

new[α_, χ_, τ_] := -(1/τ) Log[
 (Abs[ψ[α, χ]]/(1 + Abs[ψ[α, χ]]^2))^(4 j)  (Abs[η]/(1 + Abs[η]^2))^(2 j)
  Sum[Abs[η]^(2 m + 2 p) Abs[ψ[α, χ]]^(2 m + 2 p) 
  Binomial[2 j, j + m] Binomial[2 j,j + p] 
  Exp[-I δ[τ] (m^2 - p^2)] Exp[-γ[τ] (m - p)^2], 
  {m, -j, j, 1}, {p, -j, j, 1}]]

Table Plots:

Table[Plot3D[
  Re[new[α, χ, τ] - old[τ]], {α, 0, 2 π}, {χ, 0, π}, 
   PlotPoints -> 20, MaxRecursion -> 0,
   ColorFunction -> (ColorData["Rainbow"][Rescale[#3, {-2, 8}]] &),
   ColorFunctionScaling -> False, PlotRange -> {-2, 8}], {τ, 0.2, 2.0, 0.1}]

$j=2$

Answer 2

One way of plotting 4d data is with:

DensityPlot3D[
 Re[new[α, χ, τ] - old[τ]], {χ, 
  0, π}, {α, 0, 2 π}, {τ, 0.1, 1}, 
 PlotPoints -> 11]

To do this with manipulate, it is wise to do all the calculations first, and storing the values in a dataset.

data = Table[
   Table[{α, χ, 
     Re[new[α, χ, τ] - old[τ]]}, {χ, π/
      16, π, π/8}, {α, 0, 2 π, π/4}], {τ, 
    0.1, 1, 0.1}];

This creates a file for values and coordinates α, χ. Note, this takes a while to create.

Manipulate[
 ListPlot3D[Flatten[data[[τ, All, All, All]], 1]], {τ, 1, 
  Length[data[[All, 1, 1, 1]]], 1}]

This plots the data where you can change τ like you requested as a Manipulate[]

Answer 3

The command given before editing the question and before my answer was:

Manipulate[
 Plot3D[new[α_, χ_, τ_] - old[τ_], {α, 0, 2 π}, {χ, 0, π}], {τ, 0, 1}]

My answer is:

Manipulate[
 Plot3D[Evaluate[new[τ, α, χ]] - Evaluate[old[τ]], {α, 0, 2 π}, {χ,0, π}], {τ, 0, 2}]