Quit[];

Mecánica Clásica 2018 1c - Turno A

El problema es encontrar la superficie de revolución de área mínima definida por la curva y(x) en el intervalo x∈[-L, L], y tal que  y(±L) = 1. 

Van dos ejemplos de tales superficies, la función a la izquierda y la superficie de revolución a la derecha.

Show[#, ImageSize-> 400]&/@{Plot[(Sin[π (x+(1/2))] +1), {x, -1/2, 1/2}, PlotRange-> {0, All}], ParametricPlot3D[{x, (Sin[π (x+(1/2))] +1)  Cos[ϕ],  (Sin[π (x+(1/2))] +1)  Sin[ϕ]}, {x, -1/2, 1/2}, {ϕ, 0, 2π}, BoxRatios->{3, 1, 1}]}

Show[#, ImageSize-> 400]&/@{Plot[(((x^2)+1)/2), {x, -1, 1}, PlotRange-> {0, All}],ParametricPlot3D[{x, (1/2)((x^2)+1)  Cos[ϕ],(1/2)  ((x^2)+1)  Sin[ϕ]}, {x, -1, 1}, {ϕ, 0, 2π}, BoxRatios->{3, 1, 1}]}

El área de la superficie de revolución es

A[y]= 2π(∫_(-L)^L)y(x) (Sqrt[1 + y'(((x))^2)])dx.

Vimos en clase que las soluciones catenarias del problema de extremización  son de la forma

y(x)= (1/α)Cosh (α x).

Debido a las condiciones en los extremos del intervalo, α debe ser solución de la ecuación

α = Cosh (α L).

Dependiendo del valor de L, esta ecuación puede tener dos, una o ninguna solución, como es fácil de ver gráficamente:

{L1, L2, L3} = {0.5, 0.6627,0.8};
Plot[{α, Cosh[α L1], Cosh[α L2], Cosh[α L3]}, {α, 0, 5}, 
PlotStyle->{{Thick, Gray}, {Thick, Orange}, {Thick,Red}, {Thick,Green}},
AspectRatio->Automatic, PlotRange-> {0,5},
Background->Black,
ImageMargins->20,
ImageSize->500,
AxesStyle->Directive[White, Thick],
PlotLegends->"Expressions"
]

El valor de (Subscript[L, c]) que marca la transción entre ninguna o dos soluciones es tal que la recta α es tangente al gráfico de la función Cosh (α L). Eso da dos ecuaciones. En particular, el producto (Subscript[x, c]) = (Subscript[L, c])(Subscript[α, c]) satisface la ecuación

(Subscript[x, c]) = Coth (Subscript[x, c]).

La solución para (Subscript[x, c]) puede hallarse mediante FindRoot o usando el comando FixedPoint, ya que el problema está expresado como x = f(x).

FindRoot[x == Coth[x], {x, 1}][[1]][[2]]

xc = FixedPoint[Coth, 1.]

Este valor del producto L α corresponde a 

(Subscript[L, c])≃ 0.662743

(Subscript[α, c])≃1.8101705806989774`

En efecto:

xc = FixedPoint[Coth, 1.];
Lc = (Sqrt[(xc^2)-1])
αc = xc/Lc

Podemos definir funciones que encuentren numéricamente las raíces de la ecuación 

α - Cosh (α L) = 0, 

en el caso en que existan. Como hay dos raíces (Subscript[α, 1]) y (Subscript[α, 2]), tales que (Subscript[α, 1])< (Subscript[α, c])< (Subscript[α, 2]), el problema se complica un poco, porque el Mathematica busca una sola raíz, y a veces puede ir a parar a una, y a veces a la otra. 

Si el valor tentativo para iniciar la búsqueda se fija en (Subscript[α, pr])= 1, FindRoot encuentra siempre la raíz más pequeña, (Subscript[α, 1]). Para encontrar la segunda raíz, podemos definir una nueva función que no tenga una raíz en (Subscript[α, 1]) pero que sí la siga teniendo en (Subscript[α, 2]). Eso puede conseguirse buscando las raíces de 

((α - Cosh (α L))/(α-(Subscript[α, 1]))) = 0

(Estámos usando implícitamente que el cero de la función α - Cosh(α L) es simple, de modo que en la vecindad de (Subscript[α, 1]) la función α - Cosh(α L) se comporta linealmente).

Así, para encontrar la segunda raíz tenemos que usar el resultado obtenido para la primera.

(*Auxiliare*)

xc = FixedPoint[Coth, 1.];
Lc = (Sqrt[(xc^2)-1]);
αc = xc/Lc;

(*La primera raíz *)
(* ?NumericQ incluido en la definición de la función hace que no intente evaluarla a menos que x sea un número. Es necesario porque FindRoot no opera simbólicamente. Es un comando que necesita ser alimentado por números contantes y sonantes. *)

α1[x_?NumericQ]:=Module[{α, y = x},FindRoot[α - Cosh[α y] == 0, {α, 1}][[1]][[2]]]; 

(*La segunda raíz *)
α2[x_?NumericQ]:=Module[{α, y = x},FindRoot[((α- Cosh[α y])/(α - α1[x])) == 0, {α, αc}][[1]][[2]]];

(* Las áreas de la superficie de revolución correspondientes a cada raíz [¡demostrarlo!] *)
A1[L_]:= ((2π)/(α1[L]))(L + (Sqrt[((α1[L])^2)-1]));
A2[L_]:= ((2π)/(α2[L]))(L + (Sqrt[((α2[L])^2)-1]));
Ac = A1[Lc];

Abajo, el gráfico de las áreas raíces (Subscript[α, 2]) y (Subscript[α, 2]) como funciones de L. Notar que más allá de L = (Subscript[L, c]) no existen soluciones.

Show[
Graphics[{Yellow, AbsoluteThickness[2],Dashed,  Line[{{Lc, 0}, {Lc, α1[Lc]}}]}],
Plot[{α1[L],α2[L]} , {L, 0.01, Lc},PlotStyle->{{Thick, Gray}, {Thick, Orange}, {Thick,Red}, {Thick,Yellow}},PlotLegends->"Expressions"],
Background->Black,
ImageMargins->20,
ImageSize->500,
AspectRatio-> 1,
Axes-> True,
PlotRange-> {0, 8},
AxesStyle->Directive[White, Thick]
]

Manipulemos: variando L se ve cómo aparecen, se funden y desaparecen las dos raíces.

Manipulate[
Show[
If[L < Lc, Graphics[{AbsolutePointSize[10],Green,Point[α1[L]{1, 1}]}], Graphics[]],
If[L < Lc, Graphics[{AbsolutePointSize[10],Yellow, Point[α2[L]{1, 1}]}],Graphics[]],
Plot[{x, Cosh[L x]}, {x, 0, 10}], 
ImageMargins->20,
ImageSize->400,
Axes-> True,
AxesStyle->Directive[White, Thick],
PlotRange-> {{0, 10}, {0, 10}},
AspectRatio-> 1,
Background-> Black
],
{{L, 0.4}, 0.25, 2Lc, 0.001, Appearance-> "Open"}]

Abajo, el gráfico de las áreas (Subscript[A, 1]) y (Subscript[A, 2]) como funciones de L. Notar que más allá de L = (Subscript[L, c]) no existen soluciones.

Show[
Graphics[{Yellow, AbsoluteThickness[2],Dashed,  Line[{{Lc, 0}, {Lc, Ac}}]}],
Plot[{A1[L],A2[L]} , {L, 0.01, 0.66},PlotStyle->{{Thick, Gray}, {Thick, Orange}},PlotLegends->"Expressions"],
Background->Black,
ImageMargins->20,
ImageSize->500,
AspectRatio-> 1,
Axes-> True,
AxesStyle->Directive[White, Thick]
]

La solución de Goldschmidt: la "función" (Subscript[y, G])(x) que consiste en los segmentos

 {-L,1}->{-L,0}-> {L, 0}, {L, 1}  
 
genera una superficie de revolución que consiste en dos discos de radio 1 unidos por un filamento sobre el eje x. Independientemente del valor de L, el área de esta superficie es (Subscript[A, G ])= 2π, el área de los dos discos de radio 1.

La función (Subscript[y, G]) queda afuera de la familia de funciones continuas y derivables contempladas en el cálculo variacional, pero genera de todos modos una superficie admisible. 

Si graficamos ahora las tres áreas, (Subscript[A, 1]), (Subscript[A, 2]) y (Subscript[A, G]), nos encontramos con una situación no prevista: existe un L máximo, menor que (Subscript[L, c]), tal que la solución de Goldschmidt da un área menor que la de las catenarias.

AG[L_]:= 2π;
Show[
Graphics[{Yellow, AbsoluteThickness[2],Dashed,  Line[{{Lc, 0}, {Lc, Ac}}]}],
Plot[{AG[L], A1[L],A2[L]} , {L, 0.01, 0.66},PlotStyle->{{Green, Thickness[0.006]}, {Thick, Orange}, {Thick,Red}},PlotLegends->"Expressions"],
Background->Black,
ImageMargins->20,
ImageSize->500,
AspectRatio-> 1,
Axes-> True,
AxesStyle->Directive[White, Thick]
]

El valor del (Subscript[L, máx]) se encuentra numéricamente:

FindRoot[A1[L] == 2π, {L, 0.5}]

En el experimento con las películas de jabón, ésta sería la máxima relación entre la separación L y el radio de los anillos antes de que la superficie catenoide colapse en dos discos.

Más info: 

http://mathworld.wolfram.com/MinimalSurfaceofRevolution.html

Extra: la solución del problema de la partícula en el campo gravitatorio usando funciones de prueba que son combinaciones lineales de Sin[n π t].

y[t_, nmax_]:=  Module[{n}, (4/(π^3)) Sum[((Sin[(2n+1) π t])/(((2n+1))^3)), {n, 0, nmax}]]; (*Demostrarlo*)

Aumentar el "n" en el argumento de y[t, n] para obtener funciones que incluyen cada vez más términos.

npr = 0;
Plot[{(1/2)t(1 - t), y[t, npr]}, {t, 0, 1}, PlotRange-> All, ImageSize->800, Background->Black] (*Comparación con la solución exacta*)