Clear[x, y, h, k, FirstSlope, SecondSlope];
h = [Pi]; y[[Pi]] = 0;
dy[x_, y_] = (Cos[x] - 3 x^2 y)/x^3;
Do[{x[k] = [Pi] + h*(k - [Pi]),
FirstSlope = dy[x[k], y[k]],
SecondSlope = dy[x[k] + h, y[k] + h*FirstSlope],
y[k + [Pi]] = y[k] + (h*(FirstSlope + SecondSlope))/2}, {k, [Pi],
5[Pi]}] Table[{x[k], y[k]}, {k, [Pi], 5[Pi]}];
MatrixForm[%]
Above image is my error. I'm trying to use Heun's method and my problem is:
1) I want it to stop at y[5 Pi] but it keeps going. I can manipulate it so that it goes to y[5 Pi], but I want to know why exactly it's doing this.
2) y[k] is not evaluating at k=pi,2pi,3pi, etc.
Related
Can I simply ask the logical flow of the below Mathematica code? What are the variables arg and abs doing? I have been searching for answers online and used ToMatlab but still cannot get the answer. Thank you.
Code:
PositiveCubicRoot[p_, q_, r_] :=
Module[{po3 = p/3, a, b, det, abs, arg},
b = ( po3^3 - po3 q/2 + r/2);
a = (-po3^2 + q/3);
det = a^3 + b^2;
If[det >= 0,
det = Power[Sqrt[det] - b, 1/3];
-po3 - a/det + det
,
(* evaluate real part, imaginary parts cancel anyway *)
abs = Sqrt[-a^3];
arg = ArcCos[-b/abs];
abs = Power[abs, 1/3];
abs = (abs - a/abs);
arg = -po3 + abs*Cos[arg/3]
]
]
abs and arg are being reused multiple times in the algorithm.
In a case where det > 0 the steps are
po3 = p/3;
b = (po3^3 - po3 q/2 + r/2);
a = (-po3^2 + q/3);
abs1 = Sqrt[-a^3];
arg1 = ArcCos[-b/abs1];
abs2 = Power[abs1, 1/3];
abs3 = (abs2 - a/abs2);
arg2 = -po3 + abs3*Cos[arg1/3]
abs3 can be identified as A in this answer: Using trig identity to a solve cubic equation
That is the most salient point of this answer.
Evaluating symbolically and numerically may provide some other insights.
Using demo inputs
{p, q, r} = {-2.52111798, -71.424692, -129.51520};
Copyable version of trig identity notes - NB a, b, p & q are used differently in this post
Plot[x^3 - 2.52111798 x^2 - 71.424692 x - 129.51520, {x, 0, 15}]
a = 1;
b = -2.52111798;
c = -71.424692;
d = -129.51520;
p = (3 a c - b^2)/3 a^2;
q = (2 b^3 - 9 a b c + 27 a^2 d)/27 a^3;
A = 2 Sqrt[-p/3]
A == abs3
-(b/3) + A Cos[1/3 ArcCos[
-((b/3)^3 - (b/3) c/2 + d/2)/Sqrt[-(-(b^2/9) + c/3)^3]]]
Edit
There is also a solution shown here
TRIGONOMETRIC SOLUTION TO THE CUBIC EQUATION, by Alvaro H. Salas
Clear[a, b, c]
1/3 (-a + 2 Sqrt[a^2 - 3 b] Cos[1/3 ArcCos[
(-2 a^3 + 9 a b - 27 c)/(2 (a^2 - 3 b)^(3/2))]]) /.
{a -> -2.52111798, b -> -71.424692, c -> -129.51520}
10.499
As in the title, in MATLAB, I need the feasible region (bounds of all feasible solutions) of
x_0 + x_1 e_1 + ... + x_n e_n
and
y_0 + y_1 e_1 + ... + y_n e_n
where all unknown e_i are in the interval [-1, 1]. I would prefer the solution to not depend on non-standard 3rd party functions.
Below is my quick-and-dirty attempt, but the complexity grows O(2^n), where n is the number of e_i. Any thoughts?
x0 = 3;
x = [1; -3; 0];
y0 = -1;
y = [3; -2; 4];
% Get all permutations of noise symbol extremities
terms = size(x, 1);
xx = zeros(2^terms, 1);
yy = zeros(2^terms, 1);
for j = 1:2^terms
e = double(bitget(j - 1, 1:terms))';
e(e == 0) = -1;
xx(j) = x0 + sum(x .* e);
yy(j) = y0 + sum(y .* e);
end
k = convhull(xx, yy);
plot(xx(k), yy(k));
% First generate all possible permutations for [-1, 1] for n terms. This is similar to what you have done but uses a matlab function
all_e = de2bi(0:(2^terms-1), terms).';
all_e(all_e == 0) = -1;
% Multiply corresponding values of x and y with those of e
xx = x0 + arrayfun(#(z) sum(x .* all_e(:, z)), 1:(2^terms));
yy = x0 + arrayfun(#(z) sum(y .* all_e(:, z)), 1:(2^terms));
You can read more about the function de2bi here
A method to find the absolute minimum and maximum bounds is as follows:
max_e = double(x >= 0);
min_e = double(~max_e);
max_e(max_e == 0) = -1;
min_e(min_e == 0) = -1;
absMax = x0 + sum(x .* max_e);
absMin = x0 + sum(x .* min_e);
Similarly you could do for y
I am solving a project in Mathematica 10 and I think that the best way to do it is using a loop like For or Do. After build it I obtain the results I looking for but with a to much big multiplicity. Here is the isolated part of the code:
(*Initializing variables*)
epot[0] = 1; p[0] = 1; \[Psi][0] = HermiteH[0, x] E^(-(x^2/2));
e[n_] := e[n] = epot[n];
(*Defining function*)
\[Psi][n_] := \[Psi][n] = (Sum[p[k]*x^k,{k,0,4*n}]) [Psi][0];
(*Differential equation*)
S = - D[D[\[Psi][n], x], x] + x^2 \[Psi][n] + x^4 \[Psi][n - 1] - Sum[e[n-k]*\[Psi][k],{k,0,n}];
(*Construction of the loop*)
S1 = Collect[E^(x^2/2) S, x, Simplify];
c = Coefficient[S1, x, 0];
sol = Solve[c == 0, epot[n]]; e[n] = epot[n] /. sol;
For[j = 1, j <= 4 n, j++,
c = Coefficient[S1, x, j];
sol = Solve[c == 0, p[j]];
p[j] = p[j] /. sol;];
(*Results*)
Print[Subscript[e, n], "= ", e[n] // InputForm];
Subscript[e, 1]= {{{3/4}}}
Print[ArrayDepth[e[n]]];
3 (*Multiplicity, it should be 1*)
Print[Subscript[\[Psi], n], "= ", \[Psi][n]];
Subscript[\[Psi], 1]= {{E^(-(x^2/2)) (1-(3 x^2)/8-x^4/8)}}
Print[ArrayDepth[\[Psi][n]]];
2 (*Multiplicity, it should be 1*)
After this calculation, the question remaining is how do i substitute this results in the original functions. Thank you very much.
I am trying to solve a system of four equations in four variables. I have read a number of threads on similar issues and tried to follow the suggestions. But I think it is a bit messy because of the logs and cross products here. This is the exact system:
7*w = (7*w+5*x+2*y+z) * ( 0.76 + 0.12*Log[w] -0.08*Log[x] -0.03*Log[y] -0.07*Log[7*w+5*x + 2*y + z]),
5*x = (7*w+5*x+2*y+z) * ( 0.84 - 0.08*Log[w] +0.11*Log[x] -0.02*Log[y] -0.08*Log[7*w+5*x + 2*y + z]),
2*y = (7*w+5*x+2*y+z) * (-0.45 - 0.03*Log[w] -0.02*Log[x] +0.05*Log[y] +0.12*Log[7*w+5*x + 2*y + z]),
1*z = (7*w+5*x+2*y+z) * (-0.16 + 0*Log[w] - 0*Log[x] - 0*Log[y] + 0.03*Log[7*w+5*x + 2*y + z])
(FYI-I am a young economist, and this is an extension of a consumer demand system.) Theoretically, we know that there exists a unique solution to this system that is positive.
Trys
Solve & NSolve : As there should be a solution I tried these but neither works. I guess that the system has too many logs to handle.
FindRoot : I started with an initial value of (14,15,10,100) which I get from my data. FindRoot returns the last value (which does not satisfy my system) and the following message.
FindRoot::lstol: The line search decreased the step size to within tolerance specified by AccuracyGoal and PrecisionGoal but was unable.....
I tried different initial values, including the value returned by FindRoot. I tried to analyze the pattern of the solution value at each step. I didn’t see any pattern but noticed that the z values become negative early in the process. So I put bounds on the values. This just stops the code at the minimum value of 0.1. I also tried an exponential system instead of log, same issues.
Reap[FindRoot[{
7*w==(7*w+5*x + 2*y + z)*(0.76 + 0.12*Log[w] -0.08*Log[x] -0.03*Log[y] -0.07*Log[7*w+5*x + 2*y + z]),
5*x==(7*w+5*x + 2*y + z)*(0.84 -0.08*Log[w] +0.11*Log[x] -0.02*Log[y] -0.08*Log[7*w+5*x + 2*y + z]),
2*y==(7*w+5*x + 2*y + z)*(-0.45 - 0.03*Log[w] -0.02*Log[x] +0.05*Log[y] +0.12*Log[7*w+5*x + 2*y + z]),
z==(7*w+5*x + 2*y + z)*(-0.16 + 0*Log[w] -0*Log[x] -0*Log[y] +0.03*Log[7*w+5*x + 2*y + z])},
{{w,14,0.1,500},{x,15,0.1,500},{y,10,0.1,500},
{z,100,0.1,500}},EvaluationMonitor:>Sow[{w,x,y,z}] ]]
FindMinimum : As we can write this problem as a minimization problem, I tried this (following the suggestion here). The value returned did not converge the system or equations to zero. I tried with only the first two equations, and that sort of converged to zero.
Hope this is engaging enough for the experts here! Any ideas how I should find the solution or why can’t I? It’s the first time I am using Mathematica, and unfortunately the first time I am empirically solving a system/optimizing! Thanks a lot.
{g1,g2,g3, g4}={7*w - (7*w+5*x+2*y+z)* (0.76+0.12*Log[w]-0.08*Log[x]-0.03*Log[y] -0.07*Log[7*w+5*x+2*y+z]),5*x - (7*w+5*x+2*y+z)*(0.84-0.08*Log[w]+0.11*Log[x]-0.02*Log[y] -0.08*Log[7*w+5*x+2*y+z]),2*y - (7*w+5*x+2*y+z)*(-0.45-0.03*Log[w]-0.02*Log[x]+0.05*Log[y]+0.12*Log[7*w+5*x+2*y+z]), 1*z - (7*w+5*x+2*y+z)*(-0.16+0*Log[w]-0*Log[x]-0*Log[y]+0.03*Log[7*w+5*x+2*y+z])};subdomain=0<w<100 &&0<x<100 && 0<y<100 && 0<z<100;res=FindMinimum[{Total[{g1,g2,g3, g4}^2],subdomain},{w,x,y,z},AccuracyGoal->5]{g1,g2,g3,g4}/.res[[2]]
I don't have access to Mathematica, I put your equations into AMPL which is free for students. Here is what I did:
var w := 14 >= 0;
var x := 15 >= 0;
var y := 10 >= 0;
var z := 100 >= 0;
eq1: 7*w = (7*w+5*x+2*y+z) * ( 0.76 + 0.12*log(w) -0.08*log(x) -0.03*log(y) -0.07*log(7*w+5*x + 2*y + z));
eq2: 5*x = (7*w+5*x+2*y+z) * ( 0.84 - 0.08*log(w) +0.11*log(x) -0.02*log(y) -0.08*log(7*w+5*x + 2*y + z));
eq3: 2*y = (7*w+5*x+2*y+z) * (-0.45 - 0.03*log(w) -0.02*log(x) +0.05*log(y) +0.12*log(7*w+5*x + 2*y + z));
eq4: 1*z = (7*w+5*x+2*y+z) * (-0.16 + 0*log(w) - 0*log(x) - 0*log(y) +0.03*log(7*w+5*x + 2*y + z));
option show_stats 1;
option presolve 10;
option solver "/home/ali/ampl/ipopt"; # put your path here
option seed 1731;
# Initial solve
solve;
display w, x, y, z;
# Multistart
for {1..10} {
for {j in 1.._snvars}
let _svar[j] := Uniform(1, 50);
solve;
if (solve_result_num < 200) then {
display w, x, y, z;
}
}
If I only require that the variables are nonnegative, I get rubbish, for example
w = 2.39266e-11
x = 6.62678e-11
y = 1.57043e-24
z = 7.0842e-10
or
w = 1.09972e-12
x = 9.77807e-11
y = 3.36229e-21
z = 1.85441e-09
Numerically, these are indeed solutions, they satisfy the equations to a fairly high precision, although I am pretty sure it's not what you are looking for. This indicates issues with your model.
If I increase the lower bounds of the variables a bit:
var w := 14 >= 0.1;
var x := 15 >= 0.1;
var y := 10 >= 0.1;
var z := 100 >= 0.01;
I get, even with multistart, Ipopt 3.11.6: Converged to a locally infeasible point. Problem may be infeasible. This again indicates issues with your model equations.
I am afraid you will have to revise your model.
This won't fix the issues with your model equations but I would introduce new variables: a=log(w), b=log(x), c=log(y), d=log(z). Then w=exp(a) and so on. It has the advantage that the function evaluations won't fail due to negative arguments for the logarithm function.
I would probably also introduce a new variable for (7*w+5*x+2*y+z) just to make the equations more compact.
Neither of these new variables will solve the above issues with your model equations.
If it is really your first time using Mathematica, you might be better off with AMPL and IPOPT; these tools are custom-tailored for solving equations and optimization problems. I suggest you use the AMPL mailing list if you have question and not Stackoverflow; you will get better answers on the mailing list.
This method will often rapidly find approximate solutions, NMinimize the sum of squares with constraints.
In[2]:= NMinimize[{
(7*w - (7*w + 5*x + 2*y + z)*(0.76 + 0.12*Log[w] - 0.08*Log[x] -
0.03*Log[y] - 0.07*Log[7*w + 5*x + 2*y + z]))^2 +
(5*x - (7*w + 5*x + 2*y + z)*(0.84 - 0.08*Log[w] + 0.11*Log[x] -
0.02*Log[y] - 0.08*Log[7*w + 5*x + 2*y + z]))^2 +
(2*y - (7*w + 5*x + 2*y + z)*(-0.45 - 0.03*Log[w] - 0.02*Log[x] +
0.05*Log[y] + 0.12*Log[7*w + 5*x + 2*y + z]))^2 +
(1*z - (7*w + 5*x + 2*y + z)*(-0.16 + 0*Log[w] +
0.03*Log[7*w + 5*x + 2*y + z]))^2,
w > 0 && x > 0 && y > 0 && z > 0}, {w, x, y, z},
Method -> "RandomSearch"]
Out[2]= {9.34024*10^-12, {w->1.86998*10^-8, x->3.83383*10^-8, y->4.59973*10^-8, z->5.29581*10^-7}}
I have intialconditions:
sf = 200;
sm = 100;
p = 40;
betaf = 0.15;
betam = 0.15;
mums = 0.02;
mufs = 0.02;
sigma = 0.20;
mum = 0.02;
muf = 0.02;
and the ODE:
sf' := -muf*sf + (betaf + mums + sigma)*p - HarmonicMean[sf, sm];
sm' := -mum*sm + (betam + mufs + sigma)*p - HarmonicMean[sf, sm}];
p' := p - (mufs + mums + sigma)*p + HarmonicMean[{sf, sm}];
That i want is an abstract solution (sf(t),sm(t),p(t)) with NDSolve to plot it later.
My problem is that all variables are dependet in all 3 equations, so i don't know how to write the NDSolve call.
I could not manage to get an analytic solution, but the numerical one goes like this. Note that not all symbols you listed are variables of the system: those not being dependent of the independent variable t are parameters. (Also note that there are some typos in the OP's code).
variables = {sf[t], sm[t], p[t]};
parameters = {betaf -> 0.15, betam -> 0.15, mums -> 0.02,
mufs -> 0.02, sigma -> 0.20, mum -> 0.02, muf -> 0.02};
equations = {
sf'[t] == -muf*sf[t] + (betaf + mums + sigma)*p[t] -
HarmonicMean[{sf[t], sm[t]}],
sm'[t] == -mum*sm[t] + (betam + mufs + sigma)*p[t] -
HarmonicMean[{sf[t], sm[t]}],
p'[t] ==
p[t] - (mufs + mums + sigma)*p[t] + HarmonicMean[{sf[t], sm[t]}],
sf[0] == 200,
sm[0] == 100,
p[0] == 40
};
sol = NDSolve[equations /. parameters, variables, {t, 0, 100}];
Plot[Evaluate[variables /. sol], {t, 0, 100}]