Mathematica - sorting list of roots af a transcendental function

Author

sorting list of roots af a transcendental function

Dule

2006-03-22, 8:12 am

Dear group,

for calculating a model i need values for x which are given by the
transcendental function Cot[x] == x/a - a/(4*x). a is a parameter 0<a<200.
i obtained the roots with Table and FindRoot:
Table[FindRoot[Cot[x] == x/a - a/(4*x), {x, i}], {i, 1, 50}]]

I have two questions:
1. Is there a better way to do this?
2. How can i construct a list, where the values for x, which appear
multiple are dropped?

Thanks!

Roger Bagula

2006-03-23, 7:10 pm

This expant CoTangent as a polynomial to 50 powers:
Normal[Series[Cot[x], {x, 0, 50}]]
This converts them to normal input form and will give numerical solutions:
Table[x /. NSolve[Normal[Series[Cot[
x], {x, 0, 50}]] - ( x/a - a/(4*x)) == 0, x][[i]], {i, 1, 50}]
Unless you want to wait forever for your solutions I'd use 10 or 20
places which is usually enough for transcental functions as series.
To drop the extra solutions that are the same use Union:
Union[Table[x /. NSolve[Normal[Series[Cot[
x], {x, 0, 10}]] - ( x/a - a/(4*x)) == 0, x][[i]], {i, 1, 10}]]
Dule wrote:
> Dear group,
>
> for calculating a model i need values for x which are given by the
> transcendental function Cot[x] == x/a - a/(4*x). a is a parameter 0<a<200.
> i obtained the roots with Table and FindRoot:
> Table[FindRoot[Cot[x] == x/a - a/(4*x), {x, i}], {i, 1, 50}]]
>
> I have two questions:
> 1. Is there a better way to do this?
> 2. How can i construct a list, where the values for x, which appear
> multiple are dropped?
>
> Thanks!
>

Roger Bagula

2006-03-23, 7:10 pm

Pratik Desai

2006-03-23, 7:10 pm

Bill Rowe

2006-03-23, 7:10 pm

On 3/22/06 at 6:13 AM, dule23@gmx.de (Dule) wrote:

>for calculating a model i need values for x which are given by the
>transcendental function Cot[x] == x/a - a/(4*x). a is a parameter
>0<a<200. i obtained the roots with Table and FindRoot:
>Table[FindRoot[Cot[x] == x/a - a/(4*x), {x, i}], {i, 1, 50}]]

>I have two questions:
>1. Is there a better way to do this?

Table seems fine. Another way would be

FindRoot[Cot[x] == x/a -a/(4 x), {x, #}]&/@Range[50]

>2. How can i construct a list, where the values for x, which appear
>multiple are dropped?

Use Union, i.e.

Union[FindRoot[Cot[x] == x/a -a/(4 x), {x, #}]&/@Range[50]]
--
To reply via email subtract one hundred and four

Paul Abbott

2006-03-23, 7:10 pm

In article <dvrcdq$a6i$1@smc.vnet.net>, Dule <dule23@gmx.de> wrote:

> for calculating a model i need values for x which are given by the
> transcendental function Cot[x] == x/a - a/(4*x). a is a parameter 0<a<200.
> i obtained the roots with Table and FindRoot:
> Table[FindRoot[Cot[x] == x/a - a/(4*x), {x, i}], {i, 1, 50}]]
>
> I have two questions:
> 1. Is there a better way to do this?

Yes. Have a look at the RootSearch package by Ted Ersek:

http://library.wolfram.com/infocenter/MathSource/4482/

This package returns all the roots over a specified range as a list of
replacement rules (see also the more primitive RootsInRange function
that appeared in "Finding Roots in an Interval" in The Mathematica
Journal 7(2), 1998).

> 2. How can i construct a list, where the values for x, which appear
> multiple are dropped?

Using RootSearch you will not get multiples. The simplest way of
removing repeated entries from a list is to use Union

Union[{a,b,c,a}]

{a, b, c}

If entries are not exactly the same then you can use the SameTest option
for Union.

Cheers,
Paul

________________________________________
_______________________________
Paul Abbott Phone: 61 8 6488 2734
School of Physics, M013 Fax: +61 8 6488 1014
The University of Western Australia (CRICOS Provider No 00126G)
AUSTRALIA http://physics.uwa.edu.au/~paul

Carl K. Woll

2006-03-23, 7:10 pm

Dule wrote:
> Dear group,
>
> for calculating a model i need values for x which are given by the
> transcendental function Cot[x] == x/a - a/(4*x). a is a parameter 0<a<200.
> i obtained the roots with Table and FindRoot:
> Table[FindRoot[Cot[x] == x/a - a/(4*x), {x, i}], {i, 1, 50}]]
>
> I have two questions:
> 1. Is there a better way to do this?
> 2. How can i construct a list, where the values for x, which appear
> multiple are dropped?
>
> Thanks!

One method to find subintervals of an interval guaranteed to contain all
of the roots of a function f is to use the package IntervalRoots. With
this package, f must be able to accept an Interval object as an
argument, which is satisfied with your example. So, load the package:

Needs["NumericalMath`IntervalRoots`"]

We'll use IntervalBisection because your function is discontinuous. With
IntervalNewton, the roots are found more quickly, but the
discontinuities may cause some roots to be missed. The default value for
MaxRecursion is a bit low, so we'll increase it.

In[10]:=
With[{a = 10}, IntervalBisection[Cot[x] - x/a + a/(4*x), x,
Interval[{0, 50}], 0.1, MaxRecursion -> 30]]

Out[10]=
Interval[{2.24609, 2.34375}, {4.6875, 4.78516}, {7.42188, 7.51953},

{10.2539, 10.3516}, {13.2812, 13.3789}, {16.2109, 16.3086},

{19.3359, 19.4336}, {22.3633, 22.4609}, {25.4883, 25.5859},

{28.6133, 28.7109}, {31.6406, 31.7383}, {34.7656, 34.8633},

{37.8906, 37.9883}, {41.0156, 41.1133}, {44.1406, 44.2383},

{47.2656, 47.3633}]

You can refine the search for roots by choosing a smaller eps than 0.1,
or you can use FindRoot with these smaller intervals. Here we repeat
with an eps of 10^-6:

In[11]:=
With[{a = 10}, IntervalBisection[Cot[x] - x/a + a/(4*x), x,
Interval[{0, 50}], 10^-6, MaxRecursion -> 30]]

Out[11]=
Interval[{2.28445, 2.28445}, {4.76129, 4.76129}, {7.46368, 7.46368},

{10.3266, 10.3266}, {13.2862, 13.2862}, {16.3031, 16.3031},

{19.3552, 19.3552}, {22.4298, 22.4298}, {25.5197, 25.5197},

{28.6202, 28.6202}, {31.7285, 31.7285}, {34.8426, 34.8426},

{37.961, 37.961}, {41.0829, 41.0829}, {44.2075, 44.2075},

{47.3344, 47.3344}]

Let me repeat the advantage of IntervalBisection. All of the roots to
your equation between 0 and 50 are guaranteed to lie in one of the above
intervals. Another nice thing with IntervalBisection is that for
functions with a finite number of roots, your starting interval can be
Interval[{-Infinity,Infinity}]. The di

vantage, of course, is that
most special functions cannot accept Interval objects as input.

Carl Woll
Wolfram Research

David Park

2006-03-23, 7:10 pm

Try using Ted Ersek's RootSearch from MathSource.

Needs["Ersek`RootSearch`"]
func[a_] := Cot[x] == x/a - a/(4*x)
plotf[a_] := Cot[x] - (x/a - a/(4*x))

RootSearch[func[100], {x, 0.1, 50}]

{{x -> 3.0209}, {x -> 6.04265}, {x -> 9.06603}, {x -> 12.0918}, {x ->
15.1206}, {x -> 18.153}, {x -> 21.1895}, {x -> 24.2302}, {x ->
27.2756}, {x -> 30.3255}, {x -> 33.3802}, {x -> 36.4395}, {x ->
39.5034}, {x -> 42.5716}, {x -> 45.6441}, {x -> 48.7206}}

Plot[plotf[100], {x, 0.1, 50},
ImageSize -> 500]

David Park
djmp@earthlink.net
http://home.earthlink.net/~djmp/

From: Dule [mailto:dule23@gmx.de]

Dear group,

for calculating a model i need values for x which are given by the
transcendental function Cot[x] == x/a - a/(4*x). a is a parameter 0<a<200.
i obtained the roots with Table and FindRoot:
Table[FindRoot[Cot[x] == x/a - a/(4*x), {x, i}], {i, 1, 50}]]

I have two questions:
1. Is there a better way to do this?
2. How can i construct a list, where the values for x, which appear
multiple are dropped?

Thanks!

David W. Cantrell

2006-03-24, 4:16 am

"David Park" <djmp@earthlink.net> wrote:
> Try using Ted Ersek's RootSearch from MathSource.

I had supposed that someone would mention RootSearch. I see now that you
and Paul Abbott did. Having never used RootSearch before myself, I thought
that now would be a good time to give it a try. Please see my comments
below.

> Needs["Ersek`RootSearch`"]
> func[a_] := Cot[x] == x/a - a/(4*x)
> plotf[a_] := Cot[x] - (x/a - a/(4*x))
>
> RootSearch[func[100], {x, 0.1, 50}]
>
> {{x -> 3.0209}, {x -> 6.04265}, {x -> 9.06603}, {x -> 12.0918}, {x ->
> 15.1206}, {x -> 18.153}, {x -> 21.1895}, {x -> 24.2302}, {x ->
> 27.2756}, {x -> 30.3255}, {x -> 33.3802}, {x -> 36.4395}, {x ->
> 39.5034}, {x -> 42.5716}, {x -> 45.6441}, {x -> 48.7206}}
>
> Plot[plotf[100], {x, 0.1, 50},
> ImageSize -> 500]
>
> David Park
> djmp@earthlink.net
> http://home.earthlink.net/~djmp/
>
> From: Dule [mailto:dule23@gmx.de]
>
> Dear group,
>
> for calculating a model i need values for x which are given by the
> transcendental function Cot[x] == x/a - a/(4*x). a is a parameter
> 0<a<200. i obtained the roots with Table and FindRoot:
> Table[FindRoot[Cot[x] == x/a - a/(4*x), {x, i}], {i, 1, 50}]]
>
> I have two questions:
> 1. Is there a better way to do this?
> 2. How can i construct a list, where the values for x, which appear
> multiple are dropped?

I'll assume that you're interested in the positive roots only. (But of
course the negative roots can be obtained by symmetry from the positive
ones, if desired.)

If you plot Cot[x] and x/a - a/(4*x) for a few values of parameter a (say,
0.01, 1 and 100), it should be clear that your equation will have exactly
one root in each open interval of the form (n Pi, (n+1) Pi), where n is a
nonnegative integer. (This is due, among other things, to the periodicity
of Cot[x].) Furthermore, when a is small, that root will be close to the
left endpoint of that interval, and when a is large, that root will be
close to the right endpoint.

With this knowledge, your original idea can be modified very easily to get
the roots when a = 0.01:

a = 0.01; Table[FindRoot[Cot[x] == x/a - a/(4*x), {x, i}], {i, 10^-6, 50, Pi}]

{{x->0.0999584},{x->3.14477},{x->6.28478},{x->9.42584},{x->12.5672},
{x->15.7086},{x->18.8501},{x->21.9916},{x->25.1331},{x->28.2747},
{x->31.4162},{x->34.5578},{x->37.6994},{x->40.8409},{x->43.9825},
{x->47.1241}}

I was somewhat surprised that RootSearch did not find many of those roots:

a = 0.01; RootSearch[Cot[x] == x/a - a/(4*x), {x, 10^-6, 50}]

{{x->0.0999584},{x->3.14477},{x->6.28478},{x->12.5672}}

But please bear in mind that I'm a complete novice at using RootSearch.
There is probably some simple Option which can be changed so that it will
find them all easily. It certainly found all the roots in the example given
by David P. above with a = 100.

Regards,
David Cantrell

Bob Hanlon

2006-03-24, 4:16 am

a=200*Random[]

110.895

Duplicates can be removed with Union.

Union[
Table[
x/.FindRoot[Cot[x]==x/a-a/(4*x),{x,i}],
{i,50}],
SameTest->(Abs[#1-#2]<10^-6&)]

{3.03232,6.06528,9.09946,12.1354,15.1737,18.2148,21.2589,24.3065,27.3
576,30.\
4126,33.4713,36.5339,39.6003,42.6705,45.7443,48.8216}

However, the need for Union can be avoided by using better initial values for
FindRoot

Table[
x/.FindRoot[Cot[x]==x/a-a/(4*x),{x,i*Pi-0.1}],
{i,50/Pi+1}]

{3.03232,6.06528,9.09946,12.1354,15.1737,18.2148,21.2589,24.3065,27.3
576,30.\
4126,33.4713,36.5339,39.6003,42.6705,45.7443,48.8216}

%==%%

True

Bob Hanlon

>
> From: Dule <dule23@gmx.de>
> Subject: sorting list of roots af a transcendental function
>
> Dear group,
>
> for calculating a model i need values for x which are given by the
> transcendental function Cot[x] == x/a - a/(4*x). a is a parameter
0<a<200.
> i obtained the roots with Table and FindRoot:
> Table[FindRoot[Cot[x] == x/a - a/(4*x), {x, i}], {i, 1, 50}]]
>
> I have two questions:
> 1. Is there a better way to do this?
> 2. How can i construct a list, where the values for x, which appear
> multiple are dropped?
>
> Thanks!
>
>

János

2006-03-24, 4:16 am

On Mar 23, 2006, at 6:58 AM, Roger Bagula wrote:

> Dule wrote:
>
> I have a similar question of my own:
> I want to get the weights where this equation has largest roots
> equal to
> integers:g^3-g-w[n]=0
> for prime weights:
> w[n]=Prime[n]
>
> b = Table[Table[x /. NSolve[x^3 - x - Prime[n] - 1 == 0.x][[m]],
> {m, 1,
> 3}], {n, 1, 10}]
> MatrixForm[b]
> c = Table[{n, Max[Table[Abs[x] /. Solve[x^3 - x -
> Prime[n] - 1 == 0.x][[m]], {m, 1, 3}]]}, {n, 1, 20}]
> ListPlot[c]
>
> This doersn't work: it doesn't see them as Integers:
> d = Flatten[Table[{n, If [IntegerQ[
> Max[Table[Abs[x] /.
> Solve[x^3 -
> x - Prime[n] - 1 == 0.x][[m]], {m, 1, 3}]]], Max[
> Table[Abs[x] /. Solve[x^3 - x - Prime[n] - 1 ==
> 0.x][[
> m]], {m, 1, 3}]], {}]}, {n, 1, 20}], 1]
>
> That is in:
> {{1, 1.6717}, {2, 1.79632}, {3, 2.}, {4, 2.16631}, {5,
> 2.43484}, {6, 2.5483}, {7, 2.74784}, {8, 2.83714}, {9,
> 3.}, {10, 3.21447}, {11, 3.27976}, {12, 3.4611}, {13,
> 3.5719}, {14, 3.62475}, {15, 3.72594}, {16, 3.86794}, {
> 17, 4.}, {18, 4.0421}, {19, 4.16331}, {20, 4.24028}}
>
> I want output ( integer weights separated out):
> { {3, 2}, {9, 3}, {17, 4}}

Here is a newbie approach:

In[1]:=
lst = {{1, 1.6717},
{2, 1.79632}, {3, 2.},
{4, 2.16631},
{5, 2.43484},
{6, 2.5483},
{7, 2.74784},
{8, 2.83714}, {9, 3.},
{10, 3.21447},
{11, 3.27976},
{12, 3.4611},
{13, 3.5719},
{14, 3.62475},
{15, 3.72594},
{16, 3.86794}, {17, 4.},
{18, 4.0421},
{19, 4.16331},
{20, 4.24028}};

In[2]:=
Select[lst,
FractionalPart[#1[[2]]] ==
0 & ]
Out[2]=
{{3, 2.}, {9, 3.}, {17, 4.}}

---------------------------------------------
It is a "hard slug" to kill terrorists.
Here is an easier method to kill them.
1. First kill all the non-terrorists, - children, women, the
elderly -, because that is a piece of cake. That will be just
"collateral demage".
2. Kill the rest of it. Now that is easy because you do not have to
worry about the innocent any more.

Bob Hanlon

2006-03-24, 4:16 am

{#[[1]], x/.#[[2]]}&/@
Select[
Table[{n, ToRules[
Reduce[x^3-x-Prime[n]==1, x, Integers]]},
{n, 1, 20}],
Length[#]==2&]

{{3, 2}, {9, 3}, {17, 4}}

Bob Hanlon

>
> From: Roger Bagula <rlbagulatftn@yahoo.com>
> Subject: Re: sorting list of roots af a transcendental function
>
> Dule wrote:
0<a<200.[color=darkred]
>
> I have a similar question of my own:
> I want to get the weights where this equation has largest roots equal to
> integers:g^3-g-w[n]=0
> for prime weights:
> w[n]=Prime[n]
>
> b = Table[Table[x /. NSolve[x^3 - x - Prime[n] - 1 == 0.x][[m]], {m, 1,
> 3}], {n, 1, 10}]
> MatrixForm[b]
> c = Table[{n, Max[Table[Abs[x] /. Solve[x^3 - x -
> Prime[n] - 1 == 0.x][[m]], {m, 1, 3}]]}, {n, 1, 20}]
> ListPlot[c]
>
> This doersn't work: it doesn't see them as Integers:
> d = Flatten[Table[{n, If [IntegerQ[
> Max[Table[Abs[x] /.
> Solve[x^3 -
> x - Prime[n] - 1 == 0.x][[m]], {m, 1, 3}]]], Max[
> Table[Abs[x] /. Solve[x^3 - x - Prime[n] - 1 == 0.x][[
> m]], {m, 1, 3}]], {}]}, {n, 1, 20}], 1]
>
> That is in:
> {{1, 1.6717}, {2, 1.79632}, {3, 2.}, {4, 2.16631}, {5,
> 2.43484}, {6, 2.5483}, {7, 2.74784}, {8, 2.83714}, {9,
> 3.}, {10, 3.21447}, {11, 3.27976}, {12, 3.4611}, {13,
> 3.5719}, {14, 3.62475}, {15, 3.72594}, {16, 3.86794}, {
> 17, 4.}, {18, 4.0421}, {19, 4.16331}, {20, 4.24028}}
>
> I want output ( integer weights separated out):
> { {3, 2}, {9, 3}, {17, 4}}
>
>

Sponsored Links