Services & Resources / Wolfram Forums / MathGroup Archive
-----

MathGroup Archive 2012

[Date Index] [Thread Index] [Author Index]

Search the Archive

minimization

  • To: mathgroup at smc.vnet.net
  • Subject: [mg124667] minimization
  • From: Herman <btta2010 at gmail.com>
  • Date: Mon, 30 Jan 2012 05:10:09 -0500 (EST)
  • Delivered-to: l-mathgroup@mail-archive0.wolfram.com

Hello,

I want to plot the function dis[....] as a function of time, t. My problem is that I want to minimize the expression I0[....] over all values of \rho & \phi and to substitute this into the expression dis[...] to plot as a function of t. The parameters \alpha=0.1, \omega=2, r=1 depends on my choice. 

Many thanks for any comments with the syntax.

Clear[\[Rho], \[Phi]]
\[CapitalDelta][\[Alpha]_, \[Omega]0_, t_] = -\[Alpha]^2 1/
   Sqrt[\[Omega]0] \[Pi] (-1 + 
      FresnelC[Sqrt[2/\[Pi]] Sqrt[t \[Omega]0]]) FresnelC[
     Sqrt[2/\[Pi]] Sqrt[t \[Omega]0]];

                                                                      \
                                                                      \
                

\[CapitalPi][\[Alpha]_, \[Omega]0_, t_] = \[Alpha]^2 
   Integrate[(
    Sqrt[\[Pi]/
     2] (1 - 2 FresnelC[Sqrt[2/\[Pi]] Sqrt[b \[Omega]0]]) Sin[
      b \[Omega]0])/Sqrt[b], {b, 0, t}];


\[Gamma][\[Alpha]_, \[Omega]0_, 
   t_] = -\[Alpha]^2 (\[Pi] (-1 + 
      FresnelS[Sqrt[2/\[Pi]] Sqrt[t \[Omega]0]]) FresnelS[
     Sqrt[2/\[Pi]] Sqrt[t \[Omega]0]])/Sqrt[\[Omega]0];

ClearAll[\[CapitalGamma]]

\[CapitalGamma][\[Alpha]_?NumericQ, \[Omega]0_?NumericQ, 
  t_?NumericQ] := 
 NIntegrate[2*\[Gamma][\[Alpha], \[Omega]0, s], {s, 0, t}]


ClearAll[\[CapitalDelta]\[CapitalGamma]]

\[CapitalGamma][\[Alpha]_?NumericQ, \[Omega]0_?NumericQ, t_?NumericQ] 
 := NIntegrate[2*\[Gamma][\[Alpha], \[Omega]0, s], {s, 0, t}]


\[CapitalDelta]\[CapitalGamma][\[Alpha]_?NumericQ, \[Omega]0_?
   NumericQ, t_?NumericQ] := 
 NIntegrate[\[CapitalDelta][\[Alpha], \[Omega]0, s], {s, 0, t}]


\[CapitalDelta]co[\[Alpha]_?NumericQ, \[Omega]0_?NumericQ, 
  t_?NumericQ] := 
 NIntegrate[\[CapitalDelta][\[Alpha], \[Omega]0, s]*
   Cos[2 \[Omega]0 (t - s)], {s, 0, t}]


\[CapitalDelta]co[0.1, 1, 4]

0.00375065

\[CapitalDelta]si[\[Alpha]_?NumericQ, \[Omega]0_?NumericQ, 
  t_?NumericQ] := 
 NIntegrate[\[CapitalDelta][\[Alpha], \[Omega]0, s]*
   Sin[2 \[Omega]0 (t - s)], {s, 0, t}]


\[CapitalPi]co[\[Alpha]_?NumericQ, \[Omega]0_?NumericQ, t_?NumericQ] :=
  NIntegrate[\[CapitalPi][\[Alpha], \[Omega]0, s]*
   Cos[2 \[Omega]0 (t - s)], {s, 0, t}]


\[CapitalPi]si[\[Alpha]_?NumericQ, \[Omega]0_?NumericQ, t_?NumericQ] :=
  NIntegrate[\[CapitalPi][\[Alpha], \[Omega]0, s]*
   Sin[2 \[Omega]0 (t - s)], {s, 0, t}]


Clear[A0]

A0[r_] := {{1/2 Cosh[2 r], 0}, {0, 1/2 Cosh[2 r]}}

At[\[Alpha]_, \[Omega]0_, t_, r_] := 
 A0[r]*(1 - \[CapitalGamma][\[Alpha], \[Omega]0, 
      t]) + {{\[CapitalDelta]\[CapitalGamma][\[Alpha], \[Omega]0, 
      t] + (\[CapitalDelta]co[\[Alpha], \[Omega]0, 
        t] - \[CapitalPi]si[\[Alpha], \[Omega]0, 
        t]), -(\[CapitalDelta]si[\[Alpha], \[Omega]0, 
        t] - \[CapitalPi]co[\[Alpha], \[Omega]0, 
        t])}, {-(\[CapitalDelta]si[\[Alpha], \[Omega]0, 
        t] - \[CapitalPi]co[\[Alpha], \[Omega]0, 
        t]), \[CapitalDelta]\[CapitalGamma][\[Alpha], \[Omega]0, 
      t] - (\[CapitalDelta]co[\[Alpha], \[Omega]0, 
        t] - \[CapitalPi]si[\[Alpha], \[Omega]0, t])}}

Ats[\[Alpha]_, \[Omega]0_, t_, r_] := 
 A0[r]*(1 - \[CapitalGamma][\[Alpha], \[Omega]0, 
      t]) + {{\[CapitalDelta]\[CapitalGamma][\[Alpha], \[Omega]0, t], 
    0}, {0, \[CapitalDelta]\[CapitalGamma][\[Alpha], \[Omega]0, t]}}

Ct[\[Alpha]_, \[Omega]0_, t_, r_] := 
 1/2 Sinh[2 r]*(1 - \[CapitalGamma][\[Alpha], \[Omega]0, t]) {{Cos [
     2 \[Omega]0 t], 
    Sin [2 \[Omega]0 t]}, {Sin [2 \[Omega]0 t], - 
     Cos [2 \[Omega]0 t]}}



\[Sigma]t[\[Alpha]_, \[Omega]0_, t_, 
  r_] := {{At[\[Alpha], \[Omega]0, t, r], 
   Ct[\[Alpha], \[Omega]0, t, 
    r]}, {Ct[\[Alpha], \[Omega]0, t, r]\[Transpose], 
   At[\[Alpha], \[Omega]0, t, r]}}

\[Sigma]ts[\[Alpha]_, \[Omega]0_, t_, 
  r_] := {{Ats[\[Alpha], \[Omega]0, t, r], 
   Ct[\[Alpha], \[Omega]0, t, 
    r]}, {Ct[\[Alpha], \[Omega]0, t, r]\[Transpose], 
   Ats[\[Alpha], \[Omega]0, t, r]}}

I1[\[Alpha]_, \[Omega]0_, t_, r_] := 
 Det[At[\[Alpha], \[Omega]0, t, r]]

I1s[\[Alpha]_, \[Omega]0_, t_, r_] := 
 Det[Ats[\[Alpha], \[Omega]0, t, r]]

I3[\[Alpha]_, \[Omega]0_, t_, r_] := 
 Det[Ct[\[Alpha], \[Omega]0, t, r]]

I4[\[Alpha]_, \[Omega]0_, t_, r_] := 
 Det[\[Sigma]t[\[Alpha], \[Omega]0, t, r]]

I4s[\[Alpha]_, \[Omega]0_, t_, r_] := 
 Det[\[Sigma]ts[\[Alpha], \[Omega]0, t, r]]

C1[\[Alpha]_, \[Omega]0_, t_, 
  r_] := \[Sqrt](1/(
    2 I1[\[Alpha], \[Omega]0, t, 
      r]) (I1[\[Alpha], \[Omega]0, t, r]^2 + 
      I3[\[Alpha], \[Omega]0, t, r]^2 - 
      I4[\[Alpha], \[Omega]0, t, 
       r] + \[Sqrt]((I1[\[Alpha], \[Omega]0, t, r]^2 + 
           I3[\[Alpha], \[Omega]0, t, r]^2 - 
           I4[\[Alpha], \[Omega]0, t, 
            r])^2 - (2 I1[\[Alpha], \[Omega]0, t, r]*
           I3[\[Alpha], \[Omega]0, t, r])^2        )))


C1s[\[Alpha]_, \[Omega]0_, t_, 
  r_] := \[Sqrt](1/(
    2 I1s[\[Alpha], \[Omega]0, t, 
      r]) (I1s[\[Alpha], \[Omega]0, t, r]^2 + 
      I3[\[Alpha], \[Omega]0, t, r]^2 - 
      I4s[\[Alpha], \[Omega]0, t, 
       r] + \[Sqrt]((I1s[\[Alpha], \[Omega]0, t, r]^2 + 
           I3[\[Alpha], \[Omega]0, t, r]^2 - 
           I4s[\[Alpha], \[Omega]0, t, 
            r])^2 - (2 I1s[\[Alpha], \[Omega]0, t, r]*
           I3[\[Alpha], \[Omega]0, t, r])^2        )))


C2[\[Alpha]_, \[Omega]0_, t_, 
  r_] := \[Sqrt](1/(
    2 I1[\[Alpha], \[Omega]0, t, 
      r]) (I1[\[Alpha], \[Omega]0, t, r]^2 + 
      I3[\[Alpha], \[Omega]0, t, r]^2 - 
      I4[\[Alpha], \[Omega]0, t, 
       r] - \[Sqrt]((I1[\[Alpha], \[Omega]0, t, r]^2 + 
           I3[\[Alpha], \[Omega]0, t, r]^2 - 
           I4[\[Alpha], \[Omega]0, t, 
            r])^2 - (2 I1[\[Alpha], \[Omega]0, t, r]*
           I3[\[Alpha], \[Omega]0, t, r])^2        )))


C2s[\[Alpha]_, \[Omega]0_, t_, 
  r_] := \[Sqrt](1/(
    2 I1s[\[Alpha], \[Omega]0, t, 
      r]) (I1s[\[Alpha], \[Omega]0, t, r]^2 + 
      I3[\[Alpha], \[Omega]0, t, r]^2 - 
      I4s[\[Alpha], \[Omega]0, t, 
       r] - \[Sqrt]((I1s[\[Alpha], \[Omega]0, t, r]^2 + 
           I3[\[Alpha], \[Omega]0, t, r]^2 - 
           I4s[\[Alpha], \[Omega]0, t, 
            r])^2 - (2 I1s[\[Alpha], \[Omega]0, t, r]*
           I3[\[Alpha], \[Omega]0, t, r])^2        )))

an[\[Alpha]_, \[Omega]0_, t_, r_] := Sqrt[
 I1[\[Alpha], \[Omega]0, t, r]]

ans[\[Alpha]_, \[Omega]0_, t_, r_] := Sqrt[
 I1s[\[Alpha], \[Omega]0, t, r]]

\[Kappa]1[\[Alpha]_, \[Omega]0_, t_, 
  r_] := Sqrt[(an[\[Alpha], \[Omega]0, t, r] - 
    C1[\[Alpha], \[Omega]0, t, r])*(an[\[Alpha], \[Omega]0, t, r] - 
    C2[\[Alpha], \[Omega]0, t, r])]

\[Kappa]1s[\[Alpha]_, \[Omega]0_, t_, 
  r_] := Sqrt[(ans[\[Alpha], \[Omega]0, t, r] - 
    C1s[\[Alpha], \[Omega]0, t, r])*(ans[\[Alpha], \[Omega]0, t, r] - 
    C2s[\[Alpha], \[Omega]0, t, r])]

xm[\[Alpha]_, \[Omega]0_, t_, 
  r_] := (\[Kappa]1[\[Alpha], \[Omega]0, t, r]^2 + 1/4)/(
 2 \[Kappa]1[\[Alpha], \[Omega]0, t, r])

xms[\[Alpha]_, \[Omega]0_, t_, 
  r_] := (\[Kappa]1s[\[Alpha], \[Omega]0, t, r]^2 + 1/4)/(
 2 \[Kappa]1s[\[Alpha], \[Omega]0, t, r])

g[x_] := (x + 1/2) Log[x + 1/2] - (x - 1/2) Log[x - 1/2]

eof[\[Alpha]_, \[Omega]0_, t_, r_] := 
 g[xm[\[Alpha], \[Omega]0, t, r]]

eofs[\[Alpha]_, \[Omega]0_, t_, r_] := 
 g[xms[\[Alpha], \[Omega]0, t, r]]

g1[\[Alpha]_, \[Omega]0_, t_, r_] := g[an[\[Alpha], \[Omega]0, t, r]]

\[Sigma]M[\[Rho]_, \[Phi]_] := 
 Cosh[2 \[Rho]]/
  2 ({{1 + Tanh[2 \[Rho]] Cos[\[Phi]], -Tanh [
        2 \[Rho]] Sin[\[Phi]] }, {-Tanh [2 \[Rho]] Sin[\[Phi]], 
     1 - Tanh[2 \[Rho]] Cos[\[Phi]]}})

s[\[Alpha]_, \[Omega]0_, t_, r_, \[Rho]_, \[Phi]_] := 
 Inverse[At[\[Alpha], \[Omega]0, t, r] + \[Sigma]M[\[Rho], \[Phi]]]

\[Tau][\[Alpha]_, \[Omega]0_, t_, r_, \[Rho]_, \[Phi]_] := 
 At[\[Alpha], \[Omega]0, t, r] - 
  Ct[\[Alpha], \[Omega]0, t, r].s[\[Alpha], \[Omega]0, t, 
    r, \[Rho], \[Phi]].Ct[\[Alpha], \[Omega]0, t, r]\[Transpose]

I0[\[Alpha]_, \[Omega]0_, t_, r_, \[Rho]_, \[Phi]_] := 
 Re[Det[\[Tau][\[Alpha], \[Omega]0, t, r, \[Rho], \[Phi]]]]

{\[Rho], \[Phi]} = {\[Rho], \[Phi]} /. 
   Table[FindMinimum[{I0[0.1, 2, t, 2, \[Rho], \[Phi]], \[Rho] >= 0, 
      0 <= \[Phi] <= 2 \[Pi]}, {\[Rho], \[Phi]}], {t, 0, 2}];

ReplaceAll::rmix: Elements of {0.25,{1->0.000876434}} are a mixture \
of lists and nonlists. >>

ReplaceAll::rmix: Elements of {7.8194,{1->0.000200853}} are a mixture \
of lists and nonlists. >>

ReplaceAll::rmix: Elements of {13.333,{1->0.000272136}} are a mixture \
of lists and nonlists. >>

General::stop: Further output of ReplaceAll::rmix will be suppressed \
during this calculation. >>

Set::shape: Lists {\[Rho],\[Phi]} and \
{{1,0.628319}/.{0.25,{1->0.000876434}},{1,0.628319}/.{7.8194,{1->0.\
000200853}},{1,0.628319}/.{13.333,{1->0.000272136}}} are not the same \
shape. >>

k[\[Alpha]_, \[Omega]0_, t_, r_, \[Rho]_, \[Phi]_] := Sqrt[
 I0[\[Alpha], \[Omega]0, t, r, \[Rho], \[Phi]]]

k1[\[Alpha]_, \[Omega]0_, t_, r_, \[Rho]_, \[Phi]_] := 
 Re[k[\[Alpha], \[Omega]0, t, r, \[Rho], \[Phi]]]

h[\[Alpha]_, \[Omega]0_, t_, r_] := 
 Re[2 (I1[\[Alpha], \[Omega]0, t, r] + 
     I3[\[Alpha], \[Omega]0, t, r])]


h1[\[Alpha]_, \[Omega]0_, t_, r_] := 
 Re[Sqrt[(h[\[Alpha], \[Omega]0, t, r] + Sqrt[
   h[\[Alpha], \[Omega]0, t, r]^2 - 4 I4[\[Alpha], \[Omega]0, t, r]])/
  2]]

h2[\[Alpha]_, \[Omega]0_, t_, r_] := Sqrt[(
 h[\[Alpha], \[Omega]0, t, r] - Sqrt[
  h[\[Alpha], \[Omega]0, t, r]^2 - 
   4 I4[\[Alpha], \[Omega]0, t, r]])/2]

s1[\[Alpha]_, \[Omega]0_, t_, r_] := 
 Re[g[h1[\[Alpha], \[Omega]0, t, r]]]

s2[\[Alpha]_, \[Omega]0_, t_, r_] := 
 Re[g[h2[\[Alpha], \[Omega]0, t, r]]]

dis[\[Alpha]_, \[Omega]0_, t_, r_, \[Rho]_, \[Phi]_] := 
 Re[g1[\[Alpha], \[Omega]0, t, r] + 
   k1[\[Alpha], \[Omega]0, t, r, \[Rho], \[Phi]] - 
   s2[\[Alpha], \[Omega]0, t, r] - s1[\[Alpha], \[Omega]0, t, r]]

\[Alpha] = 0.1;
\[Omega]0 = 2;
\[Rho] = 1;
\[Phi] = 0.6283185307179586;

mylisth = 
 Table[{t, dis[\[Alpha], \[Omega]0, t, 2, \[Rho], \[Phi]]}, {t, 0, 10,
    2}]

$Aborted

QD = ListPlot[mylisth, Joined -> True, PlotStyle -> {Blue, Thick}, 
  AxesOrigin -> {0, 0}]

mylist = Table[{t, eof[\[Alpha], \[Omega]0, t, 2]}, {t, 0, 10, 2}]

enof = ListPlot[mylist, Joined -> True, 
  PlotStyle -> {Dashed, Red, Thick}, AxesOrigin -> {0, 0}]

Show[QD, enof, AxesStyle -> Thickness[0.002], PlotRange -> All, 
 AxesOrigin -> {0, 0}]



  • Prev by Date: Re: navigate notebook, further question
  • Next by Date: Locator-set Bezier curves mapped to 3D surface
  • Previous by thread: Re: navigate notebook, further question
  • Next by thread: Locator-set Bezier curves mapped to 3D surface