How to "embed" Piecewise in NDSolve in Mathematica - wolfram-mathematica

I am using NDSolve to solve a non-linear partial differential
equation.
I'd like one of the variables (Kvar) to be a function
of the time step currently being solved and hence and using
Piecewise.
Mathematica generates an error message saying:
SetDelayed::write: Tag Real in 0.05[t_] is Protected. >>
NDSolve::deqn: Equation or list of equations expected instead of
$Failed in the first argument ....
ReplaceAll::reps: ....
I haven't included the entire error message for ease of reading.
My code is as follows:
Needs["VectorAnalysis`"]
Needs["DifferentialEquations`InterpolatingFunctionAnatomy`"];
Clear[Eq4, EvapThickFilm, h, S, G, E1, K1, D1, VR, M, R]
Eq4[h_, {S_, G_, E1_, K1_, D1_, VR_, M_, R_}] := \!\(
\*SubscriptBox[\(\[PartialD]\), \(t\)]h\) +
Div[-h^3 G Grad[h] +
h^3 S Grad[Laplacian[h]] + (VR E1^2 h^3)/(D1 (h + K1)^3)
Grad[h] + M (h/(1 + h))^2 Grad[h]] + E1/(
h + K1) + (R/6) D[D[(h^2/(1 + h)), x] h^3, x] == 0;
SetCoordinates[Cartesian[x, y, z]];
EvapThickFilm[S_, G_, E1_, K1_, D1_, VR_, M_, R_] :=
Eq4[h[x, y, t], {S, G, E1, K1, D1, VR, M, R}];
TraditionalForm[EvapThickFilm[S, G, E1, K1, D1, VR, M, R]];
And the second cell where I am trying to implement Piecewise in NDSolve:
L = 318; TMax = 7.0;
Off[NDSolve::mxsst];
(*Ktemp = Array[0.001+0.001#^2&,13]*)
hSol = h /. NDSolve[{
(*S,G,E,K,D,VR,M*)
Kvar[t_] := Piecewise[{{0.01, t <= 4}, {0.05, t > 4}}],
EvapThickFilm[1, 3, 0.1, Kvar[t], 0.01, 0.1, 0, 160],
h[0, y, t] == h[L, y, t],
h[x, 0, t] == h[x, L, t],
(*h[x,y,0] == 1.1+Cos[x] Sin[2y] *)
h[x, y, 0] ==
1 + (-0.25 Cos[2 \[Pi] x/L] - 0.25 Sin[2 \[Pi] x/L]) Cos[
2 \[Pi] y/L]
},
h,
{x, 0, L},
{y, 0, L},
{t, 0, TMax}
][[1]]
hGrid = InterpolatingFunctionGrid[hSol];
PS: I am sorry but the first cell block doesn't display so well here. And thanks to not having enough "reputation", I can't post images.
The error message occurs when using the NDSolve cell block.

Define the function Kvar outside of a set of equations in NDSolve, like
Off[NDSolve::mxsst];
(*Ktemp=Array[0.001+0.001#^2&,13]*)
Kvar[t_] := Piecewise[{{0.01, t <= 4}, {0.05, t > 4}}];
hSol = ...
and remove it from the list in NDSolve, so that it starts as NDSolve[{(*S,G,E,K,D,VR,M*)EvapThickFilm[..., and it will work. It gives warnings, but those are related to possible singularities in your equation.
Also, your original error indicates that your Kvar was assigned a value of 0.05. So, add Clear[Kvar] before anything else in the second cell.

Related

2D Heat Equation Mathematica not solving analitically (DSolve) or numerically (NDSolve), what am I doing wrong?

my goal is to solve the following 2d heat conduction equation, along with initial and boundary conditions:
pde = D[u[x, y, t], t] == (c^2)*(D[u[x, y, t], {x, 2}] + D[u[x, y, t], {y, 2}]);
ic = {u[x,y,0] == 0};
bc = {Derivative[1, 0, 0][u][0, y, t] == k, u[x, 0, t] == 0, u[x, b, t] == 0,
u[a, y, t] == 0};
...but something always goes wrong when i input
sol = DSolve[{pde, bc, ic}, u[x, y, t], {x, y, t}]
I tried changing the conditions a bit to see if that is a problem on mathematica, and sometimes it works (example of this guy). I suspect there is something wrong with the derivative, but I tried using D[u[x,y,t],x]./x->0 == k but still it doesnt work. Is it even possible to solve this in Mathematica?

Iteratively running through list of parameter sets with ParametricNDSolve

So I have the below code
perturb1 =
x'[t] == mu1*x[t] + x[t]*(a*x[t] + b*y[t] + c*z[t]) +
x[t]*eps1 * (UnitStep[t - 1.5] - UnitStep[t - 2.5]);
perturb2 =
y'[t] == mu2*y[t] + y[t]*(d*x[t] + e*y[t] + f*z[t]) +
y[t]*eps2 * (UnitStep[t - 1.5] - UnitStep[t - 2.5]);
perturb3 =
z'[t] == mu3*z[t] + z[t]*(g*x[t] + h*y[t] + i*z[t]) +
z[t]*eps3 * (UnitStep[t - 1.5] - UnitStep[t - 2.5]);
perturbSol = ParametricNDSolve[
{perturb1, perturb2, perturb3, x[0] == 0.25, y[0] == 0.4,
z[0] == 0.35},
{x[t], y[t], z[t]},
{t, 0, 500},
{mu1, mu2, mu3, a, b, c, d, e, f, g, h, i, eps1, eps2, eps3}
];
Evaluate[x[t][#] /. perturbSol] & /# parameterSets
parameterSets is a list of 5000+ elements of the form {mu1, mu2, mu3, a, b, c, d, e, f, g, h, i, eps1, eps2, eps3} (but with numerical values). What I'm trying to do is to evaluate the parametric function using each parameter set. When I do as above, I get the error
ParametricNDSolve: Too many parameters in {mu1,mu2,mu3,a,b,c,d,e,f,g,h,i,eps1,eps2,eps3} to be filled from {{0.9,0.9,0.9,-2,-1,-1,-1,-2,-1,-1,-1,-2,-2,-2,-2}}.
So it seems that it's because, with a single value, you would evaluate the function as follows:
Evaluate[x[t][0.9,0.9,0.9,-2,-1,-1,-1,-2,-1,-1,-1,-2,-2,-2,-2]/.perturbSol]
Whereas when using Map on parameterSets, it does this:
Evaluate[x[t][{0.9,0.9,0.9,-2,-1,-1,-1,-2,-1,-1,-1,-2,-2,-2,-2}]/.perturbSol]
i.e. it's applying the function to a list of 15 parameters, rather than to the 15 parameters separated by commas.
Is there any elegant solution to this? I tried flatten around the #, which didn't do anything (as I sort of expected). I guess one way is to write #1,#2,#3 etc in the square brackets but that's pretty messy.
Any better way to do this?
Many thanks,
H
Probably, you want something along the lines of
u = ParametricNDSolveValue[{perturb1, perturb2, perturb3,
x[0] == 0.25, y[0] == 0.4, z[0] == 0.35}, {x, y, z}, {t, 0,
500}, {mu1, mu2, mu3, a, b, c, d, e, f, g, h, i, eps1, eps2,
eps3}];
parameterSets = RandomReal[{-1, 1}, {3, 15}];
(u[##])[[1]][t] & ### parameterSets

NMinimize with numerical integrating

I'm trying to find the coefficients of a function by minimizing an equation who I know is zero with Mathematica. My code is:
Clear[f];
Clear[g];
Clear[GetGood];
Clear[int];
Clear[xlist];
Xmax = 10;
n = 10;
dx = Xmax/n;
xlist = Table[i*dx, {i, n}];
A = 3.5;
slope = (A + 2)/3;
f[x_, a_, b_, c_, d_, e_] :=a/(1 + b*x + c*x^2 + d*x^3 + e*x^4)^(slope/4 + 2);
g[x_, a_, b_, c_, d_, e_] :=Derivative[1, 0, 0, 0, 0, 0][f][x, a, b, c, d, e];
int[a_?NumericQ, b_?NumericQ, c_?NumericQ, d_?NumericQ, e_?NumericQ] :=
Module[{ans, i},ans = 0;Do[ans =ans + Quiet[NIntegrate[
y^-slope*(f[Sqrt[xlist[[i]]^2 + y^2 + 2*xlist[[i]]*y*m], a, b,
c, d, e] - f[xlist[[i]], a, b, c, d, e]), {m, -1, 1}, {y,
10^-8, \[Infinity]}, MaxRecursion -> 30]], {i, 1,
Length[xlist]}];
ans
];
GetGood[a_?NumericQ, b_?NumericQ, c_?NumericQ, d_?NumericQ,e_?NumericQ] :=
Module[{ans},ans = Abs[Sum[3*f[x, a, b, c, d, e] + x*g[x, a, b, c, d,e],
{x,xlist}]+2*Pi*int[a, b, c, d, e]];
ans
];
NMinimize[{GetGood[a, b, c, d, e], a > 0, b > 0, c > 0, d > 0,
e > 0}, {a, b, c, d, e}]
The error I get after the last line is:
Part::pspec: Part specification i$3002170 is neither an integer nor a list of integers. >>
NIntegrate::inumr: "The integrand (-(1.84529/(1+<<3>>+0.595769 Part[<<2>>]^4)^2.45833)+1.84529/(1+<<18>> Sqrt[Plus[<<3>>]]+<<1>>+<<1>>+0.595769 Plus[<<3>>]^2)^2.45833)/y^1.83333 has evaluated to non-numerical values for all sampling points in the region with boundaries {{-1,1},{\[Infinity],1.*10^-8}}"
Any ideas why I am getting an error?
Thanks
Change your NMinimize to be
NMinimize[{GetGood[a,b,c,d,e],a>0&&b>0&&c>0&&d>0&&e>0}, {a,b,c,d,e}]
to get your constraints to work correctly. Their help page should really show an example of using more than a single constraint. This old page does show an example.
http://reference.wolfram.com/legacy/v5_2/functions/AdvancedDocumentationNMinimize
If you change your int[] to
int[a_?NumericQ, b_?NumericQ, c_?NumericQ, d_?NumericQ, e_?NumericQ] :=
Module[{ans, i}, ans = 0; Do[
Print["First i=", i];
ans = ans + Quiet[NIntegrate[
Print["Second i=", i];
y^-slope*(f[Sqrt[xlist[[i]]^2 + y^2 + 2*xlist[[i]]*y*m], a,b,c,d,e] -
f[xlist[[i]], a,b,c,d,e]), {m,-1,1}, {y,10^-8, \[Infinity]}, MaxRecursion -> 30]],
{i, 1, Length[xlist]}];
ans];
you will see
First i=1
Second i=1
....
First i=10
Second i=i$28850
where the first debug print never says i=i$nnnn but the second debug print does often show that i has been unassigned a value only inside your NIntegrate, not outside it, and only after i has reached a value of 10, the length of your xlist, and at that point you can't subscript by a symbol and you get the error messages you have seen.
Nothing inside your NIntegrate is changing the value of i.
I think you may have stumbled onto a bug where Mathematica is writing over the value of i.
See if you can simplify the code without driving the bug into hiding. If you can make it simpler and still show the problem you might have more likelihood of success in getting Wolfram to admit you have found a bug.

Free boundary conditions in MATHEMATICA - is this right? Second opinion

I'm trying to prescribe free boundary conditions for a non-linear evolution equation in mathematica and I wanted as second opinion on whether or not what I am doing is right.
The boundary conditions have been marked with a comment, viz., (FREE BOUNDARY CONDITIONS)
I'd also like to run this for pinned boundary conditions.
Needs["VectorAnalysis`"]
Needs["DifferentialEquations`InterpolatingFunctionAnatomy`"];
Clear[Eq5, Complete, h, S, G, E1, K1, D1, VR, M]
Eq5[h_, {S_, G_, E1_, K1_, D1_, VR_, M_}] := \!\(
\*SubscriptBox[\(\[PartialD]\), \(t\)]h\) +
Div[-h^3 G Grad[h] +
h^3 S Grad[Laplacian[h]] + (VR E1^2 h^3)/(D1 (h + K1)^3)
Grad[h] + M (h/(1 + h))^2 Grad[h]] + E1/(h + K1) == 0;
SetCoordinates[Cartesian[x, y, z]];
Complete[S_, G_, E1_, K1_, D1_, VR_, M_] :=
Eq5[h[x, y, t], {S, G, E1, K1, D1, VR, M}];
TraditionalForm[Complete[S, G, E1, K1, D1, VR, M]]
L = 185.62; TMax = 100; km = 0.0381;
Off[NDSolve::mxsst];
Off[NDSolve::ibcinc];
hSol = h /. NDSolve[{Complete[100, 0, 0, 0, 0.001, 0, 5],
(*FREE BOUNDARY CONDITIONS*)
Derivative[2, 0, 0][h][0, y, t] == 0,
Derivative[2, 0, 0][h][L, y, t] == 0,
Derivative[0, 2, 0][h][x, 0, t] == 0,
Derivative[0, 2, 0][h][x, L, t] == 0,
Derivative[3, 0, 0][h][0, y, t] == 0,
Derivative[3, 0, 0][h][L, y, t] == 0,
Derivative[0, 3, 0][h][x, 0, t] == 0,
Derivative[0, 3, 0][h][x, L, t] == 0,
(*FREE BOUNDARY CONDITIONS*)
h[x, y, 0] == 1 + (-0.05*Cos[2*Pi*(x/L)] - 0.05*Sin[2*Pi*(x/L)])*
Cos[2*Pi*(y/L)]},
h, {x, 0, L}, {y, 0, L}, {t, 0, TMax}][[1]]
hGrid = InterpolatingFunction[hSol];
{TMin, TRup} = InterpolatingFunctionDomain[hSol][[3]]
The consensus achieved from reading the comments is that the implementation of free boundary conditions in the code above is correct.
More detail should be available in books dealing with mechanics of materials or strength of materials in chapters referring to Bending moments and shear stress diagrams where very often free-free or free-fixed or fixed-fixed boundary conditions are used.

Memory exhaustion while running NDSolve

I run into the "No more memory available" error message in Mathematica. I understand that "Parallelize[]" isn't (obviously) going to help me. Neither has "ClearSystemCache[]".
What gives? Do I just need more RAM?
My Code
Needs["VectorAnalysis`"]
Needs["DifferentialEquations`InterpolatingFunctionAnatomy`"];
Clear[Eq4, EvapThickFilm, h, S, G, E1, K1, D1, VR, M, R]
Eq4[h_, {S_, G_, E1_, K1_, D1_, VR_, M_, R_}] := \!\(
\*SubscriptBox[\(\[PartialD]\), \(t\)]h\) +
Div[-h^3 G Grad[h] +
h^3 S Grad[Laplacian[h]] + (VR E1^2 h^3)/(D1 (h + K1)^3)
Grad[h] + M (h/(1 + h))^2 Grad[h]] + E1/(
h + K1) + (R/6) D[D[(h^2/(1 + h)), x] h^3, x] == 0;
SetCoordinates[Cartesian[x, y, z]];
EvapThickFilm[S_, G_, E1_, K1_, D1_, VR_, M_, R_] :=
Eq4[h[x, y, t], {S, G, E1, K1, D1, VR, M, R}];
TraditionalForm[EvapThickFilm[S, G, E1, K1, D1, VR, M, R]];
L = 318; TMax = 10;
Off[NDSolve::mxsst];
Clear[Kvar];
Kvar[t_] := Piecewise[{{1, t <= 1}, {2, t > 1}}]
(*Ktemp = Array[0.001+0.001#^2&,13]*)
hSol = h /. NDSolve[{
(*S,G,E,K,D,VR,M*)
EvapThickFilm[1, 3, 0.1, 7, 0.01, 0.1, 0, 160],
h[0, y, t] == h[L, y, t],
h[x, 0, t] == h[x, L, t],
(*h[x,y,0] == 1.1+Cos[x] Sin[2y] *)
h[x, y, 0] ==
1 + (-0.25 Cos[2 \[Pi] x/L] - 0.25 Sin[2 \[Pi] x/L]) Cos[
2 \[Pi] y/L]
},
h,
{x, 0, L},
{y, 0, L},
{t, 0, TMax},
MaxStepSize -> 0.1
][[1]]
hGrid = InterpolatingFunctionGrid[hSol];
Error message
No more memory available.
Mathematica kernel has shut down.
Try quitting other applications and then retry.
My OS specs
Intel Core 2 Duo with 4.00 GB ram, 64 bit OS (Windows 7)
Here you may get a taste of what is happening:
Replace
MaxStepSize -> 0.1
by
MaxStepFraction -> 1/30
And run your code.
Then:
p = Join[#,Reverse##]&#
Table[Plot3D[hSol[x, y, i], {x, 0, L}, {y, 0, L},
PlotRange -> {All, All, {0, 4}}],
{i, 7, 8, .1}]
Export["c:\\plot.gif", p]
So, Mma is trying to refine the solution at those peaks, to no avail.

Resources