home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / l / l042 / 1.ddi / CHAP4.ARC / INTERDRV.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-12-30  |  10.6 KB  |  299 lines
  1. program Interpolate_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 first and second            -}
  9. {-                    differentiation with a cubic spline interpolant.      -}
  10. {-                                                                          -}
  11. {-           Unit   : Differ    procedure Interpolate_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.   YInter : TNvector;                { Interpolated value at XDeriv }
  28.   YDeriv : TNvector;                { 1st derivative at XDeriv points }
  29.   YDeriv2 : TNvector;               { 2nd derivative at XDeriv points }
  30.   Error : byte;                     { Flags if something went wrong }
  31.  
  32. procedure Initialize(var XData  : TNvector;
  33.                      var YData  : TNvector;
  34.                      var XDeriv : TNvector;
  35.                      var YDeriv : TNvector;
  36.                      var Error  : byte);
  37.  
  38. {-----------------------------------------------------------}
  39. {- Output: XData, YData, XDeriv, YDeriv, Error             -}
  40. {-                                                         -}
  41. {- This procedure initializes the above variables to zero. -}
  42. {-----------------------------------------------------------}
  43.  
  44. begin
  45.   Writeln;
  46.   Error := 0;
  47.   FillChar(XData, SizeOf(XData), 0);
  48.   FillChar(YData, SizeOf(YData), 0);
  49.   FillChar(XDeriv, SizeOf(XDeriv), 0);
  50.   FillChar(YDeriv, SizeOf(YDeriv), 0);
  51. end; { procedure Initialize }
  52.  
  53. procedure GetData(var NumPoints : integer;
  54.                   var NumDeriv  : integer;
  55.                   var XData     : TNvector;
  56.                   var YData     : TNvector;
  57.                   var XDeriv    : TNvector);
  58.  
  59. {------------------------------------------------------------}
  60. {- Output: NumPoints, NumDeriv, XData, YData, XDeriv        -}
  61. {-                                                          -}
  62. {- This procedure assigns values to the above variables     -}
  63. {- from either keyboard or data file input                  -}
  64. {------------------------------------------------------------}
  65.  
  66. procedure GetDataPoints(var NumPoints : integer;
  67.                         var XData     : TNvector;
  68.                         var YData     : TNvector);
  69.  
  70. {------------------------------------------------------------}
  71. {- Output: NumPoints, XData, YData                          -}
  72. {-                                                          -}
  73. {- This procedure assigns values to the data points         -}
  74. {- from either keyboard or data file input                  -}
  75. {------------------------------------------------------------}
  76.  
  77. procedure GetTwoVectorsFromFile(var NumPoints : integer;
  78.                                 var XData     : TNvector;
  79.                                 var YData     : TNvector);
  80.  
  81. {------------------------------------------------------------}
  82. {- Output: NumPoints, XData, YData                          -}
  83. {-                                                          -}
  84. {- This procedure assigns values to the data points         -}
  85. {- from data file input                                     -}
  86. {------------------------------------------------------------}
  87.  
  88. var
  89.   FileName : string[255];
  90.   InFile : text;
  91.  
  92. begin
  93.   Writeln;
  94.   repeat
  95.     Write('File name? ');
  96.     Readln(FileName);
  97.     Assign(InFile, FileName);
  98.     Reset(InFile);
  99.     IOCheck;
  100.   until not IOerr;
  101.   NumPoints := 0;
  102.   while not(EOF(InFile)) do
  103.   begin
  104.     NumPoints := Succ(NumPoints);
  105.     Readln(InFile, XData[NumPoints], YData[NumPoints]);
  106.     IOCheck;
  107.   end;
  108.   Close(InFile);
  109. end; { procedure GetTwoVectorsFromFile }
  110.  
  111. procedure GetTwoVectorsFromKeyboard(var NumPoints : integer;
  112.                                     var XData     : TNvector;
  113.                                     var YData     : TNvector);
  114.  
  115. {------------------------------------------------------------}
  116. {- Output: NumPoints, XData, YData                          -}
  117. {-                                                          -}
  118. {- This procedure assigns values to the data points         -}
  119. {- from keyboard input                                      -}
  120. {------------------------------------------------------------}
  121.  
  122. var
  123.   Term : integer;
  124.  
  125. begin
  126.   NumPoints := 0;
  127.   Writeln;
  128.   repeat
  129.     Write('Number of points (0-', TNArraySize, ')? ');
  130.     Readln(NumPoints);
  131.     IOCheck;
  132.   until ((NumPoints >= 0) and (NumPoints <= TNArraySize) and not IOerr);
  133.   Writeln;
  134.   Write('Input the X and Y values, ');
  135.   Writeln('separated by a space (not a comma):');
  136.   for Term := 1 to NumPoints do
  137.   repeat
  138.     Write('X[', Term, '], Y[', Term, ']:');
  139.     Read(XData[Term], YData[Term]);
  140.     Writeln;
  141.     IOCheck;
  142.   until not IOerr;
  143. end; { procedure GetTwoVectorsFromKeyboard }
  144.  
  145. begin
  146.   case InputChannel('Input Data Points From') of
  147.     'K' : GetTwoVectorsFromKeyboard(NumPoints, XData, YData);
  148.     'F' : GetTwoVectorsFromFile(NumPoints, XData, YData);
  149.   end;
  150.   Writeln;
  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. {------------------------------------------------------------}
  168. {- Output: NumDeriv, XDeriv                                 -}
  169. {-                                                          -}
  170. {- This procedure assigns values to the derivative points   -}
  171. {- from data file input                                     -}
  172. {------------------------------------------------------------}
  173.  
  174. var
  175.   FileName : string[255];
  176.   InFile : text;
  177.  
  178. begin
  179.   Writeln;
  180.   repeat
  181.     Write('File name? ');
  182.     Readln(FileName);
  183.     Assign(InFile, FileName);
  184.     Reset(InFile);
  185.     IOCheck;
  186.   until not IOerr;
  187.   NumDeriv := 0;
  188.   while not(EOF(InFile)) do
  189.   begin
  190.     NumDeriv := Succ(NumDeriv);
  191.     Readln(InFile, XDeriv[NumDeriv]);
  192.     IOCheck;
  193.   end;
  194.   Close(InFile);
  195. end; { procedure GetOneVectorFromFile }
  196.  
  197. procedure GetOneVectorFromKeyboard(var NumDeriv : integer;
  198.                                    var XDeriv   : TNvector);
  199.  
  200. {------------------------------------------------------------}
  201. {- Output: NumDeriv, XDeriv                                 -}
  202. {-                                                          -}
  203. {- This procedure assigns values to the derivative points   -}
  204. {- from keyboard input                                      -}
  205. {------------------------------------------------------------}
  206.  
  207. var
  208.   Term : integer;
  209.  
  210. begin
  211.   NumDeriv := 0;
  212.   Writeln;
  213.   repeat
  214.     Write('Number of derivative points (0-', TNArraySize, ')? ');
  215.     Readln(NumDeriv);
  216.     IOCheck;
  217.   until((NumDeriv >= 0) and (NumDeriv <= TNArraySize) and not IOerr);
  218.   Writeln;
  219.   for Term := 1 to NumDeriv do
  220.   repeat
  221.     Write('Point ', Term, ': ');
  222.     Readln(XDeriv[Term]);
  223.     IOCheck;
  224.   until not IOerr;
  225. end; { procedure GetOneVectorFromKeyboard }
  226.  
  227. begin { procedure GetDerivPoints }
  228.   case InputChannel('Input Derivative Points From') of
  229.     'K' : GetOneVectorFromKeyboard(NumDeriv, XDeriv);
  230.     'F' : GetOneVectorFromFile(NumDeriv, XDeriv);
  231.   end;
  232.   Writeln;
  233. end; { procedure GetDerivPoints }
  234.  
  235. begin { procedure GetData }
  236.   GetDataPoints(NumPoints, XData, YData);
  237.   GetDerivPoints(NumDeriv, XDeriv);
  238.   GetOutputFile(OutFile);
  239. end; { procedure GetData }
  240.  
  241. procedure Results(NumPoints : integer;
  242.               var XData     : TNvector;
  243.               var YData     : TNvector;
  244.                   NumDeriv  : integer;
  245.               var XDeriv    : TNvector;
  246.               var YInter    : TNvector;
  247.               var YDeriv    : TNvector;
  248.               var YDeriv2   : TNvector;
  249.                   Error     : byte);
  250.  
  251. {------------------------------------------------------------}
  252. {- This procedure outputs the results to the device OutFile -}
  253. {------------------------------------------------------------}
  254.  
  255. var
  256.   Index : integer;
  257.  
  258. begin
  259.   Writeln(OutFile);
  260.   Writeln(OutFile);
  261.   Writeln(OutFile, 'Input Data:');
  262.   Writeln(OutFile,'     X                   Y');
  263.   for Index := 1 to NumPoints do
  264.     Writeln(OutFile, XData[Index] : 8 : 3, ' ' : 10, YData[Index] : 12 : 7);
  265.   Writeln(OutFile);
  266.   if Error >= 1 then
  267.     DisplayError;
  268.  
  269.    case Error of
  270.      0 : begin
  271.            Writeln(OutFile, 'Using free cubic spline interpolation: ');
  272.            Writeln(OutFile);
  273.            Writeln(OutFile, '   X', ' ' : 10, 'Value at X', ' ' : 13,
  274.                             '1st Deriv at X', ' ' : 13, '2nd Deriv at X');
  275.            for Index := 1 to NumDeriv do
  276.              Writeln(OutFile, XDeriv[Index] : 6 : 3, ' ' : 3,
  277.                               YInter[Index], ' ' : 3,
  278.                               YDeriv[Index], ' ' : 3,
  279.                               YDeriv2[Index] : 14 : 8);
  280.          end;
  281.  
  282.      1 : Writeln(OutFile, 'The X data points must be unique.');
  283.  
  284.      2 : Writeln(OutFile, 'The data must be in increasing sequential order.');
  285.  
  286.    end; { case }
  287. end; { procedure Results }
  288.  
  289. begin { program Interpolate_Derivative }
  290.   ClrScr;
  291.   Initialize(XData, YData, XDeriv, YDeriv, Error);
  292.   GetData(NumPoints, NumDeriv, XData, YData, XDeriv);
  293.   Interpolate_Derivative(NumPoints, XData, YData, NumDeriv, XDeriv, YInter,
  294.                          YDeriv, YDeriv2, Error);
  295.   Results(NumPoints, XData, YData, NumDeriv, XDeriv, YInter,
  296.           YDeriv, YDeriv2, Error);
  297.   Close(OutFile);
  298. end. { program Interpolate_Derivative }
  299.