Tag Info

New answers tagged

2

This works much faster: f[P_?NumericQ] := x /. FindMinimum[(0.5*x^2 + Cos[y + P] - 1)^2, {x, y}][[2]] Plot[f[P], {P, 0, 100}] It is possible to run it even faster if you will use a successive plotting algorithm (not the algorithm Plot uses) and provide optimal starting values for FindMinimum on each new step on the base on the optimal values found ...


1

I thought it interesting to ask where the roots determined by Bob Hanlon and Michael E2 lie in the complex plane. pts = Flatten[N[roots, 15] /. Rule[_, z_] -> ReIm[z], 1]; pts2 = Flatten[N[roots2, 15] /. Rule[_, z_] -> ReIm[z], 1]; As noted in their answers, the numbers of roots are 883 and 1251. One might suppose that the first list is a subset of ...


1

In V10, Solve works, too, and gives 1251 solutions. roots2 = Solve[eqns, z]; // AbsoluteTiming Length@roots2 Solve::incs: Warning: Solve was unable to prove that the solution set found is complete. >> (* {99.1951, Null} 1251 *) Maybe there are more, too. The timing is almost 6 times as long as BobHanlon's NSolve command on my computer. But ...


4

NSolve with adequate precision works well $Version (* "10.2.0 for Mac OS X x86 (64-bit) (July 7, 2015)" *) eqns = Sin[z + Sin[z + Sin[z]]] == Cos[z + Cos[z + Cos[z]]] && -3 < Re[z] < 3 && -3 < Im[z] < 3; roots = NSolve[eqns, z, WorkingPrecision -> 20]; And @@ (eqns /. roots) (* True *) Note that there are a large ...


4

Because the question seeks an expression for the modulus of p, it makes sense to express p and q in terms of the moduli and phases. sim = Simplify[(Abs[-((4 p)/(-1 + Sqrt[1 + 4 p + 4 q])^2)] + Abs[-((4 q)/(-1 + Sqrt[1 + 4 p + 4 q])^2)]) /. {p -> pm Exp[I pp], q -> qm Exp[I qp]}, pm >= 0 && qm >= 0 && ...


5

Define for convenience, eqs = {n ((α β)/(1 - α) + β) == α k^(α - 1) r^γ + ((α γ + (1 - α) (γ - 1))/(1 - α)) r, n (β/(1 - α) - 1) == (α k^(α - 1) r^(γ) - ρ)/σ, (β/(1 - α)) n - ((γ r)/(1 - α)) == (α k^(α - 1) r^(γ))/α - c/k, n (1/(ϕ (1 - σ)) + (β k^(α) r^(γ))/(ϕ c) + 1) + c^(1 - σ) n^(ϕ (1 - σ)) == ρ} Then, as stated in the question, ...


0

Let's see what are the regions of interest: n = 4; Partition[ RegionPlot[#[[2]][#[[1]][Sqrt[e + x^2 + Sqrt[(x^2) (2*e + x^2)]]], 0], {x, -n, n}, {e, -n, n}, PlotLabel -> #, AxesLabel -> Automatic, LabelStyle -> Medium] & /@ Tuples@{{Re, Im}, {Less, Greater}}, 2] ...


1

The first thing I did was to rationalizing all calculations, starting with the defintion of σ and minroot. This stops the Solve::ratnz messages. I also made some other improvements to minroot. σ = 6/10; minroot[gg_?NumericQ, bb_?NumericQ] := Module[{b, g, rts, r}, b = Rationalize[bb, 0]; g = Rationalize[gg, 0]; rts = r /. Solve[ ...


5

Increase WorkingPrecision: NSolve[PDF[BinomialDistribution[80, p], 0] == 0.95`200 && 0 < p < 1, p, Reals, WorkingPrecision -> 50] PDF[BinomialDistribution[80, p], 0] /. % (* {{p -> 0.00064096067673218860969986162632491931947341012861}} {0.9500000000000000000000000000000000000000000000000} *)


6

To get the polynomial, the easiest way is res = M /. Rationalize@Solve[a == 0, M]; poly = res[[1, 1]][M] 900 + 14400 M^5 + M^4 (50400 - 8944 z) - 1909 z + M^3 (65700 - 27760 z - 14612 z^2) + M (9900 - 13690 z + 98 z^2) + M^2 (38700 - 30597 z - 14514 z^2 + 147 z^3) Now I don't know what Solve does, but I did the following. Take the numerator ...


0

Not efficient, just showing that Mathemtica can do it from "first principles" Reduce[a + b + c == 91 && And @@ Thread[0 <= {a, b, c} <= 51] && Exists[Element[{aa, bb, cc}, Integers], 2 aa + 1 == a && 2 bb + 1 == b && ...


3

Okay, sometimes you get so involved in an idea that you don't realize how foolish it is. I was fooled or seduced by the simplicity of the Chebyshev expansion. Basically, my original answer was a complicated way to do this: cosEq = 64 x^7 - 112 x^5 - 8 x^4 + 56 x^3 + 8 x^2 - 7 x - 1 /. x -> Cos[Pi t] //TrigToExp; t /. Solve[cosEq == 0 && 0 <= ...


4

Edited to simplify the derivation and reduce the length of the final result. If R21 and R32 are pure imaginary, then the equation is solved easily. R21 /. Solve[eqns /. {Im[R21] -> -I R21, Im[R32] -> -I R32}, term][[1]] (* (I p (2 b q^2 x + 2 b q^2 y - 4 b c x y - p^2 x y - 4 b c x z - p^2 x z))/(6 b p^2 q^2 - 4 a b q^2 x - p^2 q^2 x - q^4 x - ...


1

After a slight rearrangement, your equation is a good candidate for the Chebyshev approach, as detailed here and here: r = Sqrt[18]; f = Sqrt[r^2 - #^2] Cos[#] - # Sin[#] &; n = 32; cnodes = Rescale[N[Cos[Pi Range[0, n]/n], 20], {-1, 1}, {-r, r}]; cc = Sqrt[2/n] FourierDCT[f /@ cnodes, 1]; cc[[{1, -1}]] /= 2; colleague = SparseArray[{{i_, j_} /; i + 1 ...


0

If you only want real solutions, then NSolve will find them if we help it by including the domain for zeta. R = Sqrt[18]; sol = NSolve[Sqrt[R^2 - zeta^2] - zeta Tan[zeta] == 0 && -R <= zeta <= R] (* {{zeta -> -3.66808}, {zeta -> -1.26743}, {zeta -> 1.26743}, {zeta -> 3.66808}} *) You can save them in an indexed list like ...


5

parametres = {\[Sigma] -> 1.5, \[Alpha] -> 0.3, \[Beta] -> 0.6, \[Rho] -> 0.02, \[Delta] -> 0.05, \[Phi] -> 0.8} // Rationalize; Your third equation contains (\[Beta]y^\[Alpha]) there needs to be a space as in (\[Beta] y^\[Alpha]) eqns = {((\[Alpha] y - \[Rho]) (\[Alpha] - 1))/(\[Sigma] (\[Alpha] - \[Beta] - 1)) == ...


3

I guess the FindInstance function does the job: FindInstance[{((α y - ρ) (α - 1))/(σ (α - β - 1)) == x , (β x)/(α - 1) + y^(α - 1) == z , x ((β (1 - σ))/(1 - α) + (β y^α)/(ϕ z)) == ρ} /. parametres, {x, y, z}, Reals] {{x -> 0.082946, y -> 0.836879, z -> 1.06166}}


15

One approach I've started to become fond of, apart from Plot[]-based approaches, involves the Chebyshev expansion of a function, followed by the construction of the corresponding "colleague matrix" (a matrix whose characteristic polynomial is the Chebyshev series previously determined), and then the computation of the colleague matrix's eigenvalues, which ...


0

The analogous 1D problem, NDSolveValue[{D[u[x], x] == -u[x], D[v[x], x] == -v[x], u[0] == 1, v[1] == u[1]}, {u, v}, {x, 0, 2}] integrates across x == 1 without difficult. Therefore, I expected that NDSolveValue[{D[u[x, t], t] + D[u[x, t], x] == -u[x, t], D[v[x, t], t] + D[v[x, t], x] == -v[x, t], u[x, 0] == E^-x, v[x, 0] == E^(1 - x), ...


3

Posting this so the question doesn't remain unanswered. Here Michael Trott & Victor Adamchik) posted all the necessary material to solve a quintic in Mathematica. I'm not copying the whole thing because (perhaps) copyrights issues may arise. You need to use two notebooks: First this one to perform three transformations and reduce the general equation ...


2

c[n_?IntegerQ] := Array[cVal, 2 n + 2, 0] (* Unknowns *) y[n_?NumericQ, x1_] := c[n].x^Range[0, 2 n + 1] /. x -> x1 (*function value*) dy[n_?NumericQ, x1_] := D[y[n, x], x] /. x -> x1 (*derivative*) (*Now the solving function*) res[n_, pts_, vals_] := Solve[Flatten@ MapThread[{y[n, #1] == ...


2

The error message is very descriptive: you haven't specified a boundary condition, but a condition on the middle of the region. If you amend the {x, 0, 2} to {x, 0, 1} it works correctly (but points out that your conditions are inconsistent, which they are). You should be able to impose conditions on the inside of the region by splitting the region in two, ...


6

Restrict the domain to Reals $Version "10.2.0 for Mac OS X x86 (64-bit) (July 7, 2015)" eqn = 1/Sqrt[x] == x + 1/(Sqrt[2] + Sqrt[3]); sol = Reduce[eqn, x, Reals] // ToRules {x -> Root[1 - 10*#1^2 - 4*#1^3 + #1^4 + 20*#1^5 + 6*#1^6 - 10*#1^8 - 4*#1^9 + #1^12 & , 4]^2} eqn /. sol // FullSimplify ...


4

The reason is exactly as stated: you've given it some inequalities rather than equations. The appropriate syntax is: FindRoot[ { 0.8*p*((y^0.2)/(x^0.2)) + x ((x - 2))/((x - 1)^2) == 0, 0.2*p*((x^0.8)/(y^0.8)) + y ((y - 2))/((y - 1)^2) == 0, 0.8*p*((y1^0.2)/(x1^0.2)) + x1 ((x1 - 4))/((x1 - 2)^2) == 0, 0.2*p*((x1^0.8)/(y1^0.8)) + y1 ((y1 - ...


17

First, it might be worth pointing out that in recent versions of Mathematica, Solve and NSolve are quite strong at solving equations with standard special functions. With[{f = BesselJ[1, #^(3/2)] Sin[#] &}, solvesol = x /. Solve[{f[x] == 0, 25 <= x <= 35}, x]; Plot[f[x], {x, 25, 35}, MeshFunctions -> {# &}, Mesh -> {solvesol}, ...


12

The first approach is to evaluate the function at equidistant points, and look for sign changes. The distance between two sampled points, dx, is an input to the function. When a sign change happens, use FindRoot, which is constrained to look for the root only between the two points that encompass the sign change. The function accepts all the Options that ...


2

The Shooting Method is not strictly necessary here. In addition to MicheaelE2's solution: t0 = 2; M = 8; f[t_] := t^2 - M/t; Solution = NDSolve[ {x''[t]+(f'[t]/f[t]+2/t) x'[t]+(y[t]^2/f[t]^2+2/f[t])x[t] == 0, y''[t] + 2/t y'[t] - 2 x[t]^2/f[t] y[t] == 0, x[t0 + .01] == -3/2 t0 x'[t0 + .01], y[t0 + .01] == 0, y[100000 + .01] == 10, ...


4

This system can be solved exactly with DSolve $Version "10.2.0 for Mac OS X x86 (64-bit) (July 7, 2015)" ClearAll["Global`*"] i = 4; R2 = 0.001 // Rationalize; RL = 100000; RS = 100000000; R1 = 0.04834 // Rationalize; C1 = 8.48 // Rationalize; C2 = 3.44 // Rationalize; s = DSolve[{V1[t] == RS/(RS + R1)*V2[t] + RS*R1*i/(RS + R1), V2'[t] == ...


4

Basically, there are syntax errors. Fix those and it seems to work. In particular, read the tutorial/DefiningFunctions carefully. Also, all the equations of your differential equation problem should be enclosed in {}. Finally, you have a r0 which I interpreted to be a typo and read it as t0. ClearAll[f]; f[t_] := (t^2) - (M/t); (* <-- N.B. the ...


2

What you want to do can be accomplished pretty simply by rewriting your expression as a function. eqn[p_] := Sqrt[0.04 + u + u^2] == 2.0 + 3.0 p uPts = Table[Flatten[{p, NSolve[eqn[p], u][[All, 1, 2]]}], {p, 0, 99}]; u1 = Interpolation[uPts[[All, {1, 2}]]]; u2 = Interpolation[uPts[[All, {1, 3}]]] Plot @@ {Through[{u1, u2}[t]], Flatten[{t, u1["Domain"]}], ...


6

Finding zeroes of the function Apply[ArcTan, o1[t] - o[t]] - Apply[ArcTan, o2[t] - o[t]] does not work well, because ArcTan changes discontinuously from -Pi to Pi, creating numerous spurious roots. For instance, with {a1 = 2, a2 = 13/10, a3 = 16/10, b1 = 3, b2 = 21/10, b3 = 26/10}; Plot[Apply[ArcTan, o1[t] - o[t]] - Apply[ArcTan, o2[t] - o[t]], {t, 0, ...


0

If " i " represents the imaginary unit then: eq = (Cos[θ] - Cos[θ I]) + (θ - θ I)* Sin[θ I] == 0; sol = FindRoot[eq, {θ, 5 + 5 I}] $\{\theta \to 2.68471\, +4.77788 i\}$ These equation has infinite solutions: sol2 = Chop@ Table[FindRoot[eq, {θ, n + m I}, WorkingPrecision -> 20], {n, -10, 10}, {m, -10, 10}] // Column


4

This =Solve[64((x-Sqrt[x^2-1])/(x+1))^2-25(1-Sqrt[x-1]/(x+1))^2+9==0, x] and this WolframAlpha["Solve[64((x-Sqrt[x^2-1])/(x+1))^2-25(1-Sqrt[x-1]/(x+1))^2+9==0,x]"‌​] solve immediately. Note: One reason for using WolframAlpha to handle some calculations is that you can sometimes see the steps involved, see additional information, make use of curated ...


3

You can plot your equation as a function of θ for a given θi. You can also find the roots. In the expressions below I have replaced the symbol θ with x as I was unable to paste it without it showing up as [Theta]. Below Manipulate is used to select the value of xi that will be plotted. There are also Manipulate parameters for setting the starting value for ...


0

I think you are looking for the function With. From the documentation: With[{x=x0, y=y0, ...}, expr} specifies that in expr all occurrences of x, y, ... should be replace by x0, y0, ... In your example you would write something like: With[ { b = ((100 x*(1.5 - y)*28.97)/(8.31*288*1000)) - ..., c = y, d = ((100 x*(1.5 - ...


8

A plot of the equation, which is a form of a numerical solution, is highly suggestive that this is not a "random" equation and might have some structure: eqn = (Cos[θ] - Cos[θi]) + (θ - θi) Sin[θi] == 0; cplot = ContourPlot[Evaluate@eqn, {θ, -20, 20}, {θi, -20, 20}, FrameLabel -> Automatic, GridLines -> {Range[Pi/2 - 7 Pi, 7 Pi, Pi], Range[Pi/2 - ...


0

You can use the finite element method with the method of lines as @toadatrix suggested, but for the FEM method to work, you need to do a little more. The Neumann boundary conditions need to be specified using NeumannValue. h[x_] := x*(30 - x)/900; op = D[u[t, x], t] - D[u[t, x], x, x]; begin = 0; end = 30; bc = {u[0, x] == 100*h[x]}; neumann = ...


2

Polynomials + trig generally don't mix. See this blog post on transcendental equations. Your best bet would be to solve over the Reals and pick a numerical value for θi. With[{θi = π/4}, Solve[(Cos[θ] - Cos[θi]) + (θ - θi)Sin[θi] == 0, θ, Reals] ] {{θ -> π/4}, {θ -> π/4}, {θ -> Root[{4 Sqrt[2] + Sqrt[2] π - 8 Cos[#1] - 4 Sqrt[2] #1 &, ...


2

On v10.0.0, In[1]:= FindInstance[(c3 != 0 || c2 != 0) && c1 == 0 && -c2 == 0, {c1, c2, c3}] Out[1]= {{c1 -> 0, c2 -> 0, c3 -> 1}}


3

Never use Subscript when debugging Mathematica code, because it is difficult to read. The code can be rewritten for clarity as, coupledlorenz = NDSolve[{ x1'[t] == 10*(x1[t] - x2[t]), x2'[t] == 40 x1[t] - x2[t] - x1[t] x3[t], x3'[t] == x1[t] x2[t] - (8/3) x3[t], y1'[t] == 10 (y2[t] - y1[t]) + 0.1 (x1[t] - y1[t]), y2'[t] == 35 y1[t] - y2[t] - ...


2

Here you have a way without using neither UnitStep nor PieceWise that improves the performance by 75% wrt your code. It computes 200 functions in a very reasonable time for your toy example. The main trick is to use a numeric (black box) function to be able to take Part[... ] inside it. n = 200; af = Array[f, n]; taf[t_] := Through[af[t]] bb[i_?IntegerQ, ...


6

You may solve the first form quicker by using a two step process (something like a change of variable) Solve[# == (-1 + x)^-x && x > 1, x, Reals] & /@ y /. Solve[(1 - y)^8 == 95/100, Reals]) You may also "automate" the process somewhat: newVarRule = (-1 + x)^-x -> y; eq = (1 - (-1 + x)^-x)^8 == 95/100; Solve[newVarRule[[1]] == #, x, ...


1

Second update -- I should state in simplest terms the issue the OP is facing. The set-up. The equations for a given a are eqs = Table[Power[Sqrt[λ2/(μ2 c2)], n] p[0, n + 1] == β[n] p[0, 0] + Sum[α[n, k] p[0, k], {k, 0, a}] /. NumVal, {n, 0, a - 1}]; All the variables involved in eqs are given by vars = Table[p[0, n], {n, 0, a}]; (* starts ...


4

I don't know what the "simplest" example would be, but here is one: f[z_] := Root[z + 2 #1 + #^3 - #1^4 &, 1] Plot3D[Im[f[x + I y]], {x, -2, 2}, {y, -2, 2}, PlotPoints -> 100, AxesLabel -> {"Re[z]", "Im[z]", "Im[f[z]]"}] Here you see two regions near the origin that are bounded by discontinuities of the imaginary part (branch cuts). In ...


1

I also think this is a bug, but at least there is a way out: realQ[x_] := Im@x == 0 && (Re@x >= 0 || Re@x < 0) (*or just Im@x == 0 if you aren't suspicious *) {Reduce[Exists[x, x^3 == 1, Not[realQ@x]]], Reduce[ForAll[x, x^3 == 1, realQ@x]], Reduce[ForAll[x, x == 1, realQ@x]]} (* {True, ...


6

As @Guess who it is. states in the comments, an overdetermined linear problem can be solved using Mathematica's LeastSquares[] functionality. To input your above system of equations: a = {{1, -2, 2, 2, 0, -2}, {1, -2, 2, -2, 0, 2}, {1, -2, -2, -2, -4, -2}, {1, 2, 2, -2, -4, -2}, {1, 2, -2, -2, 0, 2}, {1, 2, -2, 2, 0, -2}, {1, -2, -2, 2, 4, ...


5

We will go by solving one equation at a time and generating the corresponding replacement rules. Beware of possible numerical instabilities. The following is the equivalence between the code in your edited example and my code on the previous incarnation of this answer. I think this is enough for you to use it. Please note that the only claim on the ...


3

I used something like the following in Plotting implicitly-defined space curves. Clear[findPoint, pseudonewton]; pseudonewton[f_List, vars_] := pseudonewton[f, D[f, {vars}]]; pseudonewton[f_List, df_?MatrixQ, vars_] := With[{df0 = df /. Thread[vars -> #], f0 = f /. Thread[vars -> #]}, # - PseudoInverse[df0].f0] &; findPoint[eqs_List, ...


0

Not hard. vars = Table[a[i], {i, 1, nParticles}]; FindInstance[soln, vars] (* {{a[1] -> 0, a[2] -> 0, a[3] -> -Sqrt[2], a[4] -> Sqrt[2]}} *)


1

Revision to accommodate multiple random processes One approach is to define e[t] in the question as e*\[DifferentialD]w[t], with e a scale factor. Then, ItoProcess yields proc = ItoProcess[{\[DifferentialD]y[t] == c*y[t]*\[DifferentialD]t + σ*y[t] *\[DifferentialD]w1[t] + e*\[DifferentialD]w2[t]}, y[t], {y, y0}, t, {w1 \[Distributed] ...



Top 50 recent answers are included