0
$\begingroup$

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:

enter image description here

Help, please. Thanks.

$\endgroup$
  • 1
    $\begingroup$ Remove the underscores from new[...] and old[...] in your plot to start $\endgroup$ – J_Nat Jul 21 '16 at 19:58
  • $\begingroup$ Rendering any Plot3D[] will take a long time here, Manipulate[] isn't the way to go. $\endgroup$ – Feyre Jul 21 '16 at 20:09
  • $\begingroup$ @J_Nat Edited. Check the code. I get a similar error. See the edited post. $\endgroup$ – Junaid Aftab Jul 21 '16 at 20:14
  • $\begingroup$ @Feyre Any suggestions? $\endgroup$ – Junaid Aftab Jul 21 '16 at 20:14
  • $\begingroup$ I got no errors, just $Aborted in place of the plot which backs up Feyre's comment that it takes too long in the current state. $\endgroup$ – J_Nat Jul 21 '16 at 20:18
2
$\begingroup$

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}]

enter image description here

$j=2$

enter image description here

|improve this answer|||||
$\endgroup$
  • $\begingroup$ What about the other graphs for the other times, tau? I'm assuming this graph is for one fixed time, tau. Also, why are there two branches/surfaces in the graph. I want to calculate the difference of the two functions -- so shouldn't there be one surface? $\endgroup$ – Junaid Aftab Jul 22 '16 at 7:16
  • $\begingroup$ I ran the command with {\[Tau], 0.5, 1}. I got one graph. Shouldn't I be getting two graphs -- one that computes the difference, new - old, for \[Tau] = 0.5 and the other that does the same for \[Tau] = 1? $\endgroup$ – Junaid Aftab Jul 22 '16 at 8:27
  • $\begingroup$ @JunaidAftab As you can see here, alpha does nog affect the graph. $\endgroup$ – Feyre Jul 22 '16 at 9:11
  • $\begingroup$ @Feyre I'm not sure what's on the axes then - Cho which is till 2pi. What about the other axes? I expect the axes representing the difference to be between - 1 and 1. :/ $\endgroup$ – Junaid Aftab Jul 22 '16 at 9:24
  • $\begingroup$ You can see from the fact he is using {α, 0, 2 π}, {χ, 0, π}. The z axis is the value for the functions of two different values of τ. $\endgroup$ – Feyre Jul 22 '16 at 9:27
1
$\begingroup$

One way of plotting 4d data is with:

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

enter image description here

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[]

enter image description here

|improve this answer|||||
$\endgroup$
  • $\begingroup$ Can you please share the interpretation of this graph? I'm looking at it for the first time. I can identify which axis is which -- and the difference between new and old is between 0 and 1 so that's good. $\endgroup$ – Junaid Aftab Jul 22 '16 at 9:52
  • $\begingroup$ @JunaidAftab This is a Densityplot, that means every point in the space here has a value, this is the value of the function new[α, χ, τ] - old[τ] at the triplet {χ,α,τ} $\endgroup$ – Feyre Jul 22 '16 at 10:55
  • $\begingroup$ So the axes represent chi and alpha. At each point, what is the value of tau? I don't get it. Also, at each triplet, how do I interpret the value of new - old? What do the different colours in the plot represent? $\endgroup$ – Junaid Aftab Jul 22 '16 at 10:59
  • $\begingroup$ In this case τ is the vertical-axis. You can add , PlotLegends -> Automatic to show a numerical value for the various colours. I can think of one way to actually plot this in the original way you intended, I'll add it soon. $\endgroup$ – Feyre Jul 22 '16 at 11:04
  • $\begingroup$ So the horizontal axes represent chi and alpha and the veto ticks axis represents tau. My question still is: 1) how is tau modelled in the graph? Is tau discrete or does it take a continuum of values between 0 and 1? 2) how do I interpret the value of new - old at each triplet -- what do the colours represent? $\endgroup$ – Junaid Aftab Jul 22 '16 at 11:34
0
$\begingroup$

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}]

enter image description here

|improve this answer|||||
$\endgroup$
  • $\begingroup$ Edited. Check the code. I get a similar error. See the edited post. $\endgroup$ – Junaid Aftab Jul 21 '16 at 20:14
  • $\begingroup$ What is w? I haven't defined it. $\endgroup$ – Junaid Aftab Jul 21 '16 at 20:35
  • $\begingroup$ Why are you taking omega to be between 0 and 70? I am already numerically integrating over it and it is no longer a variable that appears in my function in the Plot command. $\endgroup$ – Junaid Aftab Jul 21 '16 at 20:38
  • $\begingroup$ I do the calculation with [Omega] from 0 to 70 just for getting lower time of calculation. In your code is from 0 to 70000 $\endgroup$ – Kamel Jul 21 '16 at 20:38
  • 1
    $\begingroup$ You can format inline code and code blocks by selecting the code and clicking the {} button above the edit window. The edit window help button ? is also useful for learning how to format your questions and answers. You may also find this meta Q&A helpful $\endgroup$ – Michael E2 Jul 21 '16 at 21:38

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.