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