Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
2002
*January
*February
*March
*April
*May
*June
*July
*August
*September
*October
*November
*December
*Archive Index
*Ask about this page
*Print this page
*Give us feedback
*Sign up for the Wolfram Insider

MathGroup Archive 2002

[Date Index] [Thread Index] [Author Index]

Search the Archive

RE: Successive Approximation

  • To: mathgroup at smc.vnet.net
  • Subject: [mg37121] RE: [mg37081] Successive Approximation
  • From: "DrBob" <drbob at bigfoot.com>
  • Date: Thu, 10 Oct 2002 03:21:06 -0400 (EDT)
  • Reply-to: <drbob at bigfoot.com>
  • Sender: owner-wri-mathgroup at wolfram.com

The first problem is that ArcSin[x/10] isn't a left-inverse of 10 Sin[x]
in the region of the root.  That's why your code converges on another
root.  A better inverse for your purpose is the gi below:

f = #(# + 3) &;
g = 10Sin@# &;
gi = Pi - ArcSin[#/10] &;

Using that inverse, there's still a problem, though.  Your
"approximation" of the root with

r = gi@f@r

fails because the derivative of gi@f at the root is

gi'[f@rr]f'[rr]

-2.02342

That's greater than one in magnitude, so distance from the root is
magnified rather than diminished.  Instead, try

r = fi@g@r

Where

fi[y_] := Evaluate[x /. Last@Solve[f@x == y, x]]

This should work, since

fi'[g@rr]g'[rr]

-0.49421355442685166

Sure enough, it does work:

Values = NestList[fi[g[#1]] & , 2., 12]

{2., 1.8679332339369226, 1.9368280058437026, 1.9040490698559083,
1.9205018812387413, 
  1.9124384783620436, 1.916439313493727, 1.9144659935649395,
1.9154421880638148,
  1.914959973607326, 1.915198347545482, 1.9150805538598723,
1.9151387724997768}

(f[#1] - g[#1] & ) /@ values

{0.9070257317431825, -0.4688124734947827, 
  0.2242366717647286, -0.11228304957089463, 
  0.05509675095190758, -0.02732121417963107, 
  0.0134795615740817, -0.006667318794729482, 
  0.003293718665990042, -0.0016281317372435211, 
  0.0008045637255396088, -0.00039764607942949226, 
  0.0001965172491082967}

Absolute error is cut in half at each iteration, as expected with a
derivative for fi@g near -1/2.  The negative sign causes the error to
alternate in sign.  We can also look at the log-absolute value of the
error as follows:

(Log[Abs[f[#1] - 
      g[#1]]] & ) /@ values

{-0.09758445910053692, -0.7575524337892089, -1.4950532145264737,
-2.18673236744676, 
  -2.8986645309519163, -3.6000918023816326, -4.306580698204814,
-5.010537479670821, 
 -5.715738058891756, -6.420322094992857, -7.125210383308283,
-7.829948195959684, -8.534760348785936}

Rest[%] - Drop[%, -1]

{-0.659967974688672, -0.7375007807372648, -0.6916791529202861,
-0.7119321635051565, 
  -0.7014272714297163, -0.7064888958231816, -0.7039567814660064,
-0.7052005792209357, 
  -0.7045840361011004, -0.7048882883154262, -0.704737812651401,
-0.7048121528262516}

The difference in logarithm of the absolute error approaches

Log@Abs[fi'[g@rr]g'[rr]]

-0.7047875587967565

If you want to use this for teaching, try to use as little code as
possible -- as I have above -- and always try to avoid Do loops in
Mathematica on principle.

DrBob

-----Original Message-----
From: Flurchick, Kenneth M [mailto:FLURCHICKK at MAIL.ECU.EDU] 
To: mathgroup at smc.vnet.net
Subject: [mg37121] [mg37081] Successive Approximation


GentleBeings
I have a straightforward implementation of successive approximations
but I cannot seem to froce the code to find the correct solution when I
have

trig or exponentials involved.  Can the assembled wisdom point to
straghtforward fixes I know FindRoot works the object is to teach
programming and successive approx, tho.

Thanks
kenf

Below is the code

Clear[f, g, gi, lim, r, rr, fr, \ gir, a, b, c, d, conv];
  Plot[{x * ((x + 3)), 10*Sin[x]}, {x, 0.01, 2.4}, 
    PlotStyle -> {{RGBColor[1, 0, 0], Thickness[ .006]}, 
                  {RGBColor[0, 0, 1], Thickness[ .006]}}
  ];
  rr = FindRoot[x * ((x + 3)) == 10*Sin[x], {x, 2, 0.01, 2.4}];
  f[a_] := a * ((a + 3)) /; a >  0;
  g[b_] := 10. * Sin[b] /; b > 0;
  gi[c_] := ArcSin[0.1*c] /; c > 0;
  Print["Actual root is ", rr];
  lim = 10;
  r = 2.0;
  conv = 10^-4;
  For[i = 1, i < lim, i++, 
    {
      fr = f[r]; 
      gir = gi[fr]; 
      d = Abs[N[gir] - r]; i
      If[d < conv, Break[]]; 
      r = gir; 
      Print["The value of x = ", r, " found after ", i, " iterations,", 
            " with a tolerence ", d, "\n"]
    }
  ]
  Print["The value of x = ", r, " found after ",  i, " iterations,",  
        " with a tolerence ", d, "\n"]

"Every man, woman and responsible child has an unalienable individual,
civil, Constitutional and human right to obtain, own, and carry, openly
or
concealed, any weapon -- rifle, shotgun, handgun, machine gun, anything
--
any time, any place, without asking anyone's permission."
                                                           L. Neil Smith






  • Prev by Date: Re: Re: Accuracy and Precision
  • Next by Date: Re: Re: Accuracy and Precision
  • Previous by thread: Successive Approximation
  • Next by thread: Function vs. Procedure