Tag Info

New answers tagged

3

An alternative is to recognize that the product of the eigenvalues is equal to the determinant. Hence: m = {{0.04 - 0.4 b, 0, 0.04 - 0.4 b}, {0, -0.08 - 1.2 b, -0.06 - 0.9 b}, {1.04 - 0.4 b, 2.08 - 0.8 b, 0}}; Roots[Det[m] == 0, b] Since the Det is a 3rd order polynomial, there are three zeros, which occur when b == 2.6 || b == 0.1 || b == ...


7

Since Mathematica offers powerful symbolic capabilities I find that more effective solution to the problem uses exact numbers instead of machine precission ones and consequently appropriate symbolic functions. The given matrix m: m = {{0.04 - 0.4 b, 0, 0.04 - 0.4 b}, {0, -0.08 - 1.2 b, -0.06 - 0.9 b}, {1.04 - 0.4 b, 2.08 - 0.8 b, 0}}; we ...


0

In order to make my answer more comprehensible I decoupled the set of equations first: (*1*) H[n+1]==7/10*H[n](17/7-H[n]) (*2*) h[n+1]==7/10*h[n](3/7+h[n]) with the constraints: (h[n]+H[n]==1) && (0<=H[n]<=1) && (0<=h[n]<=1) These can be obtained by using h[n]+H[n]==1. The recurence relations can now be solved independently. ...


2

You could also just program iteratively: f[{x_, y_}] := With[{ch = {1, 0.7 x}.{x, y}}, {ch, 1 - ch}] hdt[p_, n_] := Transpose@NestList[f, {p, 1 - p}, n] If you just want $\{H(n),h(n)\}$ for starting values $\{H(0),h(0)\}=\{p,1-p\}$: hd[p_, n_] := Nest[f, {p, 1 - p}, n]; Visualizing: lp[p_] := ListPlot[hdt[p, 10], Joined -> True, PlotMarkers -> ...


0

You could also do something like: GraphicsRow[ListLinePlot@Transpose@RecurrenceTable[{ H[n + 1] == N@(1 + (7 h[n])/10) H[n], h[n + 1] == N@1 - (1 + (7 h[n])/10) H[n], H[0] == #/100, h[0] == 1/2}, {H[n], h[n]}, {n, 1, 15}] & /@ {179, 180}]


1

v[x_, y_] := a*x^2 + b*x*y + c*x sc1 = ForAll[{x, z}, 0 <= x <= z <= 1, v[z, x] - v[x, x] >= 0] sc2 = ForAll[{x, z}, 1 >= x >= z >= 0, v[z, x] - v[x, x] <= 0] Resolve[(sc1 || sc2), {a, b, c}] (* (a < 0 && ((b <= -2 a && c >= -2 a - b) || (b > -2 a && c >= 0))) || (a >= 0 && ((b < -2 ...


2

I know it doesn't answer your question directly, but with the definition above, your function H[n] asymptotically approaches 1 pretty fast regardless of the starting value H[0]: (* Generates a table for the first 20 values of H given H[0] == alpha *) f[alpha_] := Module[{H}, H[0] = alpha; H[n_] := H[n] = H[n - 1] (1 + .7 (1 - H[n - 1])); Table[H[n], ...


2

Short Answer Clear[Derivative] first. Long Answer OK, it's surprising that there seems to be no regular answer to this common problem for beginners, let me elaborate my comment into an answer. If you restart your Mathematica and run your code again then you'll find your problem no longer exists anymore! Then, why? Because Mathematica is unstable? Of ...


2

It is a minor syntax problem. This: deq2 = DSolve[{T1''[t] == -1.062880475*10^7*T1[t] + 845.813407*T2[t], T2''[t] == 281.937803*T1[t] - 1.135556134*10^6*T2[t] - 1.807293611*10^6*T3[t] + 854.700858*(1 - 555.5555556*t)*Exp[-194.4444444*t], T3''[t] == -1.036565839*10^10*T3[t] - 6.506256977*10^9*T2[t], T1[0] == 0, T1'[0] == 0, T2[0] == 0, T2'[0] == ...


5

Another way is to use Maximize rather than solving for the zero of the derivative. f[x_] = (r ω^2 Sin[x] Cos[x])/(g - ω^2 (Cos[x])^2 r); as = {r > 0, ω > 0, g > 0, r ω^2 < g}; You can see that f[x] // TrigReduce (* -((r ω^2 Sin[2 x])/(-2 g + r ω^2 + r ω^2 Cos[2 x])) *) therefore you can make a simple substitution and, assuming the ...


3

This system of equations is overdetermined: In[27]:= Solve[(10*^3 == 1/(2*Pi*Sqrt[10000*r2*c1*c2])) && (20 == 3*Sqrt[r2*c2]/Sqrt[10000*c1]) && (3 == Sqrt[r2/10000]*Sqrt[c1*c2]/(c1 + c2)), {c1, c2, r2}, Reals] Out[27]= {{c1 -> 3/(4000000000 π), c2 -> 11/(12000000000 π), r2 -> 4000000/11}} Just using the first three ...


4

eqns = {d == (1* c*(f/130))/(1 + (f/130) + (d/50)) - (c*(d/10))/(1 + (f/ 130) + (d/50)) + a/(1 + (a/100) + (d/100) + (f/80)) - d/(1 + (a/100) + (d/100) + (f/80)), a == (c*(d/10))/(1 + (f/130) + (d/50)) - a/(1 + (a/100) + (d/100) + (f/80))}; exprs = Numerator[Together[Subtract @@@ eqns]] (* Out[4]= {-260000 a + 520000 d - ...


2

Combined symbolic and numeric calculation can be hard to deal with. You may do the symbolic part first and then do the substitution, or do the pure numeric integration NItegrate many times. Integrate[(n3 + s^2/(2 r))*(c e n)/(g r^(2/3) (s/lb (end - beg) + beg)^(4/3)), {s, 0, lb}][[1]] Output: (3 c e lb n (beg^( 1/3) (5 beg + 6 beg^(2/3) end^(1/3) + 3 ...


3

You can display zero crossing using MeshFunctions. Here is a clumsy exploitation from created graphic. The half-periods (difference between consecutive points) are displayed below with mean in red. x1plot = ListPlot[x1data, AxesLabel -> {"t", "x1"}, Joined -> True, MeshFunctions -> (#2 &), Mesh -> {{0.}}, MeshStyle -> {Red, ...


1

One way to demonstrate is to 'take care of' of the square root: Rewriting: eqn = (1 - b)/Sqrt[1 - 2 b]; sol = Solve[eqn == a, b]; Now, FullSimplify[Sqrt[eqn^2 /. sol], a > 0] yields: {a, a}


0

Modifying only these definitions in your code to read: Subscript[K, 1] := Interval[{0, 32}]; Subscript[K, 2] := Interval[{0, 8}]; Produces this result: {Subscript[u, 0] -> Interval[{-0.09, 4.29}], Subscript[u, 1] -> Interval[{-0.0355556, 3.23556}], Subscript[u, 2] -> Interval[{-0.186667, 1.98667}], Subscript[u, 4] -> ...


5

Ok, here is my take on it. Your equation appears to be a stiff one, given your initial condition in s. General First observation is that you can integrate your equation exactly. To do this, make a substitution: $\phi(s) = s'(t)$ Then, you have $s''(t) = \frac{\partial}{\partial{t}}\phi(s) = \frac{\partial\phi}{\partial{s}} \frac{\partial ...


3

You could avoid the problem altogether by using ContourPlot: ContourPlot[V[x, 0, z0] == E0, {x, -2, 2}, {z0, 0, 0.6}]


2

Here is a 'cheat': p1 = Plot3D[V[x, 0, z], {x, -1.01, 1.01}, {z, 0, 0.6}, MeshFunctions -> (#3 &), Mesh -> {{E0}}, MeshStyle -> {Red, Thick}, PlotPoints -> 100] You can then extract the desired mesh points from the object: lns = Cases[p1, Line[x_] :> x, Infinity]; gr = Graphics[{Red, Thick, Line[(p1[[1, ...


2

Using a finer grid in the loop (e.g. 0.0001) helps to reduce the gap in the middle. If we do not join the data points and give different colors to your neg and pos lists, we see that something strange happens for small $z_0$: Your equation has 4 solutions (two negative, two positive), so just using the first or the second argument wont pick the smallest or ...


2

Alternate answer, this is an exact analytic approach to the nearest point problem: (not i think precisely what @martin was after, but its an interesting problem and others may find it useful) lb = -1;ub = 1; pts0 = Select[Flatten[ Table[ {i, j}, {i, 2 lb, 2 ub , .2}, {j, 2 lb , 2 ub , .2}], 1] ,Norm[#] < 1 &]; intv[ p_, pn_] := If[(pn[[1]] != ...


0

I had the same issue and using NSolve didn't work. I got similar message: NSolve::ratnz: NSolve was unable to solve the system with inexact coefficients. The answer was obtained by solving a corresponding exact system and numericizing the result. I found a solution here: Error/warning when using NSolve for simple equation It proposes using Rationalize


2

Mathematica can handle it. Use reduce for non-linear / non-polynomial Your equations: eqs = -(0.35 - b)/sigma == 9.8602 && A*Exp[-(0.35 - b)^2/(2*sigma)] == 0.150099 && A*Exp[-(0.55 - b)^2/(2*sigma)] == 0.895049; Your solutions: Reduce[eqs, {A, b, sigma}, Reals] // Quiet A == 27.5999 && b == 1.40764 && sigma ...


1

This is not an answer to your question but a copy and paste from the documentation which you might find inspiring: Boundary Value Problems with Parameters In many of the applications where boundary value problems arise, there may be undetermined parameters, such as eigenvalues, in the problem itself that may be a part of the desired solution. By ...


2

Here is a way of finding the general solution of your equations: Define the expressions expr1 = (2 + 12*s)/(9*x^2) + (4*Sqrt[2*s])/(9*x^2*y) - (4*Sqrt[2*s])/(9*x^3) - k; expr2 = (1 + 3*Sqrt[2*s] - 6*s)/(9*y^2) + (2*Sqrt[2*s])/(9*y^2*x) - (2*Sqrt[2*s])/(9*y^3) - k; Solve for y in terms of x. ysol = Solve[expr1 == 0, y] (* {{y -> (4 Sqrt[2] Sqrt[s] ...


4

Here you are with the bands -- note also an (I think) improvement over the brute force fine discretization of the line: (I'm Not sure if that improved performance, but it didn't hurt and it looks cleaner) caveat I think my little trick thinning down the lndat list is not guaranteed to find all of the strictly nearest points. It seems to work for the ...


0

I'll write down what I've found after experimenting a little more with the code, in the hope that someone wants to take a look. The original code was a little different from the one I posted in the question (my fault, I really didn't imagine the problem would be in the part I left out... Well, lesson learned). The potential was written in this way ...


10

So you guys know - quasicrystals are cool structures that can consist of finite number of parts which can be arranged in never repeating - aperiodic - pattern. Thing here is called projection method from a regular lattice. http://www.nature.com/nmat/journal/v3/n11/fig_tab/nmat1244_F3.html Interestingly if you know Fibonacci rabbits problem - that is also ...


1

Not a perfect solution, but you could try Expand and Collect. Example: lhs = a x E^(x - a) + Exp[x] (x - 1)^2 + 5/Exp[-x]; Collect[Expand[lhs], {x^2*Exp[x], x*Exp[x], Exp[x]}] output 6 E^x + E^x (-2 + a E^-a) x + E^x x^2 note: the order of the second argument of Collect different input style of E^ and Exp[] doesn't matter here, but sometimes exact ...


0

Frame it as a set of Linear ODEs and solve it somehow. I usually use Implicit Runge Kutta in the interaction picture. solver[H_, a_] := soln = Module[{d, init, eq, vars, solargs, t, t0, tf}, d = Dimensions[H][[1]]; t0 = a[[2]]; tf = a[[3]]; t = a[[1]]; u[t_] := Table[Subscript[u, i, j][t], {i, 1, d}, {j, 1, d}]; init = (u[t0] == IdentityMatrix[d]); eq = ...


5

I Let's write down an appropriate system we would like to solve, i.e. we are to maximize a^3 + b^3 + c^3 knowing that a + b + c == 5 and 1/a + 1/b + 1/c == 1/5, thus the most direct approach uses Maximize with adequate conditions: Maximize[{a^3 + b^3 + c^3, a + b + c == 5, 1/a + 1/b + 1/c == 1/5}, {a, b, c}] {125, {a -> 1, b -> 5, c -> -1}} ...


6

Overdetermined systems of differential equations can have any solutions only if they satisfy certain compatibility conditions, therefore in general one shouldn't expect that any solutions necessarily exist. For differential equations of the first order one can impose initial conditions in the form of values of unknown functions (at certain points for ODEs) ...


3

I did not see there is an easy way to do it within DSolve. But for ODEs which could be integrated directly, using Integrate would be a possible choice to get the implicit solution. For the problem mentioned, it could be integrated directly by Integrate[ Integrate[ (1 + G (A + y[x])^3) y''[x] + 3G (A + y[x])^2 (y'[x])^2 + R, x] - C[1], x] - C[2] == 0 ...


6

You can do this without a NDSolve by calculating the distance from the follower cranks joint to the end of the driving cranks end. Then use this distance with law of cosines to calculate the deviation angle. This is also pretty easy to implement on ANY hardware capable of doing a ArcCos and Atan2 operation (note that in c atan2 parameters are swapped). ...


1

Try this: NSolve[x + # == 0, x] & /@ {1, 2, 3, 4} x /. % Flatten[%] {{{x -> -1.}}, {{x -> -2.}}, {{x -> -3.}}, {{x -> -4.}}} {{-1.}, {-2.}, {-3.}, {-4.}} {-1., -2., -3., -4.}


1

Using replacement rules in the following fashion: NSolve[x + parameter == 0, x] /. parameter -> {1, 2, 3, 4, 5} gives you: {{x -> {-1, -2, -3, -4, -5}}}


3

You can reformulate this as a objective function minimisation problem, where you minimise the sum of the squares of the left hand sides of your equations. Here is how to do this with NMinimize, trying all of the optimisation methods that are mentioned in the documentation: {#, NMinimize[(a^10 E^-a - b^10 E^-b)^2 + ((362880. + a (362880. + ...


1

tl;dr There is another solution besides @StephenLuttrell's: $(10,10)$. Well, to be more exact, $(10,9.99997819382)$. Walkthrough This answer has been updated in light of some glaring errors in my original post—namely in taking the sum of the logs of the squares instead of the log of the sum of the squares, and also in suggesting that zeroes would only ...


1

You can store the pair as follows (in this case in a and b). {a, b} = {x, y} /. First@Solve[{2 x + 2 == y, 3 x + 9 == y}, {x, y}] You can relable as you see fit. Similarly, you can just substitute in an expression, e.g. x^2 + y^2 /. First@Solve[{2 x + 2 == y, 3 x + 9 == y}, {x, y}] yields 193. Note in this case there is a unique solution so First ...


0

A variation: solveMissing[eqn_, vars_] := Solve[ Append[Equal @@@ Cases[vars, {_Symbol, _}], eqn], Replace[vars, {x_Symbol, _} :> x, 1]] Examples: solveMissing[area == length*width, {area, {length, 2}, {width, 4}}] solveMissing[area == length*width, {{area, 8}, length, {width, 4}}] (* {{area -> 8, length -> 2, width -> 4}} {{area ...


2

rectangle[{r1_Rule, r2_Rule}] := (#~Join~First@Solve[ (e1 e2 == area) /. # , First@Complement[ {area, e1, e2}, First /@ #] ]) &@{r1, r2} rectangle[{e2 -> 3, e1 -> 2}] {e2 -> 3, e1 -> 2, area -> 6} rectangle[{area -> 12, e1 -> 2}] {area -> 12, e1 -> 2, e2 -> 6}


0

It is very compute extreme-value problem in analysis.For example Minimize[a x^2 + b x + c, x] This this simple than your cases.It just have one extreme point If a!=0. But in your case, consider 0 <= b < 2 Pi, 0 <= a <2 Pi(the period of a and b is 2Pi, so we don't need consider boundary.Also we don't consider g). Clear["Global`*"] t0[vx_, ...


1

{eq1, eq2, eq3, eq4} = {a*Log[b + d] == 20, a*Log[b*30^c + d] == 125, a*Log[b*180^c + d] == 710, a*Log[b*360^c + d] == 1350}; and FindRoot[{eq1, eq2, eq3, eq4}, {{a, 0.1}, {b, 0.1}, {c, 0.01}, {d, 0.01}}] (* {a -> 1.43923, b -> 3115.74, c -> -1.15142, d -> 19.1192} *) ?


0

See also the solution using RootsInRange. This solution is more general as it will work when either the exact intersections are not known, or NSolve fails.


3

There are no solutions as shown by Solve: {eq1, eq2, eq3, eq4} = { a*Log[b + d] == 20, a*Log[b*30^c + d] == 125, a*Log[b*180^c + d] == 710, a*Log[b*360^c + d] == 1350 }; Solve[{eq1, eq2, eq3, eq4}, {a, b, c, d}] (* {} *) To show why there are no solutions over the reals, let's investigate a little further. First let's define our own Solve ...


3

Numerical approach according to Jens' comment : pde = D[u[x, t], t] - 0.2 D[u[x, t], {x, 2}] == 0; g[x_] := 1/(1 + x^2)^0.25; sol = NDSolve[{pde, u[x, 0] == g[x], u[-10, t] == u[10, t] == g[10]}, u[x, t], {x, -10, 10}, {t, 0, 20}] Plot3D[u[x, t] /. sol, {x, -10, 10}, {t, 0, 20}, AxesLabel -> {Style["x", Italic, Red, 20], ...


2

If you use: SB[n_?NumericQ, r_?NumericQ] in your definition things work as you expect. Otherwise, SB is evaluated symbolically and that will take forever...


0

Clear["Global`*"] k = 6.; SB[n_, r_] := Sum[Binomial[r Binomial[2 k, 2]/2, i] Binomial[ Binomial[n, 2] - r Binomial[2 k, 2]/2, r Binomial[k, 2] + r - i], {i, r Binomial[k, 2] + r/2, r Binomial[k, 2] + r}] SB[# k, #] & /@ Range[100] // Timing ListLogPlot[%[[2]]] way 2 Clear["Global`*"] sum[r_] := Sum[(Gamma[1 + 33 r] Gamma[1 - 36 r + 18 r^2])/( ...


0

Forget about using Solve for Economics problems. Use Reduce instead or FindInstance if you want exact answers (but works only with small systems, see below) http://www.mathematica-journal.com/2014/03/using-reduce-to-compute-nash-equilibria/ The above article in the Mathematica Journal has an example from consumer theory (2 goods ). To solve larger demand ...


1

Adding FullSimplify might clarify things for you: Assuming[Re[x] >= 0 && a ∈ Reals, Reduce[1/((x Tanh[π x])/(x^2 + a^2)) == 0, x, Complexes]] // FullSimplify results in: (C[1] ∈ Integers && x != 0 && (x == -(I/2) + 2 I C[1] || x == I/2 + 2 I C[1])) || (Sin[a π] != 0 && (x == -I a || x == I a)) This ...



Top 50 recent answers are included