Super glued strings

Not a solution

The function illustrated here is not a physical solution of the vibrating string equation. The purpose of this section is to show the Mathematica principle of the animation. The actual solutions are more complicated functions.

Plot[1+Sin[x],{x,0,Pi},PlotStyle->{{Thickness[0.01],RGBColor[0,0,0.6]}},Epilog->{{Red,Thickness[0.01],Line[{{-1,0},{0,1}}],Line[{{Pi,1},{Pi+1,0}}]},{PointSize[0.012],Point[{-1,0}],Point[{Pi+1,0}]}},PlotRange->{{-1.1,Pi+1.1},{-2.4,2.4}},AspectRatio->1/5,Frame->True, 
FrameTicks->{{{},{}},{Join[{-1,Pi+1},Range[0,Pi,Pi/4]],{}}},Axes->False,ImageSize->600]

Manipulate[Plot[(1+Sin[x])Cos[t],{x,0,Pi},PlotStyle->{{Thickness[0.01],RGBColor[0,0,0.6]}},Epilog->{{Red,Thickness[0.01],Line[{{-1,0},{0,Cos[t]}}],Line[{{Pi,Cos[t]},{Pi+1,0}}]},{PointSize[0.012],Point[{-1,0}],Point[{Pi+1,0}]}},PlotRange->{{-1.1,Pi+1.1},{-2.4,2.4}},AspectRatio->1/5,Frame->True,
FrameTicks->{{{},{}},{Join[{-1,Pi+1},Range[0,Pi,Pi/4]],{}}},Axes->False,ImageSize->600],{t,0,2Pi,N[Pi/64]},ControlPlacement->Top]

Does it satisfy PDE?

FullSimplify[(D[#,{t,2}]-(1^2)(D[#,{x,2}]))&[(1+Sin[x])Cos[t]]]

No!

Does it satisfy BCs?

((1+Sin[x])Cos[t])/.{x->0}

FullSimplify[(((1+Sin[x])Cos[t])/.{x->0})-1(D[(1+Sin[x])Cos[t],{x,1}])/.{x->0}]

FullSimplify[(((1+Sin[x])Cos[t])/.{x->Pi})+1(D[(1+Sin[x])Cos[t],{x,1}])/.{x->Pi}]

Solution 1

In this problem we consider a string of length π  stretched over the interval [0,π] with a Robin boundary condition at 0 and the Dirichlet boundary condition at π. One way to interpret the Robin boundary condition  u[0,t]-(∂_x)u[0,t]=0 is to extend the string over the interval [-1,0] and consider this part of the string rigid (soaked in super-glue).

We want to solve:

PDE: (∂_tt)u[x,t]=(∂_xx)u[x,t], 0≤x≤π, t≥0, 

BCs: u[0,t]-(∂_x)u[0,t]=0, u[π,t]=0, 

ICs:u[x,0]=ff1[x], (∂_t)u[x,0]=0.

So we need to solve the Sturm-Liouville eigenvalue problem

-y(x)''= λ y(x),  0≤x≤π,  
   y'(0)-y(0) =0,   
    y(π)=0 .

Notice that here we have

No negative eigenvalues

We look for negative eigenvalues λ = -(μ^2) where μ>0:

-y(x)''= -(μ^2) y(x),  0≤x≤π,  
   y'(0)-y(0) =0,   
    y(π)=0 .

DSolve[y''[x]==(μ^2)y[x],y[x],x]

I do not know how to force Mathematica into working with hyperbolic functions. So I manipulate the solution by hand:

Simplify[(ExpToTrig[DSolve[y''[x]==(μ^2)y[x],y[x],x]])]/.{C[1]+C[2]->C[1],C[1]-C[2]->C[2]}

Substitute the fundamental solution (Cosh[μ x] C[1]+Sinh[μ x] C[2]) into the boundary conditions and collect the expression with C[1] and C[2]. This will give us two homogeneous equations.

Collect[((Cosh[μ x]C[1]+Sinh[μ x] C[2])/.{x->0})-((D[(Cosh[μ x]C[1]+Sinh[μ x] C[2]),x])/.{x->0}),{C[1],C[2]}]

Collect[((Cosh[μ x]C[1]+Sinh[μ x] C[2])/.{x->Pi}),{C[1],C[2]}]

We want nontrivial solutions for C[1] and C[2] of the system

(C[1])-μ (C[2]) = 0 
(C[1]) Cosh[π μ]+(C[2]) Sinh[π μ] = 0

For a nontrivial solution to exists we need the determinant of the preceding system to be equal to 0.  We can collect the determinant by hand or automate the collection from the above formulas. By hand:

Det[{{1,-μ},{Cosh[π μ],Sinh[π μ]}}]

Automate using the command Coefficient[]:

{{Coefficient[#,C[1]],Coefficient[#,C[2]]}&[((Cosh[μ x]C[1]+Sinh[μ x] C[2])/.{x->0})-((D[(Cosh[μ x]C[1]+Sinh[μ x] C[2]),x])/.{x->0})],{Coefficient[#,C[1]],Coefficient[#,C[2]]}&[((Cosh[μ x]C[1]+Sinh[μ x] C[2])/.{x->Pi})]}

Det[{{Coefficient[#,C[1]],Coefficient[#,C[2]]}&[((Cosh[μ x]C[1]+Sinh[μ x] C[2])/.{x->0})-((D[(Cosh[μ x]C[1]+Sinh[μ x] C[2]),x])/.{x->0})],{Coefficient[#,C[1]],Coefficient[#,C[2]]}&[((Cosh[μ x]C[1]+Sinh[μ x] C[2])/.{x->Pi})]}]

The preceding function is the function whose zeros for μ>0 give as -(μ^2) the negative eigenvalues

It is easier to think of this equation as -μ=Tanh[π μ]

Plot[{-μ,Tanh[Pi μ]},{μ,0,3}]

Since the  -μ=Tanh[π μ] has no positive solutions, there are no negative eigenvalues.  Above is a powerful  graphical verification of this claim. This claim follows formally from our knowledge about Tanh, it is in the first quadrant for positive μ.

Zero is not an eigenvalue

Is zero an eigenvalue?

-y(x)''= 0 ,  0≤x≤π,  
   y'(0)-y(0) =0,   
    y(π)=0 .

DSolve[y''[x]==0,y[x],x]

Substitute into the boundary conditions

Collect[((C[1]+x C[2])/.{x->0})-((D[C[1]+x C[2],x])/.{x->0}),{C[1],C[2]}]

Collect[((C[1]+x C[2])/.{x->Pi}),{C[1],C[2]}]

We need a nontrivial solution for C[1] and C[2] of the system

C[1]-C[2] = 0 
C[1]+π C[2] = 0

Since the determinant

Det[{{1,-1},{1,Pi}}]

is nonzero, the system has no nontrivial solutions, thus zero is not an eigenvalue.

Find positive eigenvalues

We look for positive eigenvalues in the form λ = (μ^2) with μ>0

-y(x)''= (μ^2) y(x),  0≤x≤π,  
   y'(0)-y(0) =0,   
    y(π)=0 .

DSolve[-y''[x]==(μ^2)y[x],y[x],x]

DSolve[-D[y[x],{x,2}]==(μ^2)y[x],y[x],x]

Substitute into the boundary conditions

Sin[x]/.{x->Pi/2}

D[Sin[x],x]

D[Sin[x],x]/.{x->Pi/2}

Collect[((C[1] Cos[x μ]+C[2] Sin[x μ])/.{x->0})-((D[C[1] Cos[x μ]+C[2] Sin[x μ],x])/.{x->0}),{C[1],C[2]}]

Collect[((C[1] Cos[x μ]+C[2] Sin[x μ])/.{x->Pi}),{C[1],C[2]}]

We want nontrivial solutions for C[1] and C[2] of the system

C[1]-μ C[2] = 0 
C[1] Cos[π μ]+C[2] Sin[π μ] = 0

For a nontrivial solution to exists we need the determinant to be equal to 0

Det[{{1 ,-μ },{Cos[π μ],Sin[π μ]}}]

The above function is the function whose zeros for μ>0 give as λ = (μ^2) the positive eigenvalues.

Getting solutions for μ “visually”

Plot[μ Cos[π μ]+Sin[π μ],{μ,0,13},Ticks->{Range[0,20,1],Automatic}]

Or, this plot might be more informative

Plot[{-μ ,Tan[π μ]},{μ,0,16},Ticks->{Range[0,20,1],Automatic},PlotRange->{-15,15}]

Mathematica has a command to find approximate solutions:

Solve[μ Cos[π μ]+Sin[π μ]==0,μ]

FindRoot[μ Cos[π μ]+Sin[π μ]==0,{μ,.7}]

In the preceding command we need to give an initial guess. Then Mathematica finds a much better approximation which is nearby. Mathematica’s approximate value above is given as a substitution rule {μ -> 0.787637}. To get just the numeric value write

μ/.FindRoot[μ Cos[π μ]+Sin[π μ]==0,{μ,.7}]

However, we need many solutions.  To do that I make the above command as a pure function

(μ/.FindRoot[μ Cos[π μ]+Sin[π μ]==0,{μ,#}])&[1.7]

Next I make a list of twenty initial guesses:

Join[{.9,1.7},Range[2.6,20,1]]

Next I verify graphically that my twenty initial guesses are close to the actual zeros of the function

Point[{#,0}]&/@Join[{.9,1.7},Range[2.6,20,1]]

Plot[μ Cos[π μ]+Sin[π μ],{μ,0,20},Epilog->{{Red,Point[{#,0}]&/@Join[{.9,1.7},Range[2.6,20,1]]}},Ticks->{Range[0,20,1],Automatic}]

Quite good guesses.

Then I “map” my “zero finding function” to this list

Map[(μ/.FindRoot[μ Cos[π μ]+Sin[π μ]==0,{μ,#}])&,Join[{.9,1.7},Range[2.6,20,1]]]

Next I name these approximate eigenvalues. The named list of  many μ-s will be essential in what follows.

Clear[eves1];
eves1=Map[(μ/.FindRoot[μ Cos[π μ]+Sin[π μ]==0,{μ,#}])&,Join[{.9,1.7},Range[2.6,20,1]]]

Length[eves1]

eves1[[5]]

Thus we found twenty μ-s for the eigenvalues.

I visually inspect that there are no repetitions.

Now I can check graphically that I got the right solutions

Plot[μ Cos[π μ]+Sin[π μ],{μ,0,20},Epilog->{{Red,PointSize[0.015],Point[{#,0}]&/@eves1}},Ticks->{Range[0,20,1],Automatic}]

Looks good.

Let us apply the original function to these approximations:

Map[(# Cos[π #]+Sin[π #])&,eves1]

Chop[Map[(# Cos[π #]+Sin[π #])&,eves1]]

Quite good!

Based on the matrix that determined the eigenvalues we can now define the eigenfunctions:  With μ being the solution of  μ Cos[π μ]+Sin[π μ] =0, a corresponding eigenfunction is found be solving for (Subscript[C, 1]) and (Subscript[C, 2]) the following system

(({{1, -μ}, {Cos[π μ], Sin[π μ]}}))(({{(C[1])}, {(C[2])}})) =(({{0}, {0}}))

Since the determinant of this system is zero, the system has many solutions.  A simple solution is  (Subscript[C, 1])=μ, (Subscript[C, 2])=1.  Below are twenty eigenfunctions corresponding to the eigenvalues that we found.

Clear[efs1];
efs1[x_]=Map[(#Cos[# x]+1*Sin[# x])&,eves1]

Here is, for example, the third eigenfunction

efs1[x][[3]]

Verify the eigenvalue equation:

FullSimplify[Table[D[efs1[x][[k]],{x,2}]+(((eves1[[k]]))^2)efs1[x][[k]],{k,1,Length[eves1]}]]

Verify the boundary conditions

Table[Chop[{(((efs1[x][[k]])/.{x->0})-(D[efs1[x][[k]],{x,1}])/.{x->0}),((efs1[x][[k]])/.{x->Pi})}],{k,1,Length[eves1]}]

Let us verify it the eigenfunctions are mutually orthogonal:

MatrixForm[Chop[Table[NIntegrate[efs1[x][[j]]efs1[x][[k]],{x,0,Pi},MaxRecursion->200,AccuracyGoal->10,PrecisionGoal->10],{j,1,Length[eves1]},{k,1,Length[eves1]}]]]

For later use we need the squares of the norms of the eigenfunctions

Clear[efns1];
efns1=Chop[Table[NIntegrate[efs1[x][[j]]efs1[x][[j]],{x,0,Pi},MaxRecursion->200,AccuracyGoal->10,PrecisionGoal->10],{j,1,Length[eves1]}]]

Give initial conditions

Next we give our initial condition, the initial shape of the string.  Notice that the initial velocity is 0, so we do not need to work with sine part of the time components.

Clear[ff1];

ff1[x_]=(1/3)(x-(π/(-1-2 π)))(x-1)(x-Pi)

I chose this function so that it satisfies the BCs.

Simplify[ff1'[0]-ff1[0]==0]

Plot[ff1[x],{x,0,Pi}]

Here are the coefficients in the Fourier expansion for ff1

Clear[coefs1];coefs1=Chop[Table[NIntegrate[(ff1[x])efs1[x][[j]],{x,0,Pi},MaxRecursion->200,AccuracyGoal->10,PrecisionGoal->10],{j,1,Length[eves1]}]]

I like to keep the above coefficients and the squares of the norms separate. In fact in the expansion we need to divide the above coefficients with the squares of the norms. Here is how we do it (somewhat weird, a list divided by a list, but it works)

(coefs1/efns1)

Next we define our approximation of the solution.  Remember, our few solutions in x are in the table 
efs1[x][[k]], k∈{1,...,20}, the corresponding time components are Cos[eves1[[k]] t], where eves1 is the list of twenty μ-s.  To get the solution these few functions need to be scaled by the coefficients in  ((coefs1[[k]])/(efns1[[k]])). So, our approximation of the solution is

Sum[((coefs1[[k]])/(efns1[[k]]))efs1[x][[k]]*Cos[eves1[[k]] t],{k,1,Length[eves1]}]

There is much more compact way of delivering the same result without using summation. In fact that sum is written as  a dot product.

(efs1[x]*((Cos[# t])&/@eves1)).((coefs1/efns1))

Next we define our approximation of the solution as a function with a name:

Clear[uu1];uu1[x_,t_]=(efs1[x]*((Cos[# t])&/@eves1)).((coefs1/efns1))

Does it evaluate properly?

uu1[1,0.6]

Does it approximate the function ff1 well?

Plot[Evaluate[{(ff1[x]),uu1[x,0]}],{x,0,Pi},PlotStyle->{{Thickness[0.01],RGBColor[0,0,0.6]},{Thickness[0.005],Yellow}},Epilog->{{Red,Thickness[0.01],Line[{{-1,0},{0,uu1[0,0]}}]}},PlotRange->{{-1.1,Pi+0.1},{-1.2,1.2}},AspectRatio->1/5,Frame->True,
FrameTicks->{{{},{}},{Join[Range[0,Pi,Pi/4],{-1}],{}}},Axes->False,ImageSize->600]

Ready to oscillate?

Manipulate[Plot[Evaluate[uu1[x,t]],{x,0,Pi},PlotStyle->{{Thickness[0.01],RGBColor[0,0,0.6]}},
Epilog->{
{Red,Thickness[0.01],Line[{{-1,0},{0,Evaluate[uu1[0,t]]}}]},{PointSize[0.014],Point[#]&/@{{-1,0},{Pi,0}}},
{Text["t =",{0.9,1.25}],Text[NumberForm[N[t],{4,3}],{1.05,1.25}]}
},
PlotRange->{{-1.1,Pi+0.1},{-1.4,1.4}},AspectRatio->1/5,Frame->True,FrameTicks->{{{},{}},{Join[Range[0,Pi,Pi/4],{-1}],{}}},Axes->False,ImageSize->600],{t,0,7.3,0.05}]

Try different esthetics:

Module[{t},t=2Pi;Plot[Evaluate[uu1[x,t]],{x,0,Pi},PlotStyle->{{Thickness[0.01],RGBColor[1,0.5,0]}},
Epilog->{
{Red,Thickness[0.01],Line[{{-1,0},{0,Evaluate[uu1[0,t]]}}]},{PointSize[0.012],White,Point[#]&/@{{-1,0},{Pi,0}}},
{Text["t =",{0.925+0.08,1.25},BaseStyle-> {FontWeight->"Normal",FontColor->RGBColor[1,1,1]}],Text[NumberForm[N[2t],{3,1}],{1.011+0.08,1.25},BaseStyle-> {FontWeight->"Normal",FontColor->RGBColor[1,1,1]}]}
},
PlotRange->{{-1.1,Pi+0.1},{-1.4,1.4}},AspectRatio->1/5,Frame->True,FrameTicks->{{{},{}},{Join[Range[0,Pi,Pi/4],{-1}],{}}},Axes->False,ImageSize->800,Background->Black]]

2.14/2

Another way to make an animation is to produce a lot of pictures and put them in a table. We do not want to see the result since it contains 147 pictures; therefore the semi-column is essential at the end of the next cell.

aniuu1=Table[Plot[Evaluate[uu1[x,t]],{x,0,Pi},PlotStyle->{{Thickness[0.01],RGBColor[0,0,0.6]}},
Epilog->{
{Red,Thickness[0.01],Line[{{-1,0},{0,Evaluate[uu1[0,t]]}}]},{PointSize[0.012],Point[#]&/@{{-1,0},{Pi,0}}},
{Text["t =",{0.925+0.08,1.25}],Text[NumberForm[N[t],{4,3}],{1.011+0.08,1.25}]}
},
PlotRange->{{-1.1,Pi+0.1},{-1.4,1.4}},AspectRatio->1/5,Frame->True,FrameTicks->{{{},{}},{Join[Range[0,Pi,Pi/4],{-1}],{}}},Axes->False,ImageSize->800],{t,0,7.3,0.05}];

aniuu1BB=Table[Plot[Evaluate[uu1[x,t]],{x,0,Pi},PlotStyle->{{Thickness[0.01],RGBColor[1,0.5,0]}},
Epilog->{
{Red,Thickness[0.01],Line[{{-1,0},{0,Evaluate[uu1[0,t]]}}]},{PointSize[0.012],White,Point[#]&/@{{-1,0},{Pi,0}}},
{Text["t =",{0.925+0.08,1.25},BaseStyle-> {FontWeight->"Normal",FontColor->RGBColor[1,1,1]}],Text[NumberForm[N[t],{3,1}],{1.011+0.08,1.25},BaseStyle-> {FontWeight->"Normal",FontColor->RGBColor[1,1,1]}]}
},
PlotRange->{{-1.1,Pi+0.1},{-1.4,1.4}},AspectRatio->1/5,Frame->True,FrameTicks->{{{},{}},{Join[Range[0,Pi,Pi/4],{-1}],{}}},Axes->False,ImageSize->800,Background->Black],{t,0,7.3,0.05}];

Length[aniuu1BB]

Show[aniuu1BB[[147]],ImageSize->800]

ListAnimate[Show[#,ImageSize->600]&/@aniuu1BB]

2 7.3/147

dds=0.1&/@Range[Length[aniuu1BB]]; (* duration of each frame that we want*)

SetDirectory[NotebookDirectory[]]

(*  Export["aniuu1s1.gif",aniuu1[[1]],"ImageSize"->800];Export["aniuu1BBAni.gif",aniuu1BB,"AnimationRepetitions"->Infinity,"ImageSize"->800,"DisplayDurations"->dds] *)

(*  Export["aniuu1BBs1.gif",aniuu1BB[[1]],"ImageSize"->800];

Export["aniuu1BBAni.gif",aniuu1BB,"AnimationRepetitions"->Infinity,"ImageSize"->800,"DisplayDurations"->dds] *)

Normal mode of vibrations

And finally here are the normal modes of vibrations. Those are the few solutions that we found before

Clear[nmv1];nmv1[x_,t_]:=(efs1[x]*(((1/(Sqrt[((#)^2)+4]))Cos[# t])&/@eves1))

Manipulate[Plot[Evaluate[nmv1[x,t][[k]]],{x,0,Pi},PlotStyle->{{Thickness[0.01],RGBColor[0,0,0.5]}},
Epilog->{
{Red,Thickness[0.01],Line[{{-1,0},{0,Evaluate[nmv1[0,t][[k]]]}}]},
{PointSize[0.012],Point[#]&/@{{-1,0},{Pi,0}}}
},PlotRange->{{-1.1,Pi+.1},{-1.4,1.4}},AspectRatio->1/5,Frame->True,FrameTicks->{{{},{}},{Join[Range[0,Pi,Pi/4],{-1/2,-1}],{}}},Axes->False,ImageSize->600],{t,0,4Pi,N[Pi/64]},{{k,1},Range[10],ControlType->Setter}]

nmv1[x,t][[1]]

Manipulate[Plot[Evaluate[nmv1[x,t][[k]]],{x,0,Pi},PlotStyle->{{Thickness[0.01],RGBColor[1,0.5,0]}},
Epilog->{
{Red,Thickness[0.01],Line[{{-1,0},{0,Evaluate[nmv1[0,t][[k]]]}}]},{PointSize[0.012],White,Point[#]&/@{{-1,0},{Pi,0}}},
{Text["t =",{0.925+0.08,1.25},BaseStyle-> {FontWeight->"Normal",FontColor->RGBColor[1,1,1]}],Text[NumberForm[N[t],{3,1}],{1.011+0.08,1.25},BaseStyle-> {FontWeight->"Normal",FontColor->RGBColor[1,1,1]}]}
},
PlotRange->{{-1.1,Pi+0.1},{-1.4,1.4}},AspectRatio->1/5,Frame->True,FrameTicks->{{{},{}},{Join[Range[0,Pi,Pi/4],{-1}],{}}},Axes->False,ImageSize->800,Background->Black],{t,0,4Pi,N[Pi/64]},{{k,1},Range[6],ControlType->Setter}]

(4 Pi/Take[eves1,6]){1,2,3,4,5,6}

Manipulate[Plot[Evaluate[nmv1[x,t][[k]]],{x,0,Pi},PlotStyle->{{Thickness[0.01],RGBColor[1,0.5,0]}},
Epilog->{
{Red,Thickness[0.01],Line[{{-1,0},{0,Evaluate[nmv1[0,t][[k]]]}}]},{PointSize[0.012],White,Point[#]&/@{{-1,0},{Pi,0}}},
{Text["t =",{0.925+0.08,1.25},BaseStyle-> {FontWeight->"Normal",FontColor->RGBColor[1,1,1]}],Text[NumberForm[N[t],{3,1}],{1.011+0.08,1.25},BaseStyle-> {FontWeight->"Normal",FontColor->RGBColor[1,1,1]}]}
},
PlotRange->{{-1.1,Pi+0.1},{-1.4,1.4}},AspectRatio->1/5,Frame->True,FrameTicks->{{{},{}},{Join[Range[0,Pi,Pi/4],{-1}],{}}},Axes->False,ImageSize->800,Background->Black],{t,0,15.5,N[15.5/64]},{{k,1},Range[6],ControlType->Setter}]

Solution 2

In this problem we consider a string of length π  stretched over the interval [0,π] with a Robin boundary condition at 0 and the Dirichlet boundary condition at π.  In this case the Robin boundary condition  u[0,t]+(∂_x)u[0,t]=0  is so-called non-physical. I invented a way of interpreting this condition as a straight line-segment being attached to the string at the left-hand end-point. See the animations below. An interesting feature in this case is the existence of a negative eigenvalue.

We want to solve

PDE: (∂_tt)u[x,t]=(∂_xx)u[x,t]  where  0≤x≤π, t≥0,  
BCS: u[0,t]+(∂_x)u[0,t]=0, u[π,t]=0  for all t≥0, 
ICs: u[x,0]=ff1[x], (∂_t)u[x,0]=0  for all  x∈[0,π].

So we need to solve the Sturm-Liouville eigenvalue problem

-y(x)''= λ x y(x),  0≤x≤π,  
   y(0)+y'(0) =0,   
    y(π)=0 .

Look for negative eigenvalues

We look for negative eigenvalues λ = -(μ^2)

-y(x)''= -(μ^2) y(x),  0≤x≤π,  
   y(0)+y'(0) =0,   
    y(π)=0 .

DSolve[y''[x]==(μ^2)y[x],y[x],x]

I do not know how to force Mathematica into working with hyperbolic functions. So I force it by hand:

Simplify[(ExpToTrig[DSolve[y''[x]==(μ^2)y[x],y[x],x]])]/.{C[1]+C[2]->C[1],C[1]-C[2]->C[2]}

Substitute the fundamental solution (Cosh[μ x] C[1]+Sinh[μ x] C[2]) into the boundary conditions and collect the expression with C[1] and C[2]. This will give us two homogeneous equations.

Collect[((Cosh[μ x]C[1]+Sinh[μ x] C[2])/.{x->0})+((D[(Cosh[μ x]C[1]+Sinh[μ x] C[2]),x])/.{x->0}),{C[1],C[2]}]

Collect[((Cosh[μ x]C[1]+Sinh[μ x] C[2])/.{x->Pi}),{C[1],C[2]}]

We want nontrivial solutions for C[1] and C[2] of the system

C[1]+μ C[2] = 0 
C[1]Cosh[π μ]+C[2]Sin[π μ]=0

For a nontrivial solution to exists we need the determinant to be equal to 0

Det[{{1 ,μ },{Cosh[Pi μ],Sinh[Pi μ] }}]

The above function is the function whose zeros for μ>0 give -(μ^2) as the negative eigenvalues

Since the above function has one positive zero there is one negative eigenvalue.  Below is a graphical verification of this claim.

Plot[-μ Cosh[π μ]+Sinh[π μ],{μ,0,3},PlotRange->{-3,3}]

The equation for the eigenvalue can be rewritten as Tanh[π μ] = μ

Plot[{Tanh[π μ],μ},{μ,0,3}]

evn2=μ/.FindRoot[-μ Cosh[π μ]+Sinh[π μ]==0,{μ,1}]

The corresponding eigenfunction is

efn2[x_]=evn2 Cosh[evn2 x]-Sinh[evn2 x]

Verify

FullSimplify[D[efn2[x],{x,2}]-(evn2^2)efn2[x]]

Zero is not an eigenvalue

Is zero an eigenvalue?

-y(x)''= 0 ,  0≤x≤π,  
   y(0)+y'(0) =0,   
    y(π)=0 .

DSolve[y''[x]==0,y[x],x]

Substitute into the boundary conditions

Collect[((C[1]+x C[2])/.{x->0})+((D[C[1]+x C[2],x])/.{x->0}),{C[1],C[2]}]

Collect[((C[1]+x C[2])/.{x->Pi}),{C[1],C[2]}]

We need a nontrivial solution for C[1] and C[2] of the system

C[1]+C[2] = 0 
C[1]+π C[2] = 0

Since the determinant

Det[{{1,1},{1,Pi}}]

is nonzero, the system has no nontrivial solutions, thus zero is not an eigenvalue.

Look for positive eigenvalues

We look for positive eigenvalues λ = (μ^2)

-y(x)''= (μ^2) y(x),  0≤x≤π,  
   y(0)+y'(0) =0,   
    y(π)=0 .

DSolve[-y''[x]==(μ^2)y[x],y[x],x]

Substitute into the boundary conditions

Collect[((C[1] Cos[x μ]+C[2] Sin[x μ])/.{x->0})+((D[C[1] Cos[x μ]+C[2] Sin[x μ],x])/.{x->0}),{C[1],C[2]}]

Collect[((C[1] Cos[x μ]+C[2] Sin[x μ])/.{x->Pi}),{C[1],C[2]}]

We want nontrivial solutions for C[1] and C[2] of the system

C[1]+μ C[2] = 0 
C[1] Cos[π μ]+C[2] Sin[π μ] = 0

For a nontrivial solution to exists we need the determinant to be equal to 0

Det[{{1 ,μ },{Cos[π μ],Sin[π μ]}}]

The above function is the function whose zeros give as (μ^2) the negative eigenvalues

Getting solutions for μ “visually”

Plot[-μ Cos[π μ]+Sin[π μ],{μ,0,13},Ticks->{Range[0,20,1],Automatic}]

Or, more informative graph

Plot[{μ ,((Sin[π μ])/(Cos[π μ]))},{μ,0,13},Ticks->{Range[0,20,1],Automatic},PlotRange->{-13,13}]

Mathematica has a command to find approximate solutions:

FindRoot[-μ Cos[π μ]+Sin[π μ]==0,{μ,1.2}]

In the command above we need to give an initial guess. Then Mathematica finds a much better approximation which is nearby. Mathematica’s approximate value above is given as a substitution rule. To get just the numeric value do

μ/.FindRoot[-μ Cos[π μ]+Sin[π μ]==0,{μ,1.2}]

However, we need many solutions.  To do that I make the above command as a pure function

(μ/.FindRoot[-μ Cos[π μ]+Sin[π μ]==0,{μ,#}])&[1.2]

Next I make a list of initial guesses:

Join[{1.3},Range[2.4,20,1]]

Next I verify that my initial guesses are close to the actual zeros of the function

Plot[-μ Cos[π μ]+Sin[π μ],{μ,0,13},Epilog->{{Red,Point[{#,0}]&/@Join[{1.3},Range[2.4,20,1]]}},Ticks->{Range[0,20,1],Automatic}]

Then I “map” my “zero finding function” to this list

Map[(μ/.FindRoot[-μ Cos[π μ]+Sin[π μ]==0,{μ,#}])&,Join[{1.3},Range[2.4,20,1]]]

Next I name these approximate eigenvalues. The named list of  many μ-s will be essential in what follows.

Clear[eves2];
eves2=(μ/.FindRoot[- μ Cos[π μ]+ Sin[π μ]==0,{μ,#}])&/@Join[{1.3},Range[2.4,20,1]]

Length[eves2]

Thus we found nineteen eigenvalues.

I visually inspect that there are no repetitions.

Now I can check graphically that I got the right solutions

Plot[-μ Cos[π μ]+Sin[π μ],{μ,0,20},Epilog->{{Red,PointSize[0.015],Point[{#,0}]&/@eves2}},Ticks->{Range[0,20,1],Automatic}]

Looks good.

Let us apply the original function to these approximations:

Chop[(-# Cos[π #]+Sin[π #])&/@eves2]

Quite good!

Based on the matrix that determined the eigenvalues we can now define the eigenfunctions:  With μ being the solution of  μ Cos[π μ]+Sin[π μ] =0, a corresponding eigenfunction is found be solving for (Subscript[C, 1]) and (Subscript[C, 2]) the following system

MatrixForm[{{1 ,μ },{Cos[π μ],Sin[π μ]}}]

(({{1, μ}, {Cos[π μ], Sin[π μ]}}))(({{(Subscript[C, 1])}, {(Subscript[C, 2])}}))=(({{0}, {0}}))

Since the determinant of this system is zero, the system has many solutions.  A simple solution is  (Subscript[C, 1])=μ, (Subscript[C, 2])=-1.  Below are twenty eigenfunctions corresponding to the eigenvalues that we found.

Clear[efs2];
efs2[x_]=(#Cos[# x]-Sin[# x])&/@eves2

Here is, for example, the third eigenfunction

efs2[x][[3]]

Verify the eigenvalue equation:

FullSimplify[Table[D[efs2[x][[k]],{x,2}]+(((eves2[[k]]))^2)efs2[x][[k]],{k,1,Length[eves2]}]]

Verify the boundary conditions

Table[Chop[{(((efs2[x][[k]])/.{x->0})+(D[efs2[x][[k]],{x,1}])/.{x->0}),((efs2[x][[k]])/.{x->Pi})}],{k,1,Length[eves2]}]

Let us verify it the eigenfunctions are mutually orthogonal:

Chop[Table[NIntegrate[efs2[x][[j]]efs2[x][[k]],{x,0,Pi},MaxRecursion->200,AccuracyGoal->10,PrecisionGoal->10],{j,1,Length[eves2]},{k,1,Length[eves2]}]]

We will need the integrals of the squares for later

efns2=Chop[Table[NIntegrate[efs2[x][[j]]efs2[x][[j]],{x,0,Pi},MaxRecursion->200,AccuracyGoal->10,PrecisionGoal->10],{j,1,Length[eves2]}]]

Initial condition

ff2[x_]=(.2869 #^3+((-1+π-.2869 (π^3))/(π^2)) #^2-1 #+1)&[x]

Plot[ff2[x],{x,0,Pi}]

coefs2=Chop[Table[NIntegrate[(ff2[x])efs2[x][[j]],{x,0,Pi},MaxRecursion->200,AccuracyGoal->10,PrecisionGoal->10],{j,1,Length[eves2]}]]

(coefs2/efns2)

(efs2[x]*((Cos[# t])&/@eves2)).((coefs2/efns2))

Clear[uu2]; uu2[x_,t_]=(NIntegrate[(ff2[x])efn2[x],{x,0,Pi},MaxRecursion->200,AccuracyGoal->10,PrecisionGoal->10]/NIntegrate[(efn2[x])efn2[x],{x,0,Pi},MaxRecursion->200,AccuracyGoal->10,PrecisionGoal->10])(efn2[x]*Cosh[evn2 t])+(efs2[x]*((Cos[# t])&/@eves2)).((coefs2/efns2))

uu2[1,0.4]

Plot[Evaluate[{(ff2[x]),uu2[x,0]}],{x,0,Pi},PlotStyle->{{Thickness[0.01],Blue},{Thickness[0.005],Yellow}},Epilog->{{Red,Thickness[0.005],Line[{{1,0},{0,uu2[0,0]}}]}},PlotRange->{{-0.1,Pi+.1},{-2.2,2.2}},AspectRatio->1/4,Frame->True,FrameTicks->{{{},{}},{Join[{1},Range[0,Pi,Pi/4]],{}}},Axes->False,ImageSize->600]

Manipulate[Plot[Evaluate[uu2[x,t]],{x,0,Pi},
PlotStyle->{{Thickness[0.01],Blue}},
Epilog->{{Red,Thickness[0.005],Line[{{1,0},{0,uu2[0,t]}}]},
{PointSize[0.012],Point[#]&/@{{1,0},{Pi,0}}}
},PlotRange->{{-0.1,Pi+.1},{-2.2,2.2}},AspectRatio->1/5,Frame->True,FrameTicks->{{{},{}},{Join[{1},Range[0,Pi,Pi/4]],{}}},Axes->False,ImageSize->600],{t,0,11.5,0.1},ControlPlacement->Top]

Because of the negative eigenvalue, this string brakes.

aniuu2BB=Table[Plot[Evaluate[uu2[x,t]],{x,0,Pi},PlotStyle->{{Thickness[0.01],RGBColor[1,0.5,0]}},
Epilog->{
{Red,Thickness[0.007],Line[{{1,0},{0,Evaluate[uu2[0,t]]}}]},{PointSize[0.012],White,Point[#]&/@{{1,0},{Pi,0}}},
{Text["t =",{1.45+0.08,1.6},BaseStyle-> {FontWeight->"Normal",FontColor->RGBColor[1,1,1]}],Text[NumberForm[N[t],{3,1}],{1.5+0.1,1.6},BaseStyle-> {FontWeight->"Normal",FontColor->RGBColor[1,1,1]}]}
},
PlotRange->{{-0.1,Pi+0.1},{-1.7,1.7}},AspectRatio->1/5,Frame->True,FrameTicks->{{{},{}},{Range[0,Pi,Pi/4],{}}},Axes->False,ImageSize->800,Background->Black],{t,0,11.5,0.05}];

Length[aniuu2BB]

aniuu2BB[[200]]

ListAnimate[Show[#,ImageSize->600]&/@aniuu2BB]

(* dds=0.1&/@Range[Length[aniuu2BB]];  duration of each frame that we want*)

(* SetDirectory[NotebookDirectory[]] *)

(* Export["aniuu2BBs1.gif",aniuu2BB[[1]],"ImageSize"->800];Export["aniuu2BBAni.gif",aniuu2BB,"AnimationRepetitions"->Infinity,"ImageSize"->800,"DisplayDurations"->dds] *)

Solution 3

ff3[x_]=((0.2869636751862268`) #^3+((-1+π-(0.2869636751862268`) (π^3))/(π^2)) #^2-1 #+1)&[x]

Plot[ff3[x],{x,0,Pi}]

Chop[NIntegrate[(ff3[x])efn2[x],{x,0,Pi},MaxRecursion->200,AccuracyGoal->10,PrecisionGoal->10]]

coefs3=Chop[Table[NIntegrate[(ff3[x])efs2[x][[j]],{x,0,Pi},MaxRecursion->200,AccuracyGoal->10,PrecisionGoal->10],{j,1,Length[eves2]}]]

(coefs3/efns2)

(efs2[x]*((Cos[# t])&/@eves2)).((coefs3/efns2))

Clear[uu3];uu3[x_,t_]=(efs2[x]*((Cos[# t])&/@eves2)).((coefs3/efns2))

uu3[1,0.]

Plot[Evaluate[{(ff3[x]),uu3[x,0]}],{x,0,Pi},PlotStyle->{{Thickness[0.01],Blue},{Thickness[0.005],Yellow}},Epilog->{{Red,Thickness[0.006],Line[{{1,0},{0,uu3[0,0]}}]}},PlotRange->{{-0.1,Pi+.1},{-2.2,2.2}},AspectRatio->1/5,Frame->True,FrameTicks->{{{},{}},{Join[{1},Range[0,Pi,Pi/4]],{}}},Axes->False,ImageSize->600]

Manipulate[Plot[Evaluate[uu3[x,t]],{x,0,Pi},PlotStyle->{{Thickness[0.01],Blue}},Epilog->{{Red,Thickness[0.005],Line[{{1,0},{0,uu3[0,t]}}]},{PointSize[0.012],Point[#]&/@{{1,0},{Pi,0}}}},
PlotRange->{{-0.1,Pi+.1},{-2.2,2.2}},AspectRatio->1/5,Frame->True,FrameTicks->{{{},{}},{Join[{1},Range[0,Pi,Pi/4]],{}}},Axes->False,ImageSize->600],{t,0,19.5,0.1}]

Clear[nmv2];nmv2[x_,t_]:=(efs2[x]*(((1/(Sqrt[((#)^2)+1]))Cos[# t])&/@eves2))

Manipulate[Plot[Evaluate[nmv2[x,t][[k]]],{x,0,Pi},PlotStyle->{{Thickness[0.01],Blue}},Epilog->{{Red,Thickness[0.005],Line[{{1,0},{0,Evaluate[nmv2[0,t][[k]]]}}]},{PointSize[0.012],Point[#]&/@{{1,0},{Pi,0}}}},PlotRange->{{-0.1,Pi+0.1},{-1.5,1.5}},AspectRatio->1/5,Frame->True,FrameTicks->{{{},{}},{Join[{1},Range[0,Pi,Pi/4]],{}}},Axes->False,ImageSize->600],{t,0,4Pi,N[Pi/64]},{{k,1},Range[10],ControlType->Setter}]

In this example I carefully selected the initial shape, so that the string does not break. I selected a shape that is orthogonal to the eigenfunction corresponding to the negative eigenvalue.

aniuu3BB=Table[Plot[Evaluate[uu3[x,t]],{x,0,Pi},PlotStyle->{{Thickness[0.01],RGBColor[1,0.5,0]}},
Epilog->{
{Red,Thickness[0.007],Line[{{1,0},{0,Evaluate[uu3[0,t]]}}]},{PointSize[0.012],White,Point[#]&/@{{1,0},{Pi,0}}},
{Text["t =",{1.45+0.08,1.6},BaseStyle-> {FontWeight->"Normal",FontColor->RGBColor[1,1,1]}],Text[NumberForm[N[t],{3,1}],{1.5+0.1,1.6},BaseStyle-> {FontWeight->"Normal",FontColor->RGBColor[1,1,1]}]}
},
PlotRange->{{-0.1,Pi+0.1},{-1.7,1.7}},AspectRatio->1/5,Frame->True,FrameTicks->{{{},{}},{Range[0,Pi,Pi/4],{}}},Axes->False,ImageSize->800,Background->Black],{t,0,10,0.05}];

Length[aniuu3BB]

Show[aniuu3BB[[1]],ImageSize->600]

Show[aniuu3BB[[201]],ImageSize->600]

ListAnimate[Show[#,ImageSize->600]&/@aniuu3BB]

(* dds=0.1&/@Range[Length[aniuu3BB]];  duration of each frame that we want*)

(* Export["aniuu3BBs1.gif",aniuu3BB[[1]],"ImageSize"->800];Export["aniuu3BBAni.gif",aniuu3BB,"AnimationRepetitions"->Infinity,"ImageSize"->800,"DisplayDurations"->dds]  *)

Solution 4

We want to solve

(∂_tt)u[x,t]=(∂_xx)u[x,t], 0≤x≤π, t≥0, 
u[0,t]+4 (∂_x)u[0,t]=0, 
u[π,t]=0, 
u[x,0]=ff1[x], 
(∂_t)u[x,0]=0.

So we need to solve the Sturm-Liouville eigenvalue problem

-y(x)''= λ x y(x),  0≤x≤π,  
   y(0)+4y'(0) =0,   
    y(π)=0 .

Look for negative eigenvalues

We look for negative eigenvalues λ = -(μ^2)

-y(x)''= -(μ^2) y(x),  0≤x≤π,  
   y(0)+ 4y'(0) =0,   
    y(π)=0 .

DSolve[y''[x]==(μ^2)y[x],y[x],x]

I do not know how to force Mathematica into working with hyperbolic functions. So I force it by hand:

Simplify[(ExpToTrig[DSolve[y''[x]==(μ^2)y[x],y[x],x]])]/.{C[1]+C[2]->C[1],C[1]-C[2]->C[2]}

Substitute the fundamental solution (Cosh[μ x] C[1]+Sinh[μ x] C[2]) into the boundary conditions and collect the expression with C[1] and C[2]. This will give us two homogeneous equations.

Collect[((Cosh[μ x]C[1]+Sinh[μ x] C[2])/.{x->0})+(4(D[(Cosh[μ x]C[1]+Sinh[μ x] C[2]),x])/.{x->0}),{C[1],C[2]}]

Collect[((Cosh[μ x]C[1]+Sinh[μ x] C[2])/.{x->Pi}),{C[1],C[2]}]

We want nontrivial solutions for C[1] and C[2] of the system

C[1]+4μ C[2] = 0 
C[1]Cosh[π μ]+C[2]Sin[π μ]=0

For a nontrivial solution to exists we need the determinant to be equal to 0

Det[{{1 ,4μ },{Cosh[Pi μ],Sinh[Pi μ] }}]

The above function is the function whose zeros give as -(μ^2) the negative eigenvalues

Since the above function has no positive zeros there are no negative evs.  Below is a graphical verification of this claim.

Plot[-4μ Cosh[π μ]+Sinh[π μ],{μ,0,3},PlotRange->{-3,3}]

The equation for the eigenvalue can be rewritten as Tanh[π μ] = μ

Plot[{Tanh[π μ],4μ},{μ,0,3},PlotRange->{0,2}]

Thus there are no negative eigenvalues in this case.

Zero is not an eigenvalue

Is zero an eigenvalue?

-y(x)''= 0 ,  0≤x≤π,  
   y(0)+4y'(0) =0,   
    y(π)=0 .

DSolve[y''[x]==0,y[x],x]

Substitute into the boundary conditions

Collect[((C[1]+x C[2])/.{x->0})+4((D[C[1]+x C[2],x])/.{x->0}),{C[1],C[2]}]

Collect[((C[1]+x C[2])/.{x->Pi}),{C[1],C[2]}]

We need a nontrivial solution for C[1] and C[2] of the system

C[1]+4C[2] = 0 

C[1]+π C[2] = 0

Since the determinant

Det[{{1,4},{1,Pi}}]

is nonzero, the system has no nontrivial solutions, thus zero is not an eigenvalue.

Look for positive eigenvalues

We look for positive eigenvalues λ = (μ^2)

-y(x)''= (μ^2) y(x),  0≤x≤π,  
   y(0)+4y'(0) =0,   
    y(π)=0 .

DSolve[-y''[x]==(μ^2)y[x],y[x],x]

Substitute into the boundary conditions

Collect[((C[1] Cos[x μ]+C[2] Sin[x μ])/.{x->0})+4((D[C[1] Cos[x μ]+C[2] Sin[x μ],x])/.{x->0}),{C[1],C[2]}]

Collect[((C[1] Cos[x μ]+C[2] Sin[x μ])/.{x->Pi}),{C[1],C[2]}]

We want nontrivial solutions for C[1] and C[2] of the system

C[1]+4μ C[2] = 0 
C[1] Cos[π μ]+C[2] Sin[π μ] = 0

For a nontrivial solution to exists we need the determinant to be equal to 0

Det[{{1 ,4μ },{Cos[π μ],Sin[π μ]}}]

The above function is the function whose zeros give as (μ^2) the negative eigenvalues

Getting solutions for μ “visually”

Plot[-4μ Cos[π μ]+Sin[π μ],{μ,0,13},Ticks->{Range[0,20,1],Automatic}]

Or, more informative

Plot[{4μ ,((Sin[π μ])/(Cos[π μ]))},{μ,0,13},Ticks->{Range[0,20,1],Automatic},PlotRange->{-20,50}]

Next I make a list of initial guesses:

Join[{.3,1.3},Range[2.4,20,1]]

Next I verify that my initial guesses are close to the actual zeros of the function

Plot[-4μ Cos[π μ]+Sin[π μ],{μ,0,13},Epilog->{{Red,Point[{#,0}]&/@Join[{.3,1.3},Range[2.4,20,1]]}},Ticks->{Range[0,20,1],Automatic}]

Then I “map” my “zero finding function” to this list

Map[(μ/.FindRoot[-4μ Cos[π μ]+Sin[π μ]==0,{μ,#}])&,Join[{.3,1.3},Range[2.4,20,1]]]

Next I name these approximate eigenvalues. The named list of  many μ-s will be essential in what follows.

Clear[eves4];
eves4=(μ/.FindRoot[- 4μ Cos[π μ]+ Sin[π μ]==0,{μ,#}])&/@Join[{.3,1.3},Range[2.4,20,1]]

Length[eves4]

Thus we found twenty eigenvalues.

I visually inspect that there are no repetitions.

Now I can check graphically that I got the right solutions

Plot[-4μ Cos[π μ]+Sin[π μ],{μ,0,20},Epilog->{{Red,PointSize[0.015],Point[{#,0}]&/@eves4}},Ticks->{Range[0,20,1],Automatic}]

Looks good.

Let us apply the original function to these approximations:

Chop[(-4# Cos[π #]+Sin[π #])&/@eves4]

Quite good!

Based on the matrix that determined the eigenvalues we can now define the eigenfunctions:  With μ being the solution of  μ Cos[π μ]+Sin[π μ] =0, a corresponding eigenfunction is found be solving for (Subscript[C, 1]) and (Subscript[C, 2]) the following system

MatrixForm[{{1 ,4μ },{Cos[π μ],Sin[π μ]}}]

(({{1, 4μ}, {Cos[π μ], Sin[π μ]}}))(({{(Subscript[C, 1])}, {(Subscript[C, 2])}}))=(({{0}, {0}}))

Since the determinant of this system is zero, the system has many solutions.  A simple solution is  (Subscript[C, 1])=4μ, (Subscript[C, 2])=-1.  Below are twenty eigenfunctions corresponding to the eigenvalues that we found.

Clear[efs4];
efs4[x_]=(4#Cos[# x]-Sin[# x])&/@eves4

efs4[x][[3]]

Chop[Table[NIntegrate[efs4[x][[j]]efs4[x][[k]],{x,0,Pi},MaxRecursion->200,AccuracyGoal->10,PrecisionGoal->10],{j,1,Length[eves4]},{k,1,Length[eves4]}]]

efns4=Chop[Table[NIntegrate[efs4[x][[j]]efs4[x][[j]],{x,0,Pi},MaxRecursion->200,AccuracyGoal->10,PrecisionGoal->10],{j,1,Length[eves4]}]]

ff4[x_]=(x Sin[x]/2)

Plot[ff4[x],{x,0,Pi}]

coefs4=Chop[Table[NIntegrate[(ff4[x])efs4[x][[j]],{x,0,Pi},MaxRecursion->200,AccuracyGoal->10,PrecisionGoal->10],{j,1,Length[eves4]}]]

(coefs4/efns4)

(efs4[x]*((Cos[# t])&/@eves4)).((coefs4/efns4))

Clear[uu4]; uu4[x_,t_]=(efs4[x]*((Cos[# t])&/@eves4)).((coefs4/efns4))

uu4[1,0.]

Plot[Evaluate[{(ff4[x]),uu4[x,0]}],{x,0,Pi},PlotStyle->{{Thickness[0.01],Blue},{Thickness[0.005],Yellow}},Epilog->{{Red,Thickness[0.005],Line[{{4,0},{0,uu4[0,0]}}]}},PlotRange->{{-0.1,4+.1},{-1.2,1.2}},AspectRatio->1/5,Frame->True,FrameTicks->{{{},{}},{Join[{4},Range[0,Pi,Pi/4]],{}}},Axes->False,ImageSize-> 600]

Manipulate[Plot[Evaluate[uu4[x,t]],{x,0,Pi},PlotStyle->{{Thickness[0.01],Blue}},Epilog->{{PointSize[0.012],Point[#]&/@{{Pi,0}}},{Red,Thickness[0.005],Line[{{4,0},{0,uu4[0,t]}}]},{Point[{Pi,0}]},
{PointSize[0.012],Point[#]&/@{{4,0}}}},PlotRange->{{-0.1,4+.1},{-1.4,1.4}},AspectRatio->1/5,Frame->True,Axes->False,FrameTicks->{{{},{}},{Join[{4},Range[0,Pi,Pi/4]],{}}},ImageSize->600],{t,0,26.11,0.1}]

N[2Pi/eves4[[1]]]

Clear[nmv4];nmv4[x_,t_]:=(efs4[x]*(((1/(Sqrt[16((#)^2)+1]))Cos[# t])&/@eves4))

Manipulate[Plot[Evaluate[nmv4[x,t][[k]]],{x,0,Pi},PlotStyle->{{Thickness[0.01],Blue}},Epilog->{{PointSize[0.012],Point[{Pi,0}]},{Red,Thickness[0.005],Line[{{4,0},{0,Evaluate[nmv4[0,t][[k]]]}}]},
{PointSize[0.012],Point[{4,0}]}
},PlotRange->{{-0.1,4+0.1},{-1.5,1.5}},AspectRatio->1/5,Frame->True,FrameTicks->{{{},{}},{Join[{4},Range[0,Pi,Pi/4]],{}}},Axes->False,ImageSize->600],{t,0,N[2Pi/eves4[[1]]],0.05},{{k,1},Range[10],ControlType->Setter}]

aniuu4BB=Table[Plot[Evaluate[uu4[x,t]],{x,0,Pi},PlotStyle->{{Thickness[0.01],RGBColor[1,0.5,0]}},
Epilog->{
{Red,Thickness[0.007],Line[{{4,0},{0,Evaluate[uu4[0,t]]}}]},{PointSize[0.012],White,Point[#]&/@{{4,0},{Pi,0}}},
{Text["t =",{1.45+0.08,1.3},BaseStyle-> {FontWeight->"Normal",FontColor->RGBColor[1,1,1]}],Text[NumberForm[N[t],{3,1}],{1.5+0.115,1.3},BaseStyle-> {FontWeight->"Normal",FontColor->RGBColor[1,1,1]}]}
},
PlotRange->{{-0.1,4+0.1},{-1.4,1.4}},AspectRatio->1/5,Frame->True,FrameTicks->{{{},{}},{Join[Range[0,Pi,Pi/4],{4}],{}}},Axes->False,ImageSize->800,Background->Black],{t,0,26,0.1}];

Length[aniuu4BB]

Show[aniuu4BB[[1]],ImageSize->600]

Show[aniuu4BB[[261]],ImageSize->600]

ListAnimate[Show[#,ImageSize->600]&/@aniuu4BB]

(* 
 dds=0.1&/@Range[Length[aniuu4BB]];  
Export["aniuu4BBs1.gif",aniuu4BB[[1]],"ImageSize"->800];Export["aniuu4BBAni.gif",aniuu4BB,"AnimationRepetitions"->Infinity,"ImageSize"->800,"DisplayDurations"->dds] 
*)

Back to Solution 1, but with different sizes of a super-glued part

Manipulate[Module[{meves1,mefs1,mff1,mcoefs1,mefns1,muu1},meves1=Map[(μ/.FindRoot[ h μ Cos[π μ]+Sin[π μ]==0,{μ,#}])&,Join[{.9,1.7},Range[2.6,20,1]]];
mefs1[x_]=(h #Cos[# x]+Sin[# x])&/@meves1;
mefns1=Chop[Table[NIntegrate[mefs1[x][[j]]mefs1[x][[j]],{x,0,Pi},MaxRecursion->200,AccuracyGoal->10,PrecisionGoal->10],{j,1,Length[meves1]}]];
mff1[x_,h_]=((h^(3/4))/12) (-1+x) (-π+x) ((π/(1+π))+x) (1+(x/h));
mcoefs1=Chop[Table[NIntegrate[(mff1[x,h])mefs1[x][[j]],{x,0,Pi},MaxRecursion->200,AccuracyGoal->10,PrecisionGoal->10],{j,1,Length[meves1]}]];muu1[x_,t_]=(mefs1[x]*((Cos[# t])&/@meves1)).((mcoefs1/mefns1));
Plot[Evaluate[muu1[x,t]],{x,0,Pi},PlotStyle->{{Thickness[0.01],Blue}},
Epilog->{
{Red,Thickness[0.01],Line[{{-h,0},{0,Evaluate[muu1[0,t]]}}]},{PointSize[0.012],Point[#]&/@{{-h,0},{Pi,0}}}
},
PlotRange->{{-2.1,Pi+0.1},{-1.2,1.2}},AspectRatio->1/5,Frame->True,FrameTicks->{{{},{}},{Join[Range[-2,((-1)/4),(1/4)],Range[0,Pi,Pi/4]],{}}},Axes->False,ImageSize->500]

],{t,0,7.3,0.05},{{h,1},(1/4),2,(1/4),ControlType->Setter}]

Solution 5

In this problem we consider a string of length π  stretched over the interval [0,π] with a Robin boundary condition at 0 and the Dirichlet boundary condition at π.  In this case the Robin boundary condition  u[0,t]+π(∂_x)u[0,t]=0  is so-called non-physical boundary condition. I invented a way of interpreting this condition as a straight line-segment being attached to the string at the left-hand end-point. See the animations below. An interesting feature in this case is that 0 is an eigenvalue.

We want to solve

PDE: (∂_tt)u[x,t]=(∂_xx)u[x,t], 0≤x≤π, t≥0,  
BCS: u[0,t]+ π(∂_x)u[0,t]=0, u[π,t]=0  for all t≥0, 
ICs: u[x,0]=ff1[x], (∂_t)u[x,0]=0   for all  x∈[0,π].

So we need to solve the Sturm-Liouville eigenvalue problem

-y(x)''= λ x y(x),  0≤x≤π,  
   y(0)+ π y'(0) =0,   
    y(π)=0 .

Look for negative eigenvalues

We look for negative eigenvalues λ = -(μ^2)

-y(x)''= -(μ^2) y(x),  0≤x≤π,  
   y(0)+ π y'(0) =0,   
    y(π)=0 .

DSolve[y''[x]==(μ^2)y[x],y[x],x]

Force Mathematica to give us hyperbolic functions as the fundamental set of solutions:

Simplify[(ExpToTrig[DSolve[y''[x]==(μ^2)y[x],y[x],x]])]/.{C[1]+C[2]->C[1],C[1]-C[2]->C[2]}

Substitute the fundamental solution (Cosh[μ x] C[1]+Sinh[μ x] C[2]) into the boundary conditions and collect the expression with C[1] and C[2]. This will give us two homogeneous equations.

Collect[((Cosh[μ x]C[1]+Sinh[μ x] C[2])/.{x->0})+((D[(Cosh[μ x]C[1]+Sinh[μ x] C[2]),x])/.{x->0}),{C[1],C[2]}]

Collect[((Cosh[μ x]C[1]+Sinh[μ x] C[2])/.{x->Pi}),{C[1],C[2]}]

We want nontrivial solutions for C[1] and C[2] of the system

C[1]+π μ C[2] = 0 
C[1]Cosh[π μ]+C[2]Sin[π μ]=0

For a nontrivial solution to exists we need the determinant to be equal to 0

Det[{{1 ,μ Pi},{Cosh[Pi μ],Sinh[Pi μ] }}]

The above function is the function whose zeros for μ>0 give us -(μ^2) as the negative eigenvalues

Since the above function has no positive zeros there are no negative evs.  Below is a graphical verification of this claim.

Plot[-μ Cosh[π μ]+Sinh[π μ],{μ,0,3},PlotRange->{-3,3}]

The equation for the eigenvalue can be rewritten as Tanh[π μ] = μ

Plot[{Tanh[π μ],μ},{μ,0,3}]

evn2=μ/.FindRoot[-μ Cosh[π μ]+Sinh[π μ]==0,{μ,1}]

The corresponding eigenfunction is

efn2[x_]=evn2 Cosh[evn2 x]-Sinh[evn2 x]

Verify

FullSimplify[D[efn2[x],{x,2}]-(evn2^2)efn2[x]]

Zero is not an eigenvalue

Is zero an eigenvalue?

-y(x)''= 0 ,  0≤x≤π,  
   y(0)+ π y'(0) =0,   
    y(π)=0 .

DSolve[y''[x]==0,y[x],x]

Substitute into the boundary conditions

Collect[((C[1]+x C[2])/.{x->0})+Pi ((D[C[1]+x C[2],x])/.{x->0}),{C[1],C[2]}]

Collect[((C[1]+x C[2])/.{x->Pi}),{C[1],C[2]}]

We need a nontrivial solution for C[1] and C[2] of the system

C[1]+π C[2] = 0 
C[1]+π C[2] = 0

Since the determinant

Det[{{1,Pi},{1,Pi}}]

is zero, the system has a nontrivial solutions. Thus zero is an eigenvalue with an eigenfunction.

efs05[x_]=Pi-x

Look for positive eigenvalues

We look for positive eigenvalues λ = (μ^2)

-y(x)''= (μ^2) y(x),  0≤x≤π,  
   y(0)+ π y'(0) =0,   
    y(π)=0 .

DSolve[-y''[x]==(μ^2)y[x],y[x],x]

Substitute into the boundary conditions

Collect[((C[1] Cos[x μ]+C[2] Sin[x μ])/.{x->0})+Pi((D[C[1] Cos[x μ]+C[2] Sin[x μ],x])/.{x->0}),{C[1],C[2]}]

Collect[((C[1] Cos[x μ]+C[2] Sin[x μ])/.{x->Pi}),{C[1],C[2]}]

We want nontrivial solutions for C[1] and C[2] of the system

C[1]+π μ C[2] = 0 
C[1] Cos[π μ]+C[2] Sin[π μ] = 0

For a nontrivial solution to exists we need the determinant to be equal to 0

Det[{{1 ,μ Pi },{Cos[π μ],Sin[π μ]}}]

The above function is the function whose zeros for μ>0 give (μ^2) as the negative eigenvalues

Getting solutions for μ “visually”

Plot[-π μ Cos[π μ]+Sin[π μ],{μ,0,13},Ticks->{Range[0,20,1],Automatic}]

Or, more informative graph

Plot[{μ π ,((Sin[π μ])/(Cos[π μ]))},{μ,0,6},Ticks->{Range[0,20,1],Automatic},PlotRange->{-18,18}]

Mathematica has a command to find approximate solutions:

FindRoot[-μ π Cos[π μ]+Sin[π μ]==0,{μ,1.2}]

In the command above we need to give an initial guess. Then Mathematica finds a much better approximation which is nearby. Mathematica’s approximate value above is given as a substitution rule. To get just the numeric value do

μ/.FindRoot[-μ π Cos[π μ]+Sin[π μ]==0,{μ,1.2}]

However, we need many solutions.  To do that I make the above command as a pure function

(μ/.FindRoot[-μ π Cos[π μ]+Sin[π μ]==0,{μ,#}])&[1.2]

Next I make a list of initial guesses:

Join[{1.3},Range[2.5,20,1]]

Next I verify that my initial guesses are close to the actual zeros of the function

Plot[-μ π Cos[π μ]+Sin[π μ],{μ,0,13},Epilog->{{Red,Point[{#,0}]&/@Join[{1.3},Range[2.5,20,1]]}},Ticks->{Range[0,20,1],Automatic}]

Then I “map” my “zero finding function” to this list

Map[(μ/.FindRoot[-μ π Cos[π μ]+Sin[π μ]==0,{μ,#}])&,Join[{1.3},Range[2.5,20,1]]]

Next I name these approximate eigenvalues. The named list of  many μ-s will be essential in what follows.

Clear[eves5];
eves5=(μ/.FindRoot[- μ π Cos[π μ]+ Sin[π μ]==0,{μ,#}])&/@Join[{1.3},Range[2.5,20,1]]

Length[eves5]

Thus we found nineteen eigenvalues and remember that 0 is also an eigenvalue.

I visually inspect that there are no repetitions.

Now I can check graphically that I got the right solutions

Plot[-μ π Cos[π μ]+Sin[π μ],{μ,0,20},Epilog->{{Red,PointSize[0.015],Point[{#,0}]&/@eves5}},Ticks->{Range[0,20,1],Automatic}]

Looks good.

Let us apply the original function to these approximations:

Chop[(-# π Cos[π #]+Sin[π #])&/@eves5]

Quite good!

Based on the matrix that determined the eigenvalues we can now define the eigenfunctions:  With μ being the solution of  μ π Cos[π μ]+Sin[π μ] =0, a corresponding eigenfunction is found be solving for (Subscript[C, 1]) and (Subscript[C, 2]) the following system

MatrixForm[{{1 ,μ π},{Cos[π μ],Sin[π μ]}}]

(({{1, μ π}, {Cos[π μ], Sin[π μ]}}))(({{(Subscript[C, 1])}, {(Subscript[C, 2])}}))=(({{0}, {0}}))

Since the determinant of this system is zero, the system has many solutions.  A simple solution is  (Subscript[C, 1])=μ π, (Subscript[C, 2])=-1.  Below are twenty eigenfunctions corresponding to the eigenvalues that we found.

Clear[efs5];
efs5[x_]=(# π Cos[# x]-Sin[# x])&/@eves5

Here is, for example, the third eigenfunction

efs5[x][[3]]

But, do not forget to prepend the eigenfunction corresponds to 0 eigenvalue:

efs5[x]=Prepend[efs5[x],efs05[x]]

Length[efs5[x]]

Now also Prepend 0 to eigenvalues eves5:

eves5=Prepend[eves5,0]

Length[eves5]

Verify the eigenvalue equation:

FullSimplify[Table[D[efs5[x][[k]],{x,2}]+(((eves5[[k]]))^2)efs5[x][[k]],{k,1,Length[eves5]}]]

Verify the boundary conditions

Table[Chop[{(((efs5[x][[k]])/.{x->0})+Pi(D[efs5[x][[k]],{x,1}])/.{x->0}),((efs5[x][[k]])/.{x->Pi})}],{k,1,Length[efs5[x]]}]

Let us verify it the eigenfunctions are mutually orthogonal:

Chop[Table[NIntegrate[efs5[x][[j]]efs5[x][[k]],{x,0,Pi},MaxRecursion->200,AccuracyGoal->10,PrecisionGoal->10],{j,1,Length[efs5[x]]},{k,1,Length[efs5[x]]}]]

We will need the integrals of the squares for later

efns5=Chop[Table[NIntegrate[efs5[x][[j]]efs5[x][[j]],{x,0,Pi},MaxRecursion->200,AccuracyGoal->10,PrecisionGoal->10],{j,1,Length[efs5[x]]}]]

Initial condition

ff5[x_]=((((Pi-#))/(2Pi))( ((#)^2)+0 #+1))&[x]

ff5[x_]:=((((Pi-#))/(2Pi))( (1/4) ((#)^3)-(1/2) ((#)^2)+0 #+(1/2)))&[x] (* stays above x-axes *)

ff5[x_]:=((((Pi-#))/(2Pi))( (1/6) ((#)^3)-(1/4) ((#)^2)+0 #+(0/2)))&[x]

Verify the boundary condition:

{FullSimplify[ff5[0]+Pi ff5'[0]],ff5[Pi]}

Manipulate[Plot[{((((Pi-#))/(2Pi))( a ((#)^3)+b ((#)^2)+0 #+d))&[x],((((((Pi-#))/(2Pi))( a ((#)^3)+b ((#)^2)+0 #+d))&[0])/Pi)(Pi-x)},{x,0,Pi}],{{a,1/6},-2,2},{{b,-1/4},-3,3},{{d,0},-3,3}]

coefs5=Chop[Table[NIntegrate[(ff5[x])efs5[x][[j]],{x,0,Pi},MaxRecursion->200,AccuracyGoal->10,PrecisionGoal->10],{j,1,Length[efs5[x]]}]]

(coefs5/efns5)

(efs5[x]*((Cos[# t])&/@eves5)).((coefs5/efns5))

Clear[uu5]; uu5[x_,t_]=(efs5[x]*((Cos[# t])&/@eves5)).((coefs5/efns5))

uu5[1,0.4]

Plot[Evaluate[{(ff5[x]),uu5[x,0]}],{x,0,Pi},PlotStyle->{{Thickness[0.01],Blue},{Thickness[0.005],Yellow}},Epilog->{{Red,Thickness[0.005],Line[{{Pi,0},{0,uu5[0,0]}}]}},PlotRange->{{-0.1,Pi+.1},{-0.65,0.65}},AspectRatio->1/4,Frame->True,FrameTicks->{{{},{}},{Join[{1},Range[0,Pi,Pi/4]],{}}},Axes->False,ImageSize->600]

Manipulate[Plot[Evaluate[uu5[x,t]],{x,0,Pi},
PlotStyle->{{Thickness[0.01],Blue}},
Epilog->{{Red,Thickness[0.005],Line[{{Pi,0},{0,uu5[0,t]}}]},
{PointSize[0.012],Point[#]&/@{{Pi,0},{Pi,0}}}
},PlotRange->{{-0.1,Pi+.1},{-0.18,0.18}},AspectRatio->1/5,Frame->True,FrameTicks->{{{},{}},{Join[{1},Range[0,Pi,Pi/4]],{}}},Axes->False,ImageSize->600],{t,0,17.7,0.1},ControlPlacement->Top]

Because of the negative eigenvalue, this string brakes.

aniuu5BB=Table[Plot[Evaluate[uu5[x,t]],{x,0,Pi},PlotStyle->{{Thickness[0.01],RGBColor[1,0.5,0]}},
Epilog->{
{Red,Thickness[0.007],Opacity[0.65],Line[{{Pi,0},{0,Evaluate[uu5[0,t]]}}]},{PointSize[0.012],White,Point[#]&/@{{Pi,0},{Pi,0}}},
{Text["t =",{1.45+0.08,0.16},BaseStyle-> {FontWeight->"Normal",FontColor->RGBColor[1,1,1]}],Text[NumberForm[N[t],{3,1}],{1.5+0.1,0.16},BaseStyle-> {FontWeight->"Normal",FontColor->RGBColor[1,1,1]}]}
},
PlotRange->{{-0.1,Pi+0.1},{-0.18,0.18}},AspectRatio->1/5,Frame->True,FrameTicks->{{{},{}},{Range[0,Pi,Pi/4],{}}},Axes->False,ImageSize->800,Background->Black],{t,0,17.7,0.05}];

Length[aniuu5BB]

Show[aniuu5BB[[200]],ImageSize->800]

ListAnimate[Show[#,ImageSize->600]&/@aniuu5BB,ControlPlacement->Top]

(* SetDirectory[NotebookDirectory[]]  *)

(* 
dds5=(0.1/@Range[Length[aniuu5BB]]); 
Export["aniuu5BBs1.gif",aniuu5BB[[1]],"ImageSize"->800];Export["aniuu5BBAni.gif",aniuu5BB,"AnimationRepetitions"->Infinity,"ImageSize"->800,"DisplayDurations"->dds5]  
*)