Iteratively running through list of parameter sets with ParametricNDSolve - wolfram-mathematica

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

Related

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.

how do I solve a double integral in Mathematica?

I am very new to Mathematica, and I am trying to solve the following problem.
I have a cubic equation of the form Z = aZ^3 + bZ^2 + a + b. The first thing I want to do is to get a function that solves this analytically for Z and chooses the minimal positive root for that, as a function of a and b.
I thought that in order to get the root I could use:
Z = Solve[z == az^3 + bz^2 + a + b, z];
It seems like I am not quite getting the roots, as I would expect using the general cubic equation solution formula.
I want to integrate the minimal positive root of Z over a and b (again, preferably analytically) from 0 to 1 for a and for a to 1 for b.
I tried
Y = Integrate[Z, {a, 0, 1}, {b, a, 1}];
and that does not seem to give any formula or numerical value, but just returns an integral. (Notice I am not even sure how to pick the minimal positive root, but I am playing around with Mathematica to try to figure it out.)
Any ideas on how to do this?
Spaces between a or b and z are important. You can get the roots by:
sol = z /. Solve[z == a z^3 + b z^2 + a + b, z]
However, are you sure this expression has a solution as you expect? For a=0.5 and b=0.5, the only real root is negative.
sol /. {a->0.5, b->0.5}
{-2.26953,0.634765-0.691601 I,0.634765+0.691601 I}
sol = z /. Solve[z == a z^3 + b z^2 + a + b, z];
zz[a0_ /; NumericQ[a0], b0_ /; NumericQ[b0]] :=
Min[Select[ sol /. {a -> a0, b -> b0} ,
Element[#, Reals] && # > 0 & ]]
This returns -infinty when there are no solutions. As sirintinga noted your example integration limits are not valid..
RegionPlot[NumericQ[zz[a, b] ] , {a, -1, .5}, {b, -.5, 1}]
but you can numerically integrate if you have a valid region..
NIntegrate[zz[a, b], {a, -.5, -.2}, {b, .8, .9}] ->> 0.0370076
Edit ---
there is a bug above Select in Reals is throwin away real solutions with an infinitesimal complex part.. fix as:..
zz[a0_ /; NumericQ[a0], b0_ /; NumericQ[b0]] :=
Min[Select[ Chop[ sol /. {a -> a0, b -> b0} ],
Element[#, Reals] && # > 0 & ]]
Edit2, a cleaner approach if you dont find Chop satisfyting..
zz[a0_ /; NumericQ[a0], b0_ /; NumericQ[b0]] :=
Module[{z, a, b},
Min[z /. Solve[
Reduce[(z > 0 && z == a z^3 + b z^2 + a + b /.
{ a -> a0, b -> b0}), {z}, Reals]]]]
RegionPlot[NumericQ[zz[a, b] ] , {a, -2, 2}, {b, -2, 2}]
NIntegrate[zz[a, b], {a, 0, .5}, {b, 0, .5 - a}] -> 0.0491321

functional programming

Suppose I have this Mathematica code, whose output, a real number, depends on the input, say, x,y,z. How do I make a real-valued function in x,y,z based on the code?
If the code describes a simple relationship among x,y,z, I could define this function directly. The point here is that the given code is a very complicated block (or module).
For example, if the code simply sums x,y,z, I would simply define
f[x_,y_,z_]=x+y+z
What if I have a very complex example, like the one below:
s0[a_, b_, x_] :=
{1, 0, (a + b) x + (1 - a - b)}
s1[a_, b_, c_, d_, p_, q_, n_, x_] :=
Which[0 <= x <= c, {2, n - 1, x/c*q + p},
c <= x <= c + d, {2, n, (x - c)/d*p},
c + d <= x <= 1, {1, n + 1, (x - (c + d))/(1 - c - d)*(1 - a - b)}]
s2[s_, t_, c_, d_, p_, q_, n_, x_] :=
Which[0 <= x <= 1 - s - t, {2, n - 1,
x/(1 - s - t)*(1 - p - q) + p + q},
1 - s - t <= x <= 1 - s, {3,
n - 1, (x - (1 - s - t))/t*(1 - c - d) + c + d},
1 - s <= x <= 1, {3, n, (x - (1 - s))/s*d + c}]
s3[c_, a_, b_, s_, t_, n_, x_] :=
Which[0 <= x <= 1 - a - b, {4, n - 1, x/(1 - a - b)*t + 1 - s - t},
1 - a - b <= x <= 1 - a, {4, n, (x - (1 - a - b))/b*(1 - s - t)},
1 - a <= x <= 1, {3, n + 1, (x - (1 - a))/a*c}]
s4[p_, q_, s_, a_, b_, n_, x_] :=
Which[0 <= x <= p, {4, n - 1, x/p*s + 1 - s},
p <= x <= p + q, {5, n - 1, (x - p)/q*a/(a + b) + b/(a + b)},
p + q <= x <= 1, {5, n, (x - (p + q))/(1 - p - q)*b/(a + b)}]
F[{k_, n_, x_}] :=
Which[k == 0, s0[a, b, x],
k == 1, s1[a, b, c, d, p, q, n, x],
k == 2, s2[s, t, c, d, p, q, n, x],
k == 3, s3[c, a, b, s, t, n, x],
k == 4, s4[p, q, s, a, b, n, x]]
G[x_] := NestWhile[F, {0, 0, x}, Function[e, Extract[e, {1}] != 5]]
H[x_] := Extract[G[x], {2}] + Extract[G[x], {3}]
H[0]
For the above code to run, one needs to specify the list
{a,b,c,d,p,q,s,t}
And the output are real numbers. How does one define a function in a,b,c,d,p,q,s,t that spits out these real numbers?
Your essential problem is that you have a large number of parameters in your auxiliary functions, but your big-letter functions (F, G and H and by the way single-capital-letter function names in Mathematica are a bad idea) only take three parameters and your auxiliary functions (s0 etc) only return three values in the returned list.
You have two possible ways to fix this.
You can either redefine everything to require all the parameters required in the whole system - I'm assuming that common parameter names across the auxiliary functions really are common values - like this:
G[x_, a_, b_, c_, d_, p_, q_, s_, t_] :=
NestWhile[F, {0, 0, x, a, b, c, d, p, q, s, t},
Function[e, Extract[e, {1}] != 5]]
or
You can set some options that set these parameters globally for the whole system. Look up Options and OptionsPattern. You would do something like this:
First, define default options:
Options[mySystem] = {aa -> 0.2, bb -> 1., cc -> 2., dd -> 4.,
pp -> 0.2, qq -> 0.1, ss -> 10., tt -> 20.}
SetOptions[mySystem, {aa->0.2, bb->1., cc->2., dd->4., pp->0.2,
qq->0.1, ss->10., tt->20.}]
Then write your functions like this:
F[{k_, n_, x_}, OptionsPattern[mySystem]] :=
With[{a = OptionValue[aa], b = OptionValue[bb], c = OptionValue[cc],
d = OptionValue[dd], p = OptionValue[pp], q = OptionValue[qq],
s = OptionValue[ss], t = OptionValue[tt]},
Which[k == 0, s0[a, b, x], k == 1, s1[a, b, c, d, p, q, n, x],
k == 2, s2[s, t, c, d, p, q, n, x], k == 3,
s3[c, a, b, s, t, n, x], k == 4, s4[p, q, s, a, b, n, x]] ]
There is also something quite wrong with your use of Extract (you are assuming there are more parts in your list than are actually there in the first few iterations), but this answers your main issue.

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.

How to "embed" Piecewise in NDSolve in 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.

Resources