home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / l / l042 / 1.ddi / CHAP2.ARC / BISECT.PAS next >
Encoding:
Pascal/Delphi Source File  |  1987-12-30  |  6.8 KB  |  197 lines
  1. program Bisect_Prog;
  2.  
  3. {---------------------------------------------------------------------------}
  4. {-                                                                         -}
  5. {-     Turbo Pascal Numerical Methods Toolbox                              -}
  6. {-     Copyright (c) 1986, 87 by Borland International, Inc.               -}
  7. {-                                                                         -}
  8. {-        Purpose: This program demonstrates the bisection routine.        -}
  9. {-                                                                         -}
  10. {-        Unit   : RootsEqu   procedure Bisect                             -}
  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.   LeftEndpoint, RightEndpoint : Float;   { Endpoints of the region }
  22.   Answer, yAnswer             : Float;   { Root of f(x) }
  23.   Tol                         : Float;   { Tolerance }
  24.   Iter, MaxIter               : integer; { Number of iterations }
  25.   Error                       : byte;    { Flags if something went wrong }
  26.  
  27. {$F+}
  28. {----- HERE IS THE FUNCTION TO FIND A ROOT OF ------}
  29. function TNTargetF(X : Float) : Float;
  30. begin
  31.   TNTargetF := Cos(X) - X;
  32. end; { function TNTargetF }
  33. {---------------------------------------------------}
  34. {$F-}
  35.  
  36. procedure Initial(var LeftEndpoint  : Float;
  37.                   var RightEndpoint : Float;
  38.                   var Answer        : Float;
  39.                   var yAnswer       : Float;
  40.                   var Tol           : Float;
  41.                   var Iter          : integer;
  42.                   var MaxIter       : integer;
  43.                   var Error         : byte);
  44.  
  45. {----------------------------------------------------------}
  46. {- Output: LeftEndpoint, RightEndpoint, Answer, yAnswer,  -}
  47. {-         Tol, Iter, MaxIter, Error                      -}
  48. {-                                                        -}
  49. {- This procedure initializes the above variables to zero -}
  50. {----------------------------------------------------------}
  51. begin
  52.   LeftEndpoint := 0;
  53.   RightEndpoint := 0;
  54.   Answer := 0;
  55.   yAnswer := 0;
  56.   Tol := 0;
  57.   Iter := 0;
  58.   MaxIter := 0;
  59.   Error := 0;
  60. end; { procedure Initial }
  61.  
  62. procedure UserInput(var LeftEndpoint  : Float;
  63.                     var RightEndpoint : Float;
  64.                     var Tol           : Float;
  65.                     var MaxIter       : integer);
  66.  
  67. {-------------------------------------------------------}
  68. {- Output: LeftEndpoint, RightEndpoint, Tol, MaxIter   -}
  69. {-                                                     -}
  70. {- This procedure assigns values to the left and       -}
  71. {- right endpoints of the interval, to the tolerance   -}
  72. {- with which the answer should be found, and to the   -}
  73. {- maximum number of iterations to be performed. Input -}
  74. {- is from the keyboard.                               -}
  75. {-------------------------------------------------------}
  76.  
  77. procedure GetEndPoints(var LeftEndpoint  : Float;
  78.                        var RightEndpoint : Float);
  79. begin
  80.   Writeln;
  81.   repeat
  82.     Write(' Left endpoint: ');
  83.     Readln(LeftEndpoint);
  84.     IOCheck;
  85.   until not IOerr;
  86.   repeat
  87.     Write('Right endpoint: ');
  88.     Readln(RightEndpoint);
  89.     IOCheck;      { check for I/O errors }
  90.   until not IOerr;
  91. end; { procedure GetEndPoints }
  92.  
  93. procedure GetTolerance(var Tol : Float);
  94. begin
  95.   Tol := 1E-8;
  96.   repeat
  97.     Writeln;
  98.     Write('Tolerance (> 0): ');
  99.     ReadFloat(Tol);
  100.     IOCheck;        { Check for I/O errors }
  101.     if Tol <= 0 then
  102.     begin
  103.       IOerr := true;
  104.       Tol := 1E-8;
  105.     end;
  106.   until not IOerr;
  107. end; { procedure GetTolerance }
  108.  
  109. procedure GetMaxIter(var MaxIter : integer);
  110. begin
  111.   MaxIter := 100;
  112.   repeat
  113.     Writeln;
  114.     Write('Maximum number of iterations (> 0)? ');
  115.     ReadInt(MaxIter);
  116.     IOCheck;        { Check for I/O errors }
  117.     if MaxIter < 0 then
  118.     begin
  119.       IOerr := true;
  120.       MaxIter := 100;
  121.     end;
  122.   until not IOerr;
  123. end; { procedure GetMaxIter }
  124.  
  125. begin { procedure UserInput }
  126.   GetEndPoints(LeftEndpoint, RightEndpoint);
  127.   GetTolerance(Tol);
  128.   GetMaxIter(MaxIter);
  129.   GetOutputFile(OutFile);
  130. end; { procedure UserInput }
  131.  
  132. procedure Results(LeftEndpoint  : Float;
  133.                   RightEndpoint : Float;
  134.                   Tol           : Float;
  135.                   MaxIter       : integer;
  136.                   Answer        : Float;
  137.                   yAnswer       : Float;
  138.                   Iter          : integer;
  139.                   Error         : byte);
  140. {------------------------------------------------------------}
  141. {- This procedure outputs the results to the device OutFile -}
  142. {------------------------------------------------------------}
  143. begin
  144.   Writeln(OutFile);
  145.   Writeln(OutFile);
  146.   Writeln(OutFile,'left endpoint: ' : 30, LeftEndpoint);
  147.   Writeln(OutFile,'right endpoint: ' : 30, RightEndpoint);
  148.   Writeln(OutFile,'Tolerance: ' : 30, Tol);
  149.   Writeln(OutFile,'Maximum number of iterations: ' : 30, MaxIter);
  150.   Writeln(OutFile);
  151.   if Error = 1 then
  152.     DisplayWarning;
  153.   if Error >= 2 then
  154.     DisplayError;
  155.   case Error of
  156.     0 : begin
  157.           Writeln(OutFile,'Number of iterations: ' : 26, Iter : 3);
  158.           Writeln(OutFile,'Calculated root: ' : 26, Answer);
  159.           Writeln(OutFile,'Value of the function  ' : 26);
  160.           Writeln(OutFile,'at the calculated root: ' : 26, yAnswer);
  161.         end;
  162.  
  163.     1 : begin
  164.           Writeln(OutFile,'It will take more than ',MaxIter,
  165.                           ' iterations to get within tolerance.');
  166.           Writeln(OutFile);
  167.           Writeln(OutFile,'Number of iterations: ' : 26, Iter);
  168.           Writeln(OutFile,'Calculated root: ' : 26, Answer);
  169.           Writeln(OutFile,'Value of the function  ' : 26);
  170.           Writeln(OutFile,'at the calculated root: ' : 26, yAnswer);
  171.         end;
  172.  
  173.     2 : begin
  174.           Writeln(OutFile,
  175.                   'The sign of the function at the two endpoints is the same.');
  176.           Writeln(OutFile, 'Change the endpoints.');
  177.         end;
  178.  
  179.     3 : Writeln(OutFile, 'The tolerance must be greater than zero.');
  180.  
  181.     4 : Writeln(OutFile,
  182.                 'The maximum number of iteration must be greater than zero.');
  183.   end; { case }
  184. end; { procedure Results }
  185.  
  186. begin { program Bisect }
  187.   ClrScr;
  188.   Initial(LeftEndpoint, RightEndpoint, Answer,
  189.           yAnswer, Tol, Iter, MaxIter, Error);
  190.   UserInput(LeftEndpoint, RightEndpoint, Tol, MaxIter);
  191.   Bisect(LeftEndpoint, RightEndpoint, Tol, MaxIter,
  192.          Answer, yAnswer, Iter, Error, @TNTargetF);
  193.   Results(LeftEndpoint, RightEndpoint, Tol, MaxIter,
  194.           Answer, yAnswer, Iter, Error);
  195.   Close(OutFile);
  196. end. { program Bisect }
  197.