ff[x_]=Exp[-x^2]

In class we found that the parametric vector equation of the surface which determines a solution of Burgers’ equation is

{ff[ξ] s+ξ,s,ff[ξ]}

We can plot it using ParametricPlot3D

MoCBurgersSur1f1=Show[ParametricPlot3D[{ξ,0,ff[ξ]},{ξ,-3,3},PlotPoints->{100},PlotStyle->{{Thickness[0.01],RGBColor[0,0.6,0]}}],ParametricPlot3D[{ff[ξ] s+ξ,s,ff[ξ]},{s,0,2.8},{ξ,-3,3},PlotPoints->{100,100},Mesh->{20,0},BoundaryStyle->Automatic],
PlotRange->{{-3,3},{0,2.8},{0,1.05}},PlotRangePadding->None,BoxRatios->{4,2,1},AxesLabel->{x,t,z},AxesEdge->{{-1,-1},{1,-1},{-1,-1}},ImageSize->800]

Pics={"MoCBurgersSur1f1"};

And from this picture it is clear that this is not a graph of function of x and t.  This can be seen by looking at the projected characteristics:

Length[Table[ξ,{ξ,-3,3,.05}]]

MoCBurgersChaP1f1=ParametricPlot[Evaluate[Table[{(E^(-(ξ^2))) s+ξ,s},{ξ,-3.5,4,.05}]],{s,0,3},PlotStyle->{Thickness[0.002]},PlotRange->{{-3,3},{0,2.8}},ImageSize->800]

Pics=Append[Pics,"MoCBurgersChaP1f1"];

However, if we restrict time, we might get a graph of a function of x and t:

MoCBurgersSur2f1=Show[ParametricPlot3D[{ξ,0,ff[ξ]},{ξ,-3,3},PlotPoints->{100},PlotStyle->{{Thickness[0.01],RGBColor[0,0.6,0]}}],ParametricPlot3D[{ff[ξ] s+ξ,s,ff[ξ]},{s,0,1},{ξ,-3,3},PlotPoints->{100,100},Mesh->{20,0},BoundaryStyle->Automatic],
PlotRange->{{-3,3},{0,1},{0,1.05}},PlotRangePadding->None,BoxRatios->{4,1,1},AxesLabel->{x,t,z},AxesEdge->{{-1,-1},{1,-1},{-1,-1}},ImageSize->800]

Pics

Pics=Append[Pics,"MoCBurgersSur2f1"];

Pics

MoCBurgersChaP2f1=ParametricPlot[Evaluate[Table[{(E^(-(ξ^2))) s+ξ,s},{ξ,-3.5,4,.05}]],{s,0,3},PlotStyle->{Thickness[0.002]},PlotRange->{{-3,3},{0,1}},ImageSize->800]

Pics=Append[Pics,"MoCBurgersChaP2f1"]

The above surface looks like a graph of a function. Next we will find the maximum value of time t, that is s in our setting for which our surface will be a graph of a function. To this end we look at the cross sections of the surface with fixed time, that is fixed s. We study the parametric equation

{ff[ξ] s+ξ,ff[ξ]}

in xz-plane. For this Manipulate[] is a great tool.

When you execute the Manipulate[] command, click on the + sign next to the “s” slider. That will give you the information about the s values that are used in the plot. We would like to find the smallest s for which the resulting graph is not a function, that is does not satisfy the vertical line test.

Manipulate[ParametricPlot[{ff[ξ] s+ξ,ff[ξ]},{ξ,-4,4},PlotStyle->{{Thickness[0.005],If[s<0.1,RGBColor[0,0.6,0],RGBColor[0,0,0.6]]}},PlotRange->{{-3,3},{-0.21,1.21}},GridLines->{Range[-4,4,0.2],Range[-1,2,0.2]},AspectRatio->1/3,PlotLabel->TableForm[{"s=",NumberForm[s,{3,3}]},TableDirections->Row,TableSpacing->0.2],ImageSize->500],{s,0,2.8}]

MoCBurgersInTi1f1=Table[ParametricPlot[{ff[ξ] s+ξ,ff[ξ]},{ξ,-4,4},PlotStyle->{{Thickness[0.005],If[s<0.1,RGBColor[0,0.6,0],RGBColor[0,0,0.6]]}},PlotRange->{{-3,3},{-0.21,1.21}},GridLines->{Range[-4,4,0.2],Range[-1,2,0.2]},AspectRatio->1/3,PlotLabel->TableForm[{"s=",NumberForm[N[s,5],{4,3}]},TableDirections->Row,TableSpacing->0.2],ImageSize->800],{s,0,2.8,0.025}];

Length[MoCBurgersInTi1f1]

NumberForm[N[2.725,5],{4,3}]

Table[s,{s,0,2.8,0.025}]

MoCBurgersInTi1f1[[112]]

Pics=Append[Pics,"MoCBurgersInTi1f1"]

Pics

Looking at the above manipulation, I conclude that at around s≈1.205 the graph is not a function. The vertical tangent line occurs around x≈1.41. These are my guesses that we will verify below.

The vertical tangent line will occur when the first component of the tangent vector is equal to 0. Let us calculate the tangent vector:

D[{ff[ξ] s+ξ,ff[ξ]},ξ]

For which s (time) the first component becomes 0?

Solve[1-2 (E^(-(ξ^2))) s ξ==0,s]

Pics

MoCBurgersSur3f1=Show[
ParametricPlot3D[{ξ,0,ff[ξ]},{ξ,-3,3},PlotPoints->{100},PlotStyle->{{Thickness[0.01],RGBColor[0,0.6,0]}}],ParametricPlot3D[{ff[ξ] s+ξ,s,ff[ξ]},{s,0,2.8},{ξ,-3,3},PlotPoints->{100,100},Mesh->{20,0},BoundaryStyle->Automatic],
ParametricPlot3D[{(1/(2 ξ))+ξ,((E^(ξ^2))/(2 ξ)),(E^(-(ξ^2)))},{ξ,0,26},PlotPoints->{100},PlotStyle->{{RGBColor[1,0,0],Thickness[0.005]}}],PlotRange->{{-3,3},{0,2.8},{0,1.05}},PlotRangePadding->None,BoxRatios->{4,2,1},AxesLabel->{x,t,z},AxesEdge->{{-1,-1},{1,-1},{-1,-1}},ImageSize->800]

Pics=Append[Pics,"MoCBurgersSur3f1"]

MoCBurgersChaP3f1=Show[ParametricPlot[Evaluate[Table[{(E^(-(ξ^2))) s+ξ,s},{ξ,-3.5,4,.05}]],{s,0,3},PlotStyle->{Thickness[0.002]}],ParametricPlot[{(1/(2 ξ))+ξ,((E^(ξ^2))/(2 ξ))},{ξ,0,2},PlotPoints->{100},PlotStyle->{{RGBColor[1,0,0],Thickness[0.005]}}],PlotRange->{{-3,3},{0,2.8}},ImageSize->800]

Pics=Append[Pics,"MoCBurgersChaP3f1"]

Thus s must equal the above expression in ξ. Let us check that expression of ξ:

MoCFind1stTimef1=Plot[((E^(ξ^2))/(2 ξ)),{ξ,-2,2},PlotRange->{-4,4},GridLines->{Range[-4,4,0.2],Range[-4,4,0.2]}]

Pics=Append[Pics,"MoCFind1stTimef1"]

We want a positive s, the smallest positive s. In the above plot s is on the vertical axis. Let us find the smallest such s:

D[((E^(ξ^2))/(2 ξ)),ξ]

Solve[(E^(ξ^2))-((E^(ξ^2))/(2 (ξ^2)))==0,ξ]

Clearly we need ξ = 1/(Sqrt[2]). Thus, the number below is the s that we seek

(((E^(ξ^2))/(2 ξ)))/.{ξ->(1/(Sqrt[2]))}

N[(Sqrt[(E/2)])]

Ok, this is sufficiently close to what I guessed, around s≈1.205

Now check x. The x coordinate is in fact  ff[ξ] s+ξ

(ff[ξ] s+ξ)/.{ξ->(1/(Sqrt[2])),s->(Sqrt[(E/2)]) }

N[(Sqrt[2])]

This is much closer to my guess, around x≈1.41.

ParametricPlot3D[{ff[ξ] s+ξ,s,ff[ξ]},{s,0,(Sqrt[(E/2)])},{ξ,-3,3},PlotPoints->{100,100},Mesh->{20,0},BoxRatios->{4,3,1},AxesLabel->{x,t,z},ImageSize->500]

Let us check whether Mathematica can solve the following two equations for ξ and s.

Solve[{x==(E^(-(ξ^2))) s+ξ,y==s},{ξ,s}]

Let us plot many projected characteristics:

ParametricPlot[Evaluate[Table[{(E^(-(ξ^2))) s+ξ,s},{ξ,-2,4,.05}]],{s,0,3},PlotStyle->{Thickness[0.003]},Epilog->{{Red,Line[{{-10,(Sqrt[(E/2)])},{10,(Sqrt[(E/2)])}}]}},PlotRange->{{-2,4},{0,3}},ImageSize->600]

FullSimplify[{-(E^((1/2) ProductLog[-(1/(2 (s^2)))])) s (-1+ProductLog[-(1/(2 (s^2)))]),(E^((1/2) ProductLog[-(1/(2 (s^2)))]))},And[s>(Sqrt[E/2])]]

Simplify[(E^(ProductLog[-(1/(2 (s^2)))])),And[s>(Sqrt[E/2])]]

MoCBurgersInTi2f1=Table[ParametricPlot[{ff[ξ] s+ξ,ff[ξ]},{ξ,-4,4},PlotStyle->{{Thickness[0.005],If[s<0.1,RGBColor[0,0.6,0],RGBColor[0,0,0.6]]}},
Epilog->{If[s<(Sqrt[(E/2)]),{},{PointSize[0.01],RGBColor[0.8,0,0],Point[{-(E^((1/2) ProductLog[-(1/(2 (s^2)))])) s (-1+ProductLog[-(1/(2 (s^2)))]),(E^((1/2) ProductLog[-(1/(2 (s^2)))]))}],Point[{(E^((1/2) ProductLog[-1,-(1/(2 (s^2)))])) s+((Sqrt[-ProductLog[-1,-(1/(2 (s^2)))]])/(Sqrt[2])),(E^((1/2) ProductLog[-1,-(1/(2 (s^2)))]))}]}]},PlotRange->{{-3,3},{-0.21,1.21}},GridLines->{Range[-4,4,0.2],Range[-1,2,0.2]},AspectRatio->1/3,PlotLabel->TableForm[{"s=",NumberForm[N[s,5],{4,3}]},TableDirections->Row,TableSpacing->0.2],ImageSize->800],{s,0,2.8,0.025}];

Pics=Append[Pics,"MoCBurgersInTi2f1"]

MoCBurgersInTi2f1[[104]]

Let us try some other initial condition:

Clear[ff1]; ff1[x_]=Sin[x]

ParametricPlot[Evaluate[Table[{ff1[ξ] s+ξ,s},{ξ,-2Pi,2 Pi,(Pi/32)}]],{s,0,20},PlotStyle->{Thickness[0.001]},PlotRange->{{-2Pi,2 Pi},{0,2}},ImageSize->800,AspectRatio->Automatic]

ParametricPlot3D[{ff1[ξ] s+ξ,s,ff1[ξ]},{s,0,1},{ξ,-2 Pi,2 Pi},PlotPoints->{100,100},Mesh->{20,0},BoxRatios->{4,3,1},AxesLabel->{x,t,z},ImageSize->500]

Clear[ff2]; ff2[x_]=-ArcTan[x]

ParametricPlot[Evaluate[Table[{ff2[ξ] s+ξ,s},{ξ,-4,4,0.1}]],{s,0,20},PlotStyle->{Thickness[0.001]},PlotRange->{{-2,2},{0,2}},ImageSize->400,AspectRatio->Automatic]

ParametricPlot3D[{ff2[ξ] s+ξ,s,ff2[ξ]},{s,0,2},{ξ,-2 Pi,2 Pi},PlotPoints->{100,100},Mesh->{20,0},BoxRatios->{4,3,1},AxesLabel->{x,t,z},ImageSize->500]

In this section I illustrate that we found correct points at which the tangent lines are vertical

Now that we have found where the vertical tangents are, we can illustrate them in Manipulate:

For this for each s ≥(Sqrt[E/2]) we need to find ξ-s that solve the following equation (the equation below to be solved for ξ requires functions that you did not learn in school. Mathematica calls them ProductLog[] functions, other common name is W-functions

FullSimplify[Solve[1-2 (E^(-(ξ^2))) s ξ==0,ξ],And[s>(Sqrt[E/2])]]

Let us verify these solutions:

FullSimplify[(1-2 (E^(-(ξ^2))) s ξ)/.{{ξ->((Sqrt[-ProductLog[-(1/(2 (s^2)))]])/(Sqrt[2]))},{ξ->((I (Sqrt[ProductLog[-(1/(2 (s^2)))]]))/(Sqrt[2]))}},And[s>(Sqrt[E/2])]]

Unfortunately, the second solution is wrong.

This is not very nice of Mathematica, it gave us a wrong solution. Let us try Reduce

FullSimplify[Reduce[1-2 (E^(-(ξ^2))) s ξ==0,ξ],And[s>(Sqrt[E/2])]]

I cannot believe that it is true what Mathematica is saying, that it cannot solve this equation. So, I solved the above equation by hand. I can provide details later, the solutions are

{{ξ-> (Sqrt[-(1/2)ProductLog[0,-(1/(2 (s^2)))]])},{ξ-> (Sqrt[-(1/2)ProductLog[-1,-(1/(2 (s^2)))]])}}

For example for s=2

FullSimplify[(1-2 (E^(-(ξ^2))) s ξ)/.{{ξ-> (Sqrt[-(1/2)ProductLog[0,-(1/(2 (s^2)))]])},{ξ-> (Sqrt[-(1/2)ProductLog[-1,-(1/(2 (s^2)))]])}},And[s>(Sqrt[E/2])]]

FullSimplify[(1-2 (E^(-(ξ^2))) s ξ)/.{ξ-> (Sqrt[-(1/2)ProductLog[-1,-(1/(2 (s^2)))]])},And[s>(Sqrt[E/2])]]

It is interesting that Mathematica does not know that the last number is 0. However, we can check that numerically for specific s. But I will approach it differently. I calculate the expression, which should be 1, to make   (1-2 (e^(-(ξ^2))) s ξ) equal to 0

FullSimplify[(2 (E^(-(ξ^2))) s ξ)/.{ξ-> (Sqrt[-(1/2)ProductLog[-1,-(1/(2 (s^2)))]])},And[s>(Sqrt[E/2])]]

So, this does not work either. Now calculate the square of the expression (2 (e^(-(ξ^2))) s ξ)

FullSimplify[(((2 (E^(-(ξ^2))) s ξ))^2)/.{ξ-> (Sqrt[-(1/2)ProductLog[-1,-(1/(2 (s^2)))]])},And[s>(Sqrt[E/2])]]

Finally this worked. We calculated (((2 (e^(-(ξ^2))) s ξ))^2)=1, since (2 (e^(-(ξ^2))) s ξ)>0, we can deduce that (2 (e^(-(ξ^2))) s ξ)=1.

Next we calculate the points at which the tangent lines are vertical

FullSimplify[{ff[ξ] s+ξ,ff[ξ]}/.{{ξ->(Sqrt[-(1/2)ProductLog[0,-(1/(2 (s^2)))]])},{ξ->(Sqrt[-(1/2)ProductLog[-1,-(1/(2 (s^2)))]])}},And[s>(Sqrt[E/2])]]

Manipulate[ParametricPlot[{ff[ξ] s+ξ,ff[ξ]},{ξ,-4,4},Epilog->{If[s<(Sqrt[(E/2)]),{},{PointSize[0.01],RGBColor[0.6,0,0],Point[{-(E^((1/2) ProductLog[-(1/(2 (s^2)))])) s (-1+ProductLog[-(1/(2 (s^2)))]),(E^((1/2) ProductLog[-(1/(2 (s^2)))]))}],Point[{(E^((1/2) ProductLog[-1,-(1/(2 (s^2)))])) s+((Sqrt[-ProductLog[-1,-(1/(2 (s^2)))]])/(Sqrt[2])),(E^((1/2) ProductLog[-1,-(1/(2 (s^2)))]))}]}]},PlotRange->{{-4,4},{-0.1,1.1}},GridLines->{Range[-4,4,0.2],Range[0,1,0.2]},AspectRatio->1/2,ImageSize->500],{s,0,4}]

Show[
ParametricPlot3D[{ff[ξ] s+ξ,s,ff[ξ]},{s,0,6},{ξ,-3,3},PlotPoints->{100,100},Mesh->{20,0},PlotStyle->{{Opacity[0.5]}}], 
ParametricPlot3D[{-(E^((1/2) ProductLog[-(1/(2 (s^2)))])) s (-1+ProductLog[-(1/(2 (s^2)))]),s,(E^((1/2) ProductLog[-(1/(2 (s^2)))]))},{s,(Sqrt[E/2]),26},PlotPoints->{100},PlotStyle->{{RGBColor[1,0,0],Thickness[0.005]}}],ParametricPlot3D[{-(E^((1/2) ProductLog[-1,-(1/(2 (s^2)))])) s (-1+ProductLog[-1,-(1/(2 (s^2)))]),s,(E^((1/2) ProductLog[-1,-(1/(2 (s^2)))]))},{s,(Sqrt[E/2]),6},PlotPoints->{100},PlotStyle->{{RGBColor[1,0,0],Thickness[0.005]}}],PlotRange->{{-3,3},{0,3},{0,1}},
BoxRatios->{4,2,1},AxesLabel->{x,t,z},ImageSize->500]

But, there is another, simpler equation for the red curve:

Solve[1-2 (E^(-(ξ^2))) s ξ==0,s]

{ff[ξ] s+ξ,s,ff[ξ]}/.{s->((E^(ξ^2))/(2 ξ))}

Show[
ParametricPlot3D[{ff[ξ] s+ξ,s,ff[ξ]},{s,0,6},{ξ,-3,3},PlotPoints->{100,100},Mesh->{20,0},PlotStyle->{{Opacity[0.75]}}], 
ParametricPlot3D[{(1/(2 ξ))+ξ,((E^(ξ^2))/(2 ξ)),(E^(-(ξ^2)))},{ξ,0,26},PlotPoints->{100},PlotStyle->{{RGBColor[1,0,0],Thickness[0.005]}}],PlotRange->{{-3,3},{0,3},{-0.1,1.1}},
BoxRatios->{4,2,1},AxesLabel->{x,t,z},ImageSize->600]

Show[
ParametricPlot[Evaluate[Table[{(E^(-(ξ^2))) s+ξ,s},{ξ,-4,7,.05}]],{s,0,4},PlotStyle->{Thickness[0.002]}],Graphics[{RGBColor[1,0.5,0],Thickness[0.005],Line[{{-10,(Sqrt[E/2])},{10,(Sqrt[E/2])}}]}],ParametricPlot[Evaluate[{(1/(2 ξ))+ξ,((E^(ξ^2))/(2 ξ))}],{ξ,0,3},PlotPoints->{100},PlotStyle->{{RGBColor[1,0,0],Thickness[0.005]}}],PlotRange->{{-2,4},{0,3}},ImageSize->600]

Export

SetDirectory["C:\\Dropbox\\Work\\myweb\\Courses\\Math_pages\\Math_430"]

NotebookDirectory[]

NotebookFileName[]

dds=0.3&/@Range[Length[MoCBurgersInTi1f1]];

Export["MoCBurgersInTi1f1.gif",MoCBurgersInTi1f1,"AnimationRepetitions"->1,"ImageSize"->800,"DisplayDurations"->dds]

Export["MoCBurgersInTi2f1.gif",MoCBurgersInTi2f1,"AnimationRepetitions"->Infinity,"ImageSize"->800,"DisplayDurations"->dds]

Export["MoCBurgersInTi2s1f1.gif",MoCBurgersInTi2f1[[1]],"ImageSize"->800]

Export["MoCBurgersInTi1s1f1.gif",MoCBurgersInTi1f1[[1]],"ImageSize"->800]

Pics

Export["MoCBurgersSur1f1.gif",MoCBurgersSur1f1,"ImageSize"->800]; 
Export["MoCBurgersChaP1f1.gif",MoCBurgersChaP1f1,"ImageSize"->800];Export["MoCBurgersSur2f1.gif",MoCBurgersSur2f1,"ImageSize"->800];Export["MoCBurgersChaP2f1.gif",MoCBurgersChaP2f1,"ImageSize"->800];Export["MoCBurgersSur3f1.gif",MoCBurgersSur3f1,"ImageSize"->800];Export["MoCBurgersChaP3f1.gif",MoCBurgersChaP3f1,"ImageSize"->800];
Export["MoCFind1stTimef1.gif",MoCFind1stTimef1,"ImageSize"->800];

(* Export["MoCCirclesCha1f1.png",MoCCirclesCha1f1,"PNG",ImageResolution->1200];Export["MoCCirclesCha2f1.png",MoCCirclesCha2f1,"PNG",ImageResolution->1200];
Export["MoCCirclesSur1f1.png",MoCCirclesSur1f1,"PNG",ImageResolution->1200];Export["MoCCirclesSur2f1.png",MoCCirclesSur2f1,"PNG",ImageResolution->1200];Export["MoCCirclesSur1ef1.png",MoCCirclesSur1ef1,"PNG",ImageResolution->1200];Export["MoCCirclesSur2ef1.png",MoCCirclesSur2ef1,"PNG",ImageResolution->1200]  *)

Plot[2 x Exp[-x^2],{x,-3,3}]

Solve[2 x Exp[-x^2]==1/2,x]

N[%]

FullSimplify[(2 x Exp[-x^2]-1/2)/.{{x->-I (Sqrt[(1/2) ProductLog[-(1/8)]])},{x->-I (Sqrt[(1/2) ProductLog[-1,-(1/8)]])}}]

N[%]

Reduce[2 x Exp[-x^2]==1/2,x]

Solve[2 x Exp[-x^2]==y,x]

FullSimplify[(2 x Exp[-x^2]-y)/.{{x->-((I (Sqrt[ProductLog[-((y^2)/2)]]))/(Sqrt[2]))},{x->((I (Sqrt[ProductLog[-((y^2)/2)]]))/(Sqrt[2]))}},And[y>0]]

FullSimplify[(2 x Exp[-x^2]-y)/.{{x->-((I (Sqrt[ProductLog[-((y^2)/2)]]))/(Sqrt[2]))},{x->-((I (Sqrt[ProductLog[1,-((y^2)/2)]]))/(Sqrt[2]))}},And[y>0]]

FullSimplify[((((2 x Exp[-x^2]))^2)-(y^2))/.{{x->-((I (Sqrt[ProductLog[-((y^2)/2)]]))/(Sqrt[2]))},{x->-((I (Sqrt[ProductLog[-1,-((y^2)/2)]]))/(Sqrt[2]))}},And[y>0]]

Plot[(x)/.{{x->((Sqrt[-ProductLog[-((y^2)/2)]])/(Sqrt[2]))},{x->((Sqrt[-ProductLog[-1,-((y^2)/2)]])/(Sqrt[2]))}},{y,0,(Sqrt[2/E])},PlotRange->All]

Table[((Sqrt[-ProductLog[-1,-((y^2)/2)]])/(Sqrt[2])),{y,0.1,1,0.1}]

Solve[a b I/(a+b I)==4-2 I&&a∈Reals&&b∈Reals,{a,b}]

Solve[2 x Exp[-x^2]==1/2&&x∈Reals,{x}]

(2 x Exp[-x^2]-1/2)/.{{x->(NumericalApproximation[Root, (RowDefault["0.269", FEExpressionsNumericalApproximationElider]), Root[{(E^((#1)^2))-4 #1&,0.26872044315376317231021701484451151804`20.50140956162433}], ])},{x->(NumericalApproximation[Root, (RowDefault["1.28", FEExpressionsNumericalApproximationElider]), Root[{(E^((#1)^2))-4 #1&,1.27704457333651607685103172656025660725`20.30324448901622}], ])}}

Reduce[2 x Exp[-x^2]==1/2&&x∈Reals,{x}]