home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / l / l042 / 1.ddi / CHAP4.ARC / DERIV.PAS next >
Encoding:
Pascal/Delphi Source File  |  1987-12-30  |  11.6 KB  |  332 lines
  1. program First_Derivative_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 2, 3 and 5 point            -}
  9. {-                    differentiation.                                      -}
  10. {-                                                                          -}
  11. {-           Unit   : Differ    procedure First_Derivative                  -}
  12. {-                                                                          -}
  13. {----------------------------------------------------------------------------}
  14.  
  15. {$I-}      { Disable I/O error trapping }
  16. {$R+}      { Enable range checking }
  17.  
  18. uses
  19.   Differ, Dos, Crt, Common;
  20.  
  21. var
  22.   XData, YData : TNvector;          { Data points (X,Y) }
  23.   NumPoints : integer;              { Number of data points }
  24.   NumDeriv : integer;               { Number of points at which }
  25.                                     { to find derivative }
  26.   XDeriv : TNvector;                { Values at which to differentiate }
  27.   YDeriv : TNvector;                { 1st derivative at XDeriv points }
  28.   Point : integer;                  { 2, 3, or 5 point differentiation }
  29.   Error : byte;                     { Flags if something went wrong }
  30.  
  31. procedure Initialize(var XData        : TNvector;
  32.                      var YData        : TNvector;
  33.                      var XDeriv       : TNvector;
  34.                      var YDeriv       : TNvector;
  35.                      var Point        : integer;
  36.                      var Error        : byte);
  37.  
  38. {-----------------------------------------------------------}
  39. {- Output: XData, YData, XDeriv, YDeriv, Point, Error      -}
  40. {-                                                         -}
  41. {- This procedure initializes the above variables to zero. -}
  42. {-----------------------------------------------------------}
  43.  
  44. begin
  45.   Writeln;
  46.   Point := 0;
  47.   Error := 0;
  48.   FillChar(XData, SizeOf(XData), 0);
  49.   FillChar(YData, SizeOf(YData), 0);
  50.   FillChar(XDeriv, SizeOf(XDeriv), 0);
  51.   FillChar(YDeriv, SizeOf(YDeriv), 0);
  52. end; { procedure Initialize }
  53.  
  54. procedure GetData(var NumPoints : integer;
  55.                   var NumDeriv  : integer;
  56.                   var XData     : TNvector;
  57.                   var YData     : TNvector;
  58.                   var XDeriv    : TNvector;
  59.                   var Point     : integer);
  60.  
  61. {------------------------------------------------------------}
  62. {- Output: NumPoints, NumDeriv, XData, YData, XDeriv, Point -}
  63. {-                                                          -}
  64. {- This procedure assigns values to the above variables     -}
  65. {- from either keyboard or data file input                  -}
  66. {------------------------------------------------------------}
  67.  
  68. procedure GetDataPoints(var NumPoints : integer;
  69.                         var XData     : TNvector;
  70.                         var YData     : TNvector);
  71.  
  72. {------------------------------------------------------------}
  73. {- Output: NumPoints, XData, YData                          -}
  74. {-                                                          -}
  75. {- This procedure assigns values to the data points         -}
  76. {- from either keyboard or data file input                  -}
  77. {------------------------------------------------------------}
  78.  
  79. procedure GetTwoVectorsFromFile(var NumPoints : integer;
  80.                                 var XData     : TNvector;
  81.                                 var YData     : TNvector);
  82.  
  83. {------------------------------------------------------------}
  84. {- Output: NumPoints, XData, YData                          -}
  85. {-                                                          -}
  86. {- This procedure assigns values to the data points         -}
  87. {- from data file input                                     -}
  88. {------------------------------------------------------------}
  89.  
  90. var
  91.   FileName : string[255];
  92.   InFile : text;
  93. begin
  94.   Writeln;
  95.   repeat
  96.     Write('File name? ');
  97.     Readln(FileName);
  98.     Assign(InFile, FileName);
  99.     Reset(InFile);
  100.     IOCheck;
  101.   until not IOerr;
  102.   NumPoints := 0;
  103.   while not(EOF(InFile)) do
  104.   begin
  105.     NumPoints := Succ(NumPoints);
  106.     Readln(InFile, XData[NumPoints], YData[NumPoints]);
  107.     IOCheck;
  108.   end;
  109.   Close(InFile);
  110. end; { procedure GetTwoVectorsFromFile }
  111.  
  112. procedure GetTwoVectorsFromKeyboard(var NumPoints : integer;
  113.                                     var XData     : TNvector;
  114.                                     var YData     : TNvector);
  115.  
  116. {------------------------------------------------------------}
  117. {- Output: NumPoints, XData, YData                          -}
  118. {-                                                          -}
  119. {- This procedure assigns values to the data points         -}
  120. {- from keyboard input                                      -}
  121. {------------------------------------------------------------}
  122.  
  123. var
  124.   Term : integer;
  125.  
  126. begin
  127.   NumPoints := 0;
  128.   Writeln;
  129.   repeat
  130.     Write('Number of points (0-', TNArraySize, ')? ');
  131.     Readln(NumPoints);
  132.     IOCheck;
  133.   until ((NumPoints >= 0) and (NumPoints <= TNArraySize) and not IOerr);
  134.   Writeln;
  135.   Write('Input the X and Y values,');
  136.   Writeln(' separated by a space (not a comma):');
  137.   for Term := 1 to NumPoints do
  138.   repeat
  139.     Write('X[', Term, '], Y[', Term, ']: ');
  140.     Read(XData[Term], YData[Term]);
  141.     Writeln;
  142.     IOCheck;
  143.   until not IOerr;
  144. end; { procedure GetTwoVectorsFromKeyboard }
  145.  
  146. begin
  147.   case InputChannel('Input Data Points From') of
  148.     'K' : GetTwoVectorsFromKeyboard(NumPoints, XData, YData);
  149.     'F' : GetTwoVectorsFromFile(NumPoints, XData, YData);
  150.   end;
  151. end; { procedure GetDataPoints }
  152.  
  153. procedure GetDerivPoints(var NumDeriv : integer;
  154.                          var XDeriv   : TNvector);
  155.  
  156. {------------------------------------------------------------}
  157. {- Output: NumDeriv, XDeriv                                 -}
  158. {-                                                          -}
  159. {- This procedure assigns values to the derivative points   -}
  160. {- from either keyboard or data file input                  -}
  161. {------------------------------------------------------------}
  162.  
  163. procedure GetOneVectorFromFile(var NumDeriv : integer;
  164.                                var XDeriv   : TNvector);
  165.  
  166. {------------------------------------------------------------}
  167. {- Output: NumDeriv, XDeriv                                 -}
  168. {-                                                          -}
  169. {- This procedure assigns values to the derivative points   -}
  170. {- from data file input                                     -}
  171. {------------------------------------------------------------}
  172.  
  173. var
  174.   FileName : string[255];
  175.   InFile : text;
  176. begin
  177.   Writeln;
  178.   repeat
  179.     Write('File name? ');
  180.     Readln(FileName);
  181.     Assign(InFile, FileName);
  182.     Reset(InFile);
  183.     IOCheck;
  184.   until not IOerr;
  185.   NumDeriv := 0;
  186.   while not(EOF(InFile)) do
  187.   begin
  188.     NumDeriv := Succ(NumDeriv);
  189.     Readln(InFile, XDeriv[NumDeriv]);
  190.     IOCheck;
  191.   end;
  192.   Close(InFile);
  193. end; { procedure GetOneVectorFromFile }
  194.  
  195. procedure GetOneVectorFromKeyboard(var NumDeriv : integer;
  196.                                    var XDeriv   : TNvector);
  197.  
  198. {------------------------------------------------------------}
  199. {- Output: NumDeriv, XDeriv                                 -}
  200. {-                                                          -}
  201. {- This procedure assigns values to the derivative points   -}
  202. {- from keyboard input                                      -}
  203. {------------------------------------------------------------}
  204.  
  205. var
  206.   Term : integer;
  207.  
  208. begin
  209.   NumDeriv := 0;
  210.   Writeln;
  211.   repeat
  212.     Write('Number of X values (0-', TNArraySize, ')? ');
  213.     Readln(NumDeriv);
  214.     IOCheck;
  215.   until((NumDeriv >= 0) and (NumDeriv <= TNArraySize) and not IOerr);
  216.   Writeln;
  217.   for Term := 1 to NumDeriv do
  218.   repeat
  219.     Write('Point ', Term, ': ');
  220.     Readln(XDeriv[Term]);
  221.     IOCheck;
  222.   until not IOerr;
  223. end; { procedure GetOneVectorFromKeyboard }
  224.  
  225. var
  226.   Ch : char;
  227.  
  228. begin
  229.   case InputChannel('Input Derivative Points From') of
  230.     'K' : GetOneVectorFromKeyboard(NumDeriv, XDeriv);
  231.     'F' : GetOneVectorFromFile(NumDeriv, XDeriv);
  232.   end;
  233. end; { procedure GetDerivPoints }
  234.  
  235. procedure GetPoint(var Point : integer);
  236.  
  237. {---------------------------------------------------------}
  238. {- Output: Point                                         -}
  239. {-                                                       -}
  240. {- This procedure sets the value of Point which          -}
  241. {- determines which differentiation formula will be used -}
  242. {---------------------------------------------------------}
  243.  
  244. begin
  245.   Writeln;
  246.   repeat
  247.     Point := 5;
  248.     Write('2, 3 or 5 point differentiation ? ');
  249.     ReadInt(Point);
  250.     IOCheck;
  251.     if not(Point in [2, 3, 5]) then
  252.     begin
  253.       IOerr := true;
  254.       Point := 5;
  255.     end;
  256.   until not IOerr;
  257. end; { procedure GetPoint }
  258.  
  259. begin { procedure GetData }
  260.   GetDataPoints(NumPoints, XData, YData);
  261.   GetDerivPoints(NumDeriv, XDeriv);
  262.   GetPoint(Point);
  263.   GetOutputFile(OutFile);
  264. end; { procedure GetData }
  265.  
  266. procedure Results(NumPoints : integer;
  267.               var XData     : TNvector;
  268.               var YData     : TNvector;
  269.                   NumDeriv  : integer;
  270.               var XDeriv    : TNvector;
  271.               var YDeriv    : TNvector;
  272.                   Point     : integer);
  273.  
  274. {------------------------------------------------------------}
  275. {- This procedure outputs the results to the device OutFile -}
  276. {------------------------------------------------------------}
  277.  
  278. var
  279.   Index : integer;
  280.  
  281. begin
  282.   Writeln(OutFile);
  283.   Writeln(OutFile);
  284.   Writeln(OutFile, 'Input Data:');
  285.   Writeln(OutFile, '     X                        Y');
  286.   for Index := 1 to NumPoints do
  287.     Writeln(OutFile, XData[Index] : 12 : 7, ' ' : 10, YData[Index]);
  288.   Writeln(OutFile);
  289.   if Error = 1 then
  290.     DisplayWarning;
  291.   if Error >= 2 then
  292.     DisplayError;
  293.   case Error of
  294.     0, 1 : begin
  295.              Writeln(OutFile, 'Using ', Point, ' point differentiation:');
  296.              Writeln(OutFile);
  297.              Writeln(OutFile, '     X                 Derivative at X');
  298.              for Index := 1 to NumDeriv do
  299.              begin
  300.                Write(OutFile, XDeriv[Index] : 8 : 3, ' ' : 10);
  301.                if ABS(YDeriv[Index]) >= 9.999999E35 then
  302.                  Writeln(OutFile, 'No derivative calculated')
  303.                else
  304.                  Writeln(OutFile, YDeriv[Index]);
  305.              end;
  306.            end;
  307.  
  308.     2 : Writeln(OutFile, 'The X data points must be unique.');
  309.  
  310.     3 : Writeln(OutFile, 'The data must be in increasing sequential order.');
  311.  
  312.     4 : Writeln(OutFile, 'There are too few data points to do ',
  313.                           Point, ' point differentiation.');
  314.  
  315.     5 : Writeln(OutFile, 'There is no ', Point, ' point differentiation.');
  316.  
  317.     6 : Writeln(OutFile,
  318.                 'The data must be evenly spaced for 5 point differentiation.');
  319.  
  320.   end; { case }
  321. end; { procedure Results }
  322.  
  323. begin  { program First_Derivative }
  324.   ClrScr;
  325.   Initialize(XData, YData, XDeriv, YDeriv, Point, Error);
  326.   GetData(NumPoints, NumDeriv, XData, YData, XDeriv, Point);
  327.   First_Derivative(NumPoints, XData, YData, Point, NumDeriv, XDeriv,
  328.                    YDeriv, Error);
  329.   Results(NumPoints, XData, YData, NumDeriv, XDeriv, YDeriv, Point);
  330.   Close(OutFile);
  331. end. { program First_Derivative }
  332.