home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / l / l042 / 1.ddi / CHAP4.ARC / DERIV2.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-12-30  |  11.6 KB  |  335 lines
  1. program Second_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 3 and 5 point               -}
  9. {-                    second differentiation.                               -}
  10. {-                                                                          -}
  11. {-           Unit   : Differ    procedure Second_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;                  { 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.  
  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.   NumPoints := 0;
  104.   while not(EOF(InFile)) do
  105.   begin
  106.     NumPoints := Succ(NumPoints);
  107.     Readln(InFile, XData[NumPoints], YData[NumPoints]);
  108.     IOCheck;
  109.   end;
  110.   Close(InFile);
  111. end; { procedure GetTwoVectorsFromFile }
  112.  
  113. procedure GetTwoVectorsFromKeyboard(var NumPoints : integer;
  114.                                     var XData     : TNvector;
  115.                                     var YData     : TNvector);
  116.  
  117. {------------------------------------------------------------}
  118. {- Output: NumPoints, XData, YData                          -}
  119. {-                                                          -}
  120. {- This procedure assigns values to the data points         -}
  121. {- from keyboard input                                      -}
  122. {------------------------------------------------------------}
  123.  
  124. var
  125.   Term : integer;
  126.  
  127. begin
  128.   NumPoints := 0;
  129.   Writeln;
  130.   repeat
  131.     Write('Number of points (0-', TNArraySize, ')? ');
  132.     Readln(NumPoints);
  133.     IOCheck;
  134.   until (NumPoints >= 0) and (NumPoints <= TNArraySize) and (not IOerr);
  135.   Writeln;
  136.   Write('Input the X and Y values, ');
  137.   Writeln('separated by a space (not a comma):');
  138.   for Term := 1 to NumPoints do
  139.   repeat
  140.     Write('X[', Term, '], Y[', Term, ']:');
  141.     Read(XData[Term], YData[Term]);
  142.     Writeln;
  143.     IOCheck;
  144.   until not IOerr;
  145. end; { procedure GetTwoVectorsFromKeyboard }
  146.  
  147. begin { procedure GetDataPoints }
  148.   case InputChannel('Input Data Points From') of
  149.     'K' : GetTwoVectorsFromKeyboard(NumPoints, XData, YData);
  150.     'F' : GetTwoVectorsFromFile(NumPoints, XData, YData);
  151.   end;
  152.   Writeln;
  153. end; { procedure GetDataPoints }
  154.  
  155. procedure GetDerivPoints(var NumDeriv : integer;
  156.                          var XDeriv   : TNvector);
  157.  
  158. {------------------------------------------------------------}
  159. {- Output: NumDeriv, XDeriv                                 -}
  160. {-                                                          -}
  161. {- This procedure assigns values to the derivative points   -}
  162. {- from either keyboard or data file input                  -}
  163. {------------------------------------------------------------}
  164.  
  165. procedure GetOneVectorFromFile(var NumDeriv : integer;
  166.                                var XDeriv   : TNvector);
  167.  
  168. {------------------------------------------------------------}
  169. {- Output: NumDeriv, XDeriv                                 -}
  170. {-                                                          -}
  171. {- This procedure assigns values to the derivative points   -}
  172. {- from data file input                                     -}
  173. {------------------------------------------------------------}
  174.  
  175. var
  176.   FileName : string[255];
  177.   InFile : text;
  178.  
  179. begin
  180.   Writeln;
  181.   repeat
  182.     Write('File name? ');
  183.     Readln(FileName);
  184.     Assign(InFile, FileName);
  185.     Reset(InFile);
  186.     IOCheck;
  187.   until not IOerr;
  188.   NumDeriv := 0;
  189.   while not(EOF(InFile)) do
  190.   begin
  191.     NumDeriv := Succ(NumDeriv);
  192.     Readln(InFile, XDeriv[NumDeriv]);
  193.     IOCheck;
  194.   end;
  195.   Close(InFile);
  196. end; { procedure GetOneVectorFromFile }
  197.  
  198. procedure GetOneVectorFromKeyboard(var NumDeriv : integer;
  199.                                   var XDeriv    : TNvector);
  200.  
  201. {------------------------------------------------------------}
  202. {- Output: NumDeriv, XDeriv                                 -}
  203. {-                                                          -}
  204. {- This procedure assigns values to the derivative points   -}
  205. {- from keyboard input                                      -}
  206. {------------------------------------------------------------}
  207.  
  208. var
  209.   Term : integer;
  210.  
  211. begin
  212.   NumDeriv := 0;
  213.   Writeln;
  214.   repeat
  215.     Write('Number of X values (0-', TNArraySize, ')? ');
  216.     Readln(NumDeriv);
  217.     IOCheck;
  218.   until (NumDeriv >= 0) and (NumDeriv <= TNArraySize) and (not IOerr);
  219.   Writeln;
  220.   for Term := 1 to NumDeriv do
  221.     repeat
  222.       Write('Point ', Term, ': ');
  223.       Readln(XDeriv[Term]);
  224.       IOCheck;
  225.     until not IOerr;
  226. end; { procedure GetOneVectorFromKeyboard }
  227.  
  228. begin
  229.   case InputChannel('Input Derivative Points From') of
  230.     'K' : GetOneVectorFromKeyboard(NumDeriv, XDeriv);
  231.     'F' : GetOneVectorFromFile(NumDeriv, XDeriv);
  232.   end;
  233.   Writeln;
  234. end;  { procedure GetDerivPoints }
  235.  
  236. procedure GetPoint(var Point : integer);
  237.  
  238. {---------------------------------------------------------}
  239. {- Output: Point                                         -}
  240. {-                                                       -}
  241. {- This procedure sets the value of Point which          -}
  242. {- determines which differentiation formula will be used -}
  243. {---------------------------------------------------------}
  244.  
  245. begin
  246.   Writeln;
  247.   repeat
  248.     Point := 5;
  249.     Write('3 or 5 point second differentiation ? ');
  250.     ReadInt(Point);
  251.     IOCheck;
  252.     if not(Point in [3, 5]) then
  253.     begin
  254.       IOerr := true;
  255.       Point := 5;
  256.     end;
  257.   until not IOerr;
  258. end; { procedure GetPoint }
  259.  
  260. begin { procedure GetData }
  261.   GetDataPoints(NumPoints, XData, YData);
  262.   GetDerivPoints(NumDeriv, XDeriv);
  263.   GetPoint(Point);
  264.   GetOutputFile(OutFile);
  265. end; { procedure GetData }
  266.  
  267. procedure Results(NumPoints : integer;
  268.               var XData     : TNvector;
  269.               var YData     : TNvector;
  270.                   NumDeriv  : integer;
  271.               var XDeriv    : TNvector;
  272.               var YDeriv    : TNvector;
  273.                   Point     : integer);
  274.  
  275. {------------------------------------------------------------}
  276. {- This procedure outputs the results to the device OutFile -}
  277. {------------------------------------------------------------}
  278.  
  279. var
  280.   Index : integer;
  281.  
  282. begin
  283.   Writeln(OutFile);
  284.   Writeln(OutFile);
  285.   Writeln(OutFile, 'Input Data:');
  286.   Writeln(OutFile, '     X                     Y');
  287.   for Index := 1 to NumPoints do
  288.     Writeln(OutFile, XData[Index] : 12 : 7, ' ' : 10, YData[Index]);
  289.   Writeln(OutFile);
  290.   if Error = 1 then
  291.     DisplayWarning;
  292.   if Error >= 2 then
  293.     DisplayError;
  294.  
  295.   case Error of
  296.     0, 1 : begin
  297.              Writeln(OutFile, 'Using ',Point,
  298.                               ' point second differentiation:');
  299.              Writeln(OutFile);
  300.              Writeln(OutFile, '     X            Second Derivative at X');
  301.              for Index := 1 to NumDeriv do
  302.              begin
  303.                Write(OutFile, XDeriv[Index] : 8 : 3, ' ' : 10);
  304.                if ABS(YDeriv[Index]) >= 9.999999E35 then
  305.                  Writeln(OutFile, 'No 2nd derivative calculated.')
  306.                else
  307.                  Writeln(OutFile, YDeriv[Index]);
  308.              end;
  309.            end;
  310.  
  311.     2 : Writeln(OutFile, 'The X data points must be unique.');
  312.  
  313.     3 : Writeln(OutFile, 'The data must be in increasing sequential order.');
  314.  
  315.     4 : Writeln(OutFile, 'There are too few data points for ', Point,
  316.                          ' point differentiation.');
  317.  
  318.     5 : Writeln(OutFile, 'There is no ', Point, ' point differentiation.');
  319.  
  320.     6 : Writeln(OutFile,
  321.                 'The data must be evenly spaced for second differentiation.');
  322.  
  323.   end; { case }
  324. end; { procedure Results }
  325.  
  326. begin { program Second_Derivative }
  327.   ClrScr;
  328.   Initialize(XData, YData, XDeriv, YDeriv, Point, Error);
  329.   GetData(NumPoints, NumDeriv, XData, YData, XDeriv, Point);
  330.   Second_Derivative(NumPoints, XData, YData, Point, NumDeriv, XDeriv,
  331.                     YDeriv, Error);
  332.   Results(NumPoints, XData, YData, NumDeriv, XDeriv, YDeriv, Point);
  333.   Close(OutFile);
  334. end. { program Second_Derivative }
  335.