home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / l / l042 / 1.ddi / CHAP5.ARC / ADAPGAUS.PAS next >
Encoding:
Pascal/Delphi Source File  |  1987-12-30  |  7.9 KB  |  222 lines
  1. program Adaptive_Gauss_Quadrature_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 integration with            -}
  9. {-                    Adaptive Quadrature methods and Gaussian Quadrature.  -}
  10. {-                                                                          -}
  11. {-           Unit   : Integrat    procedure Adaptive_Gauss_Quadrature       -}
  12. {-                                                                          -}
  13. {----------------------------------------------------------------------------}
  14.  
  15. {$I-}      { Disable I/O error trapping }
  16. {$R+}      { Enable range checking }
  17.  
  18. uses
  19.   Integrat, Dos, Crt, Common;
  20.  
  21. var
  22.   LowerLimit, UpperLimit : Float;   { Limits of integration }
  23.   Tolerance : Float;                { Tolerance in the answer }
  24.   MaxIntervals : integer;           { Maximum number of subintervals used }
  25.                                     { to approximate the integral }
  26.   Integral : Float;                 { Value of the integral }
  27.   NumIntervals : integer;           { Number of subintervals used }
  28.                                     { to approximate integral }
  29.   Error : byte;                     { Flags if something went wrong }
  30.  
  31. {$F+}
  32. function TNTargetF(X : Float) : Float;
  33.  
  34. {-----------------------------------------------------}
  35. {-         This is the function to integrate         -}
  36. {-----------------------------------------------------}
  37.  
  38. begin
  39.   TNTargetF := Exp(3 * X) + Sqr(X) / 3;
  40. end; { function TNTargetF }
  41. {$F-}
  42.  
  43. procedure Initialize(var LowerLimit   : Float;
  44.                      var UpperLimit   : Float;
  45.                      var Integral     : Float;
  46.                      var Tolerance    : Float;
  47.                      var MaxIntervals : integer;
  48.                      var NumIntervals : integer;
  49.                      var Error        : byte);
  50.  
  51. {------------------------------------------------------------------}
  52. {- Output: LowerLimit, UppterLimit, Integral, Tolerance,          -}
  53. {-         MaxIntervals, NumIntervals, Error                      -}
  54. {-                                                                -}
  55. {- This procedure initializes the above variables to zero         -}
  56. {------------------------------------------------------------------}
  57.  
  58. begin
  59.   Writeln;
  60.   LowerLimit := 0;
  61.   UpperLimit := 0;
  62.   Integral := 0;
  63.   Tolerance := 0;
  64.   MaxIntervals := 0;
  65.   NumIntervals := 0;
  66.   Error := 0;
  67. end; { procedure Initialize }
  68.  
  69. procedure GetData(var LowerLimit   : Float;
  70.                   var UpperLimit   : Float;
  71.                   var Tolerance    : Float;
  72.                   var MaxIntervals : integer);
  73.  
  74. {------------------------------------------------------------}
  75. {- Output: LowerLimit, UpperLimit, Tolerance, MaxIntervals  -}
  76. {-                                                          -}
  77. {- This procedure assigns values to the above variables     -}
  78. {- from keyboard input                                      -}
  79. {------------------------------------------------------------}
  80.  
  81. procedure GetLimits(var LowerLimit : Float;
  82.                     var UpperLimit : Float);
  83.  
  84. {------------------------------------------------------------}
  85. {- Output: LowerLimit, UpperLimit                           -}
  86. {-                                                          -}
  87. {- This procedure assigns values to the limits of           -}
  88. {- integration from keyboard input                          -}
  89. {------------------------------------------------------------}
  90.  
  91. begin
  92.   repeat
  93.     repeat
  94.       Write('Lower limit of integration? ');
  95.       Readln(LowerLimit);
  96.       IOCheck;
  97.     until not IOerr;
  98.     Writeln;
  99.     repeat
  100.       Write('Upper limit of integration? ');
  101.       Readln(UpperLimit);
  102.       IOCheck;
  103.     until not IOerr;
  104.     if LowerLimit = UpperLimit then
  105.     begin
  106.       Writeln;
  107.       Writeln('       The limits of integration must be different.');
  108.       Writeln;
  109.     end;
  110.   until LowerLimit <> UpperLimit;
  111. end; { procedure GetLimits }
  112.  
  113. procedure GetTolerance(var Tolerance : Float);
  114.  
  115. {--------------------------------------------------}
  116. {- Output: Tolerance                              -}
  117. {-                                                -}
  118. {- This procedure reads in the accepted Tolerance -}
  119. {- from the keyboard.                             -}
  120. {--------------------------------------------------}
  121.  
  122. begin
  123.   Writeln;
  124.   repeat
  125.     Tolerance := 1E-8;
  126.     Write('Tolerance in answer: (> 0): ');
  127.     ReadFloat(Tolerance);
  128.     IOCheck;
  129.     if Tolerance <= 0 then
  130.     begin
  131.       IOerr := true;
  132.       Tolerance := 1E-8;
  133.     end;
  134.   until not IOerr;
  135. end; { procedure GetTolerance }
  136.  
  137. procedure GetMaxIntervals(var MaxIntervals : integer);
  138.  
  139. {--------------------------------------------------}
  140. {- Output: MaxIntervals                           -}
  141. {-                                                -}
  142. {- This procedure reads in the maximum number of  -}
  143. {- subintervals to be used in approximating the   -}
  144. {- integral.  Input is from the keyboard.         -}
  145. {--------------------------------------------------}
  146.  
  147. begin
  148.   Writeln;
  149.   repeat
  150.     MaxIntervals := 1000;
  151.     Write('Maximum number of subintervals (> 0): ');
  152.     ReadInt(MaxIntervals);
  153.     IOCheck;
  154.     if MaxIntervals <= 0 then
  155.     begin
  156.       IOerr := true;
  157.       MaxIntervals := 1000;
  158.     end;
  159.   until not IOerr;
  160. end; { procedure GetMaxIntervals }
  161.  
  162. begin { procedure GetData }
  163.   GetLimits(LowerLimit, UpperLimit);
  164.   GetTolerance(Tolerance);
  165.   GetMaxIntervals(MaxIntervals);
  166.   GetOutputFile(OutFile);
  167. end; { procedure GetData }
  168.  
  169. procedure Results(LowerLimit   : Float;
  170.                   UpperLimit   : Float;
  171.                   Tolerance    : Float;
  172.                   MaxIntervals : integer;
  173.                   Integral     : Float;
  174.                   NumIntervals : integer;
  175.                   Error        : byte);
  176.  
  177. {------------------------------------------------------------}
  178. {- This procedure outputs the results to the device OutFile -}
  179. {------------------------------------------------------------}
  180.  
  181. begin
  182.   Writeln(OutFile);
  183.   Writeln(OutFile);
  184.   Writeln(OutFile, 'Lower Limit:' : 35, LowerLimit : 25);
  185.   Writeln(OutFile, 'Upper Limit:' : 35, UpperLimit : 25);
  186.   Writeln(OutFile, 'Tolerance:' : 35, Tolerance : 25);
  187.   Writeln(OutFile, 'Maximum number of subintervals:' : 35, MaxIntervals : 5);
  188.   Writeln(OutFile, 'Number of subintervals used:' : 35, NumIntervals : 5);
  189.   Writeln(OutFile);
  190.   if Error = 3 then
  191.     DisplayWarning;
  192.   if Error in [1, 2] then
  193.     DisplayError;
  194.  
  195.   case Error of
  196.     0 : Writeln(OutFile, 'Integral:' : 25, Integral);
  197.  
  198.     1 : Writeln(OutFile, 'The tolerance must be greater than zero.');
  199.  
  200.     2 : Writeln(OutFile,
  201.                 'The maximum number of intervals must be greater than zero.');
  202.  
  203.     3 : begin
  204.           Writeln(OutFile, 'The integral was not found with ', NumIntervals,
  205.                            ' subintervals.');
  206.           Writeln(OutFile, 'The integral thus far: ', Integral);
  207.         end;
  208.   end; { case }
  209. end; { procedure Results }
  210.  
  211. begin { program Adaptive_Gauss_Quadrature }
  212.   ClrScr;
  213.   Initialize(LowerLimit, UpperLimit, Integral, Tolerance, MaxIntervals,
  214.              NumIntervals, Error);
  215.   GetData(LowerLimit, UpperLimit, Tolerance, MaxIntervals);
  216.   Adaptive_Gauss_Quadrature(LowerLimit, UpperLimit, Tolerance, MaxIntervals,
  217.                             Integral, NumIntervals, Error, @TNTargetF);
  218.   Results(LowerLimit, UpperLimit, Tolerance, MaxIntervals,
  219.           Integral, NumIntervals, Error);
  220.   Close(OutFile);
  221. end. { program Adaptive_Gauss_Quadrature }
  222.