home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / l / l042 / 1.ddi / CHAP2.ARC / SECANT.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1987-12-30  |  6.6 KB  |  197 lines
  1. program Secant_Prog;
  2.  
  3. {----------------------------------------------------------------------------}
  4. {-                                                                          -}
  5. {-     Turbo Pascal Numerical Methods Toolbox                               -}
  6. {-     Copyright (c) 1986, 87 by Borland International, Inc.                -}
  7. {-                                                                          -}
  8. {-        Purpose: This sample program demonstrates the secant method.      -}
  9. {-                                                                          -}
  10. {-        Unit   : RootsEqu    procedure Secant                             -}
  11. {-                                                                          -}
  12. {----------------------------------------------------------------------------}
  13.  
  14. {$I-}          { Disable I/O error trapping }
  15. {$R+}          { Enable range checking }
  16.  
  17. uses
  18.   RootsEqu, Dos, Crt, Common;
  19.  
  20. var
  21.   InitGuess1 : Float;         { Initial approximation #1 }
  22.   InitGuess2 : Float;         { Initial approximation #2 }
  23.   Tolerance : Float;          { Tolerance in answer }
  24.   Root, Value : Float;        { Resulting root and other info }
  25.   Iter : integer;             { Number of iterations to find root }
  26.   MaxIter : integer;          { Maximum number of iterations }
  27.   Error : byte;               { Error flag }
  28.  
  29. {$F+}
  30. {------- HERE IS THE FUNCTION ----------}
  31. function TNTargetF(X : Float) : Float;
  32. begin
  33.   TNTargetF := Cos(X) - X;
  34. end;  { function TNTargetF }
  35. {---------------------------------------}
  36. {$F-}
  37.  
  38. procedure Initialize(var InitGuess1 : Float;
  39.                      var InitGuess2 : Float;
  40.                      var Tolerance  : Float;
  41.                      var Root       : Float;
  42.                      var Value      : Float;
  43.                      var MaxIter    : integer;
  44.                      var Iter       : integer;
  45.                      var Error      : byte);
  46.  
  47. {-----------------------------------------------------------}
  48. {- Output: InitGuess1, InitGuess2, Tolerance, Root, Value, -}
  49. {-         MaxIter, Iter, Error                            -}
  50. {-                                                         -}
  51. {- This procedure initializes the above variables to zero. -}
  52. {-----------------------------------------------------------}
  53.  
  54. begin
  55.   InitGuess1 := 0;
  56.   InitGuess2 := 0;
  57.   Tolerance := 0;
  58.   MaxIter := 0;
  59.   Root := 0;
  60.   Value := 0;
  61.   Error := 0;
  62.   Iter := 0;
  63. end; { procedure Initialize }
  64.  
  65. procedure UserInput(var InitGuess1 : Float;
  66.                     var InitGuess2 : Float;
  67.                     var Tol        : Float;
  68.                     var MaxIter    : integer);
  69.  
  70. {-------------------------------------------------------------}
  71. {- Output: InitGuess1, InitGuess2, Tol, MaxIter              -}
  72. {-                                                           -}
  73. {- This procedure assigns values to the initial guesses      -}
  74. {- (InitGuess1, InitGuess2), to the tolerance to which the   -}
  75. {- answer should be found, and to the maximum number of      -}
  76. {- iterations to be performed. Input is from the keyboard.   -}
  77. {-------------------------------------------------------------}
  78.  
  79. procedure GetInitialGuess(var InitGuess1 : Float;
  80.                           var InitGuess2 : Float);
  81. begin
  82.   repeat
  83.     Writeln;
  84.     Write('First initial approximation to the root: ');
  85.     Readln(InitGuess1);
  86.     IOCheck;        { Check for I/O errors }
  87.   until not IOerr;
  88.   repeat
  89.     Writeln;
  90.     Write('Second initial approximation to the root: ');
  91.     Readln(InitGuess2);
  92.     IOCheck;        { Check for I/O errors }
  93.   until not IOerr;
  94. end; { procedure GetInitialGuess }
  95.  
  96. procedure GetTolerance(var Tol : Float);
  97. begin
  98.   Tol := 1E-8;
  99.   repeat
  100.     Writeln;
  101.     Write('Tolerance (> 0): ');
  102.     ReadFloat(Tol);
  103.     IOCheck;        { Check for I/O errors }
  104.     if Tol <= 0 then
  105.     begin
  106.       IOerr := true;
  107.       Tol := 1E-8;
  108.     end;
  109.   until not IOerr;
  110. end; { procedure GetTolerance }
  111.  
  112. procedure GetMaxIter(var MaxIter : integer);
  113. begin
  114.   MaxIter := 100;
  115.   repeat
  116.     Writeln;
  117.     Write('Maximum number of iterations (> 0): ');
  118.     ReadInt(MaxIter);
  119.     IOCheck;
  120.     if MaxIter < 0 then
  121.     begin
  122.       IOerr := true;
  123.       MaxIter := 100;
  124.     end;
  125.   until not IOerr;
  126. end; { procedure GetMaxIter }
  127.  
  128. begin { procedure UserInput }
  129.   GetInitialGuess(InitGuess1, InitGuess2);
  130.   GetTolerance(Tol);
  131.   GetMaxIter(MaxIter);
  132.   GetOutputFile(OutFile);
  133. end; { procedure UserInput }
  134.  
  135. procedure Results(InitGuess1 : Float;
  136.                   InitGuess2 : Float;
  137.                   Tol        : Float;
  138.                   MaxIter    : integer;
  139.               var OutFile    : text;
  140.                   Root       : Float;
  141.                   Value      : Float;
  142.                   Iter       : integer;
  143.                   Error      : byte);
  144.  
  145. {------------------------------------------------------------}
  146. {- This procedure outputs the results to the device OutFile -}
  147. {------------------------------------------------------------}
  148.  
  149. begin
  150.   Writeln(OutFile);
  151.   Writeln(OutFile);
  152.   Writeln(OutFile, ' First initial approximation: ' : 30, InitGuess1);
  153.   Writeln(OutFile, 'Second initial approximation: ': 30, InitGuess2);
  154.   Writeln(OutFile, 'Tolerance: ' : 30, Tol);
  155.   Writeln(OutFile, 'Maximum number of iterations: ' : 30, MaxIter);
  156.   Writeln(OutFile);
  157.   if Error in [1, 2] then
  158.     DisplayWarning;
  159.   if Error >= 3 then
  160.     DisplayError;
  161.  
  162.   case Error of
  163.     1 : Writeln(OutFile, 'It will take more than ',MaxIter,
  164.                 ' iterations to solve this equation.');
  165.  
  166.     2 : Writeln(OutFile, 'The slope is approaching zero.');
  167.  
  168.     3 : Writeln(OutFile, 'The tolerance must be greater than zero.');
  169.  
  170.     4 : Writeln(OutFile,
  171.                 'The maximum number of iterations must be greater than zero.');
  172.  
  173.   end; { case }
  174.   if Error <= 2 then
  175.   begin
  176.     Writeln(OutFile);
  177.     Writeln(OutFile, 'Number of iterations: ' : 30, Iter : 3);
  178.     Writeln(OutFile, 'Calculated root: ' : 30, Root);
  179.     Writeln(OutFile, 'Value of the function  ' : 30);
  180.     Writeln(OutFile, 'at the calculated root: ' : 30, Value);
  181.     Writeln(OutFile);
  182.   end;
  183. end; { procedure Results }
  184.  
  185. begin { program Secant }
  186.   ClrScr;
  187.   Initialize(InitGuess1, InitGuess2, Tolerance, Root,
  188.              Value, MaxIter, Iter, Error);
  189.   UserInput(InitGuess1, InitGuess2, Tolerance, MaxIter);
  190.   { Use the Secant method to converge onto a root }
  191.   Secant(InitGuess1, InitGuess2, Tolerance, MaxIter,
  192.          Root, Value, Iter, Error, @TNTargetF);
  193.   Results(InitGuess1, InitGuess2, Tolerance, MaxIter, OutFile,
  194.           Root, Value, Iter, Error);
  195.   Close(OutFile);         { Close output file }
  196. end. { program Secant }
  197.