home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / TURBOPAS / PAS_ENG.ZIP / SIMQ1.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1985-07-19  |  2.4 KB  |  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.