Skip to main content
Mathematica

Return to Question

Formatted code
Source Link
MarcoB
MarcoB
  • 67.7k
  • 18
  • 96
  • 198
G = 0.01;
β = 1;
ωc = 50;
ϕ = 0;
θ = π/2;
J = 1;

η = 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}, 
   MaxRecursion -> 15,   PrecisionGoal -> 3]

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

old[τ_] := (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[α_, χ_, τ_] := (Abs[ψ[α, χ]]/(1 \
 + Abs[ψ[α, χ]]^2))^(2 J)*(Abs[η]/(1 + 
  Abs[η]^2))^(2 J)*
   Sum[Binomial[2 J, J + m] Binomial[2 J, 
    J + p]*(Conjugate[ψ[α, \
     χ]]*η)^(m)*(Conjugate[η]*ψ[α, χ])^(p)*
      Exp[-I δ[τ] (m^2 - 
       p^2)] Exp[-γ[τ] (m - p)^2], 
    {m, -J, J, 
        1}, {p, -J, J, 1}];

J1Final = Plot3D[
  Re[new[αPlot3D[Re[new[α, χ, 1] - old[1]], {α, 0, 
   2 π}, {χ, 0, π}, 
    PlotPoints -> 20, 
    MaxRecursion -> 0]

NMaximize[{f[α, χ, 1], 0 <= α <= 2 π, 
 0 <= χ <= π}, {α, χ}],

{-0.0336509, {α -> 6.28319, χ -> 3.14159}},

{0.291708, {α -> 3.14159, χ -> 1.5708}},

as expected. How could it be that NMaximize is a finding the global maximum to be lesserless than what FindMaximum is finding it to be.?

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

η = 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}, 
   MaxRecursion -> 15,   PrecisionGoal -> 3]

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

old[τ_] := (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[α_, χ_, τ_] := (Abs[ψ[α, χ]]/(1 \
 + Abs[ψ[α, χ]]^2))^(2 J)*(Abs[η]/(1 + 
  Abs[η]^2))^(2 J)*
   Sum[Binomial[2 J, J + m] Binomial[2 J, 
    J + p]*(Conjugate[ψ[α, \
     χ]]*η)^(m)*(Conjugate[η]*ψ[α, χ])^(p)*
      Exp[-I δ[τ] (m^2 - 
       p^2)] Exp[-γ[τ] (m - p)^2], {m, -J, J, 
        1}, {p, -J, J, 1}];

J1Final = Plot3D[
  Re[new[α, χ, 1] - old[1]], {α, 0, 
   2 π}, {χ, 0, π}, PlotPoints -> 20, 
    MaxRecursion -> 0]

NMaximize[{f[α, χ, 1], 0 <= α <= 2 π, 
 0 <= χ <= π}, {α, χ}],

{-0.0336509, {α -> 6.28319, χ -> 3.14159}},

{0.291708, {α -> 3.14159, χ -> 1.5708}},

as expected. How could it be that NMaximize is a finding the global maximum to be lesser than what FindMaximum is finding it to be.

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

η = 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}, 
  MaxRecursion -> 15, PrecisionGoal -> 3]

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

old[τ_] := (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[α_, χ_, τ_] := (Abs[ψ[α, χ]]/(1 + Abs[ψ[α, χ]]^2))^(2 J)*(Abs[η]/(1 + Abs[η]^2))^(2 J)*
   Sum[Binomial[2 J, J + m] Binomial[2 J, 
    J + p]*(Conjugate[ψ[α, χ]]*η)^(m)*(Conjugate[η]*ψ[α, χ])^(p)*
      Exp[-I δ[τ] (m^2 - p^2)] Exp[-γ[τ] (m - p)^2], 
    {m, -J, J, 1}, {p, -J, J, 1}];

J1Final = Plot3D[Re[new[α, χ, 1] - old[1]], {α, 0, 2 π}, {χ, 0, π}, 
    PlotPoints -> 20, MaxRecursion -> 0]

NMaximize[{f[α, χ, 1], 0 <= α <= 2 π, 0 <= χ <= π}, {α, χ}]

{-0.0336509, {α -> 6.28319, χ -> 3.14159}}

{0.291708, {α -> 3.14159, χ -> 1.5708}}

as expected. How could it be that NMaximize is finding the global maximum to be less than what FindMaximum is finding it to be?

Greek letters
Source Link
edit approved Jul 26, 2016 at 12:04
Feyre
edit approved Jul 26, 2016 at 12:04
Feyre
  • 8.7k
  • 2
  • 29
  • 48
G = 0.01;
\[Beta]β = 1;
\[Omega]cωc = 50;
\[Phi]ϕ = 0;
\[Theta]θ = \[Pi]π/2;
J = 1;

\[Eta]η = Exp[I \[Phi]]ϕ] Tan[\[Theta]Tan[θ/2];

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

integralgamma[\[Omega]_integralgamma[ω_, \[Tau]_]τ_] := 
 4 G \[Omega]ω Exp[-\[Omega]ω/\[Omega]c]ωc] ((1 - 
  Cos[\[Omega]Cos[ω \[Tau]]τ])/\[Omega]^ω^(2)) Coth[\[Beta]Coth[β \[Omega]ω/2]

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

mem : \[Delta][\[Tau]_]δ[τ_] := 
 mem = NIntegrate[
  integraldelta[\[Omega]integraldelta[ω, \[Tau]]τ], {\[Omega]ω, 0, Infinity}, 
   MaxRecursion -> 15,   PrecisionGoal -> 3]

mem : \[Gamma][\[Tau]_]γ[τ_] := 
 mem = NIntegrate[
  integralgamma[\[Omega]integralgamma[ω, \[Tau]]τ], {\[Omega]ω, 0, Infinity}, 
   MaxRecursion -> 15, PrecisionGoal -> 3]

old[\[Tau]_]old[τ_] := (Abs[\[Eta]]Abs[η]/(1 + Abs[\[Eta]]^2Abs[η]^2))^(4 J) Sum[
 Abs[\[Eta]]^Abs[η]^(2 m + 2 p) Binomial[2 J, J + m] Binomial[2 J, 
  J + p] Exp[-I \[Delta][\[Tau]]δ[τ] (m^2 - 
     p^2)] Exp[-\[Gamma][\[Tau]]γ[τ] (m - p)^2], {m, -J, J, 
      1}, {p, -J, J, 1}];


new[\[Alpha]_new[α_, \[Chi]_χ_, \[Tau]_]τ_] := (Abs[\[Psi][\[Alpha]Abs[ψ[α, \[Chi]]]χ]]/(1 \
 + Abs[\[Psi][\[Alpha]Abs[ψ[α, \[Chi]]]^2χ]]^2))^(2 J)*(Abs[\[Eta]]Abs[η]/(1 + 
  Abs[\[Eta]]^2Abs[η]^2))^(2 J)*
   Sum[Binomial[2 J, J + m] Binomial[2 J, 
    J + p]*(Conjugate[\[Psi][\[Alpha]Conjugate[ψ[α, \
     \[Chi]]]*\[Eta]χ]]*η)^(m)*(Conjugate[\[Eta]]*\[Psi][\[Alpha]Conjugate[η]*ψ[α, \[Chi]]χ])^(p)*
      Exp[-I \[Delta][\[Tau]]δ[τ] (m^2 - 
       p^2)] Exp[-\[Gamma][\[Tau]]γ[τ] (m - p)^2], {m, -J, J, 
        1}, {p, -J, J, 1}];

J1Final = Plot3D[
  Re[new[\[Alpha]Re[new[α, \[Chi]χ, 1] - old[1]], {\[Alpha]α, 0, 
   2 \[Pi]π}, {\[Chi]χ, 0, \[Pi]π}, PlotPoints -> 20, 
    MaxRecursion -> 0]

NMaximize[{f[\[Alpha]f[α, \[Chi]χ, 1], 0 <= \[Alpha]α <= 2 \[Pi]π, 
 0 <= \[Chi]χ <= \[Pi]π}, {\[Alpha]α, \[Chi]χ}],

{-0.0336509, {\[Alpha]α -> 6.28319, \[Chi]χ -> 3.14159}},

FindMaximum[f[\[Alpha]FindMaximum[f[α, \[Chi]χ, 1], {\[Alpha]α, 2}, {\[Chi]χ, 2}]

{0.291708, {\[Alpha]α -> 3.14159, \[Chi]χ -> 1.5708}},

G = 0.01;
\[Beta] = 1;
\[Omega]c = 50;
\[Phi] = 0;
\[Theta] = \[Pi]/2;
J = 1;

\[Eta] = Exp[I \[Phi]] Tan[\[Theta]/2];

Clear[\[Psi]]
\[Psi][\[Alpha]_, \[Chi]_] := Exp[I \[Alpha]]*Tan[\[Chi]/2];

integralgamma[\[Omega]_, \[Tau]_] := 
 4 G \[Omega] Exp[-\[Omega]/\[Omega]c] ((1 - 
  Cos[\[Omega] \[Tau]])/\[Omega]^(2)) Coth[\[Beta] \[Omega]/2]

integraldelta[\[Omega]_, \[Tau]_] := 
 4 G \[Omega] Exp[-\[Omega]/\[Omega]c] (Sin[\[Omega] \[Tau]] - \
  \[Omega] \[Tau])/\[Omega]^2

mem : \[Delta][\[Tau]_] := 
 mem = NIntegrate[
  integraldelta[\[Omega], \[Tau]], {\[Omega], 0, Infinity}, 
   MaxRecursion -> 15,   PrecisionGoal -> 3]

mem : \[Gamma][\[Tau]_] := 
 mem = NIntegrate[
  integralgamma[\[Omega], \[Tau]], {\[Omega], 0, Infinity}, 
   MaxRecursion -> 15, PrecisionGoal -> 3]

old[\[Tau]_] := (Abs[\[Eta]]/(1 + Abs[\[Eta]]^2))^(4 J) Sum[
 Abs[\[Eta]]^(2 m + 2 p) Binomial[2 J, J + m] Binomial[2 J, 
  J + p] Exp[-I \[Delta][\[Tau]] (m^2 - 
     p^2)] Exp[-\[Gamma][\[Tau]] (m - p)^2], {m, -J, J, 
      1}, {p, -J, J, 1}];


new[\[Alpha]_, \[Chi]_, \[Tau]_] := (Abs[\[Psi][\[Alpha], \[Chi]]]/(1 \
 + Abs[\[Psi][\[Alpha], \[Chi]]]^2))^(2 J)*(Abs[\[Eta]]/(1 + 
  Abs[\[Eta]]^2))^(2 J)*
   Sum[Binomial[2 J, J + m] Binomial[2 J, 
    J + p]*(Conjugate[\[Psi][\[Alpha], \
     \[Chi]]]*\[Eta])^(m)*(Conjugate[\[Eta]]*\[Psi][\[Alpha], \[Chi]])^(p)*
      Exp[-I \[Delta][\[Tau]] (m^2 - 
       p^2)] Exp[-\[Gamma][\[Tau]] (m - p)^2], {m, -J, J, 
        1}, {p, -J, J, 1}];

J1Final = Plot3D[
  Re[new[\[Alpha], \[Chi], 1] - old[1]], {\[Alpha], 0, 
   2 \[Pi]}, {\[Chi], 0, \[Pi]}, PlotPoints -> 20, 
    MaxRecursion -> 0]

NMaximize[{f[\[Alpha], \[Chi], 1], 0 <= \[Alpha] <= 2 \[Pi], 
 0 <= \[Chi] <= \[Pi]}, {\[Alpha], \[Chi]}],

{-0.0336509, {\[Alpha] -> 6.28319, \[Chi] -> 3.14159}},

FindMaximum[f[\[Alpha], \[Chi], 1], {\[Alpha], 2}, {\[Chi], 2}]

{0.291708, {\[Alpha] -> 3.14159, \[Chi] -> 1.5708}},

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

η = 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}, 
   MaxRecursion -> 15,   PrecisionGoal -> 3]

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

old[τ_] := (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[α_, χ_, τ_] := (Abs[ψ[α, χ]]/(1 \
 + Abs[ψ[α, χ]]^2))^(2 J)*(Abs[η]/(1 + 
  Abs[η]^2))^(2 J)*
   Sum[Binomial[2 J, J + m] Binomial[2 J, 
    J + p]*(Conjugate[ψ[α, \
     χ]]*η)^(m)*(Conjugate[η]*ψ[α, χ])^(p)*
      Exp[-I δ[τ] (m^2 - 
       p^2)] Exp[-γ[τ] (m - p)^2], {m, -J, J, 
        1}, {p, -J, J, 1}];

J1Final = Plot3D[
  Re[new[α, χ, 1] - old[1]], {α, 0, 
   2 π}, {χ, 0, π}, PlotPoints -> 20, 
    MaxRecursion -> 0]

NMaximize[{f[α, χ, 1], 0 <= α <= 2 π, 
 0 <= χ <= π}, {α, χ}],

{-0.0336509, {α -> 6.28319, χ -> 3.14159}},

FindMaximum[f[α, χ, 1], {α, 2}, {χ, 2}]

{0.291708, {α -> 3.14159, χ -> 1.5708}},
added 15 characters in body
Source Link
Junaid Aftab
Junaid Aftab
  • 1k
  • 5
  • 11

J1Final = Plot3D[ Re[new[[Alpha], [Chi], 1] - old1], {[Alpha], 0, 2 [Pi]}, {[Chi], 0, [Pi]}, PlotPoints -> 20, MaxRecursion -> 0]

J1Final = Plot3D[
  Re[new[\[Alpha], \[Chi], 1] - old[1]], {\[Alpha], 0, 
   2 \[Pi]}, {\[Chi], 0, \[Pi]}, PlotPoints -> 20, 
    MaxRecursion -> 0]

{-0.0336509, {\[Alpha] -> 6.28319, \[Chi] -> 3.14159}},

which is clearly not expected. When I run

J1Final = Plot3D[ Re[new[[Alpha], [Chi], 1] - old1], {[Alpha], 0, 2 [Pi]}, {[Chi], 0, [Pi]}, PlotPoints -> 20, MaxRecursion -> 0]

{-0.0336509, {\[Alpha] -> 6.28319, \[Chi] -> 3.14159}}

When I run

J1Final = Plot3D[
  Re[new[\[Alpha], \[Chi], 1] - old[1]], {\[Alpha], 0, 
   2 \[Pi]}, {\[Chi], 0, \[Pi]}, PlotPoints -> 20, 
    MaxRecursion -> 0]

{-0.0336509, {\[Alpha] -> 6.28319, \[Chi] -> 3.14159}},

which is clearly not expected. When I run

Source Link
Junaid Aftab
Junaid Aftab
  • 1k
  • 5
  • 11