home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 September / Simtel20_Sept92.cdr / msdos / turbopas / pas_sci.arc / SIMQ1.PAS < prev    next >
Pascal/Delphi Source File  |  1985-07-21  |  2KB  |  138 lines
  1. program simq1;        { -> 67 }
  2. { pascal program to solve three simultaneous equations by Cramer's rule }
  3.  
  4. const    rmax    = 3;
  5.     cmax    = 3;
  6.  
  7. type    arys    = array[1..cmax] of real;
  8.     ary2s    = array[1..rmax,1..cmax] of real;
  9.  
  10. var    y,coef    : arys;
  11.     a    : ary2s;
  12.     n    : integer;
  13.     yesno    : char;
  14.     error    : boolean;
  15.  
  16.  
  17. procedure get_data(var a: ary2s;
  18.            var y: arys;
  19.            var n: integer);
  20.  
  21. { get the values for n, and arrays a,y }
  22.  
  23. var    i,j    : integer;
  24.  
  25. begin    { procedure get_data }
  26.   writeln;
  27.   n:=rmax;
  28.   for i:=1 to n do
  29.     begin
  30.       writeln(' Equation',i:3);
  31.       for j:=1 to n do
  32.     begin
  33.       write(j:3,':');
  34.       read(a[i,j])
  35.     end;
  36.       write(',C:');
  37.       readln(y[i])
  38.     end;
  39.   writeln;
  40.   for i:=1 to n do
  41.     begin
  42.       for j:=1 to n do
  43.       write(a[i,j]:7:4,' ');
  44.       writeln(':',y[i]:7:4)
  45.     end;
  46.      writeln
  47. end;        { procedure get_data }
  48.  
  49. procedure write_data;
  50.     { print out the answeres }
  51.  
  52. var    i    : integer;
  53.  
  54. begin    { write_data }
  55.   for i:=1 to n do
  56.     write(coef[i]:9:5);
  57.   writeln
  58. end;        { write_data }
  59.  
  60.  
  61. procedure solve(a: ary2s;
  62.         y: arys;
  63.      var coef: arys;
  64.         n: integer;
  65.     var error: boolean);
  66.  
  67. var
  68.     b    : ary2s;
  69.     i,j    : integer;
  70.     det    : real;
  71.  
  72.  
  73.  
  74. function deter(a: ary2s): real;
  75. { pascal program to calculate the determinant of a 3-by-3matrix }
  76.  
  77. var
  78.     sum    : real;
  79.  
  80. begin    { function deter }
  81.   sum:=a[1,1]*(a[2,2]*a[3,3]-a[3,2]*a[2,3])
  82.     -a[1,2]*(a[2,1]*a[3,3]-a[3,1]*a[2,3])
  83.     +a[1,3]*(a[2,1]*a[3,2]-a[3,1]*a[2,2]);
  84.   deter:=sum
  85. end;    { function deter }
  86.  
  87.  
  88.  
  89. procedure setup(var b: ary2s;
  90.          var coef: arys;
  91.             j: integer);
  92.  
  93. var    i    : integer;
  94.  
  95. begin    { setup }
  96.   for i:=1 to n do
  97.     begin
  98.       b[i,j]:=y[i];
  99.       if j>1 then b[i,j-1]:=a[i,j-1]
  100.     end;
  101.   coef[j]:=deter(b)/det
  102. end;    { setup }
  103.  
  104. begin        { procedure solve }
  105.   error:=false;
  106.   for i:=1 to n do
  107.     for j:=1 to n do
  108.       b[i,j]:=a[i,j];
  109.   det:=deter(b);
  110.   if det=0.0 then
  111.     begin
  112.       error:=true;
  113.       writeln(chr(7),'ERROR: matrix is singular.')
  114.     end
  115.   else
  116.     begin
  117.       setup(b,coef,1);
  118.       setup(b,coef,2);
  119.       setup(b,coef,3);
  120.     end    { else }
  121. end;    {procedure solve }
  122.  
  123.  
  124. begin        { MAIN program }
  125.   ClrScr;
  126.   writeln;
  127.   writeln('Simultaneous solution by Cramers rule');
  128.   repeat
  129.     get_data(a,y,n);
  130.     solve(a,y,coef,n,error);
  131.     if not error then write_data;
  132.     writeln;
  133.     write('More?');
  134.     readln(yesno);
  135.     ClrScr
  136.   until(yesno<>'Y')and(yesno<>'y')
  137. end.
  138.