home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / l / l042 / 1.ddi / CHAP4.ARC / DERIVFN.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-12-30  |  7.4 KB  |  221 lines
  1. program FirstDerivative_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 differentiation         -}
  9. {-                    routine FirstDerivative. This procedure approximates  -}
  10. {-                    the first derivative to a function at a given number  -}
  11. {-                    of points.                                            -}
  12. {-                                                                          -}
  13. {-           Unit   : Differ    procedure FirstDerivative                   -}
  14. {-                                                                          -}
  15. {----------------------------------------------------------------------------}
  16.  
  17. {$I-}      { Disable I/O error trapping }
  18. {$R+}      { Enable range checking }
  19.  
  20. uses
  21.   Differ, Dos, Crt, Common;
  22.  
  23. var
  24.   NumDeriv : integer;      { Number of points at which to find derivative }
  25.   XDeriv : TNvector;       { Values at which to differentiate }
  26.   YDeriv : TNvector;       { 1st derivative at XDeriv points }
  27.   Tolerance : Float;       { Tolerance in answer }
  28.   Error : byte;            { Flags if something went wrong }
  29.  
  30. {$F+}
  31. { ----- Here is the function to differentiate -------------------- }
  32.  
  33. function TNTargetF(X : Float) : Float;
  34. begin
  35.   TNTargetF := Sqr(X) * Cos(X);
  36. end; { function TNTargetF }
  37.  
  38. { ---------------------------------------------------------------- }
  39. {$F-}
  40.  
  41. procedure Initialize(var XDeriv    : TNvector;
  42.                      var YDeriv    : TNvector;
  43.                      var Tolerance : Float;
  44.                      var Error     : byte);
  45.  
  46. {-----------------------------------------------------------}
  47. {- Output: XDeriv, YDeriv, Tolerance, Error                -}
  48. {-                                                         -}
  49. {- This procedure initializes the above variables to zero. -}
  50. {-----------------------------------------------------------}
  51.  
  52. begin
  53.   Tolerance := 0;
  54.   Error := 0;
  55.   FillChar(XDeriv, SizeOf(XDeriv), 0);
  56.   FillChar(YDeriv, SizeOf(YDeriv), 0);
  57. end; { procedure Initialize }
  58.  
  59. procedure GetData(var NumDeriv  : integer;
  60.                   var XDeriv    : TNvector;
  61.                   var Tolerance : Float);
  62.  
  63. {------------------------------------------------------------}
  64. {- Output: NumDeriv, XDeriv, Tolerance                      -}
  65. {-                                                          -}
  66. {- This procedure assigns values to the above variables     -}
  67. {- from either keyboard or data file input                  -}
  68. {------------------------------------------------------------}
  69.  
  70. procedure GetDerivPoints(var NumDeriv : integer;
  71.                          var XDeriv   : TNvector);
  72.  
  73. {------------------------------------------------------------}
  74. {- Output: NumDeriv, XDeriv                                 -}
  75. {-                                                          -}
  76. {- This procedure assigns values to the derivative points   -}
  77. {- from either keyboard or data file input                  -}
  78. {------------------------------------------------------------}
  79.  
  80. procedure GetOneVectorFromFile(var NumDeriv : integer;
  81.                                var XDeriv   : TNvector);
  82.  
  83. {------------------------------------------------------------}
  84. {- Output: NumDeriv, XDeriv                                 -}
  85. {-                                                          -}
  86. {- This procedure assigns values to the derivative points   -}
  87. {- from data file input                                     -}
  88. {------------------------------------------------------------}
  89.  
  90. var
  91.   FileName : string[255];
  92.   InFile : text;
  93.  
  94. begin
  95.   Writeln;
  96.   repeat
  97.     Write('File name? ');
  98.     Readln(FileName);
  99.     Assign(InFile, FileName);
  100.     Reset(InFile);
  101.     IOCheck;
  102.   until not IOerr;
  103.   NumDeriv := 0;
  104.   while not(EOF(InFile)) do
  105.   begin
  106.     NumDeriv := Succ(NumDeriv);
  107.     Readln(InFile, XDeriv[NumDeriv]);
  108.     IOCheck;
  109.   end;
  110.   Close(InFile);
  111. end; { procedure GetOneVectorFromFile }
  112.  
  113. procedure GetOneVectorFromKeyboard(var NumDeriv : integer;
  114.                                    var XDeriv   : TNvector);
  115.  
  116. {------------------------------------------------------------}
  117. {- Output: NumDeriv, XDeriv                                 -}
  118. {-                                                          -}
  119. {- This procedure assigns values to the derivative points   -}
  120. {- from keyboard input                                      -}
  121. {------------------------------------------------------------}
  122.  
  123. var
  124.   Term : integer;
  125.  
  126. begin
  127.   NumDeriv := 0;
  128.   Writeln;
  129.   repeat
  130.     Write('Number of points (0-', TNArraySize, ')? ');
  131.     Readln(NumDeriv);
  132.     IOCheck;
  133.   until((NumDeriv >= 0) and (NumDeriv <= TNArraySize) and not IOerr);
  134.   Writeln;
  135.   for Term := 1 to NumDeriv do
  136.   repeat
  137.     Write('Point ', Term, ': ');
  138.     Readln(XDeriv[Term]);
  139.     IOCheck;
  140.   until not IOerr;
  141. end; { procedure GetOneVectorFromKeyboard }
  142.  
  143. begin
  144.   case InputChannel('Input Derivative Points From') of
  145.     'K' : GetOneVectorFromKeyboard(NumDeriv, XDeriv);
  146.     'F' : GetOneVectorFromFile(NumDeriv, XDeriv);
  147.   end;
  148.   Writeln;
  149. end; { procedure GetDerivPoints }
  150.  
  151. procedure GetTolerance(var Tolerance : Float);
  152.  
  153. {---------------------------------------------------------}
  154. {- Output: Tolerance                                     -}
  155. {-                                                       -}
  156. {- This procedure sets the value of the Tolerance.       -}
  157. {---------------------------------------------------------}
  158.  
  159. begin
  160.   Writeln;
  161.   repeat
  162.     Tolerance := 1E-2;
  163.     Write('Tolerance (> 0)? ');
  164.     ReadFloat(Tolerance);
  165.     IOCheck;
  166.     if Tolerance <= 0 then
  167.     begin
  168.       IOerr := true;
  169.       Tolerance := 1E-2;
  170.     end;
  171.   until not IOerr;
  172. end; { procedure GetTolerance }
  173.  
  174. begin { procedure GetData }
  175.   GetDerivPoints(NumDeriv, XDeriv);
  176.   GetTolerance(Tolerance);
  177.   GetOutputFile(OutFile);
  178. end; { procedure GetData }
  179.  
  180. procedure Results(NumDeriv  : integer;
  181.               var XDeriv    : TNvector;
  182.               var YDeriv    : TNvector;
  183.                   Tolerance : Float;
  184.                   Error     : byte);
  185.  
  186. {------------------------------------------------------------}
  187. {- This procedure outputs the results to the device OutFile -}
  188. {------------------------------------------------------------}
  189.  
  190. var
  191.   Index : integer;
  192.  
  193. begin
  194.   Writeln(OutFile);
  195.   Writeln(OutFile);
  196.   if Error = 1 then
  197.     DisplayError;
  198.  
  199.    case Error of
  200.      0 : begin
  201.            Writeln(OutFile, 'Tolerance = ', Tolerance);
  202.            Writeln(OutFile);
  203.            Writeln(OutFile,'     X               Derivative at X');
  204.            for Index := 1 to NumDeriv do
  205.              Writeln(OutFile, XDeriv[Index] : 8 : 3, ' ' : 10, YDeriv[Index]);
  206.          end;
  207.  
  208.      1 : Writeln(OutFile, 'The tolerance must be greater than zero.');
  209.  
  210.    end;
  211. end; { procedure Results }
  212.  
  213. begin { program FirstDerivative }
  214.   ClrScr;
  215.   Initialize(XDeriv, YDeriv, Tolerance, Error);
  216.   GetData(NumDeriv, XDeriv, Tolerance);
  217.   FirstDerivative(NumDeriv, XDeriv, YDeriv, Tolerance, Error, @TNTargetF);
  218.   Results(NumDeriv, XDeriv, YDeriv, Tolerance, Error);
  219.   Close(OutFile);
  220. end. { program FirstDerivative }
  221.