home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / TURBOPAS / PAS_ENG.ZIP / GAUSS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1985-07-19  |  3.1 KB  |  168 lines
  1. program gaus; { -> 75 }
  2. { pascal program to perform simultaneous solution by Gaussian elimination }
  3. { procedure GAUSS is included }
  4.  
  5. const maxr = 8;
  6.  maxc = 8;
  7.  
  8. type ary = array[1..maxr] of real;
  9.  arys = array[1..maxc] of real;
  10.  ary2s = array[1..maxr,1..maxc] of real;
  11.  
  12. var y : arys;
  13.  coef : arys;
  14.  a : ary2s;
  15.  n,m : integer;
  16.  first,
  17.  error : boolean;
  18.  
  19.  
  20. procedure get_data(var a: ary2s;
  21.      var y: arys;
  22.    var n,m: integer);
  23.  
  24. { get values for n and arrays a,y }
  25.  
  26. var i,j : integer;
  27.  
  28. begin
  29.   writeln;
  30.   repeat
  31.     write('How many equations? ');
  32.     readln(n);
  33.     if not first then clrscr else first:=false;
  34.     m:=n
  35.   until n<maxr;
  36.   if n>1 then
  37.     begin
  38.       for i:=1 to n do
  39.  begin
  40.    writeln('Equation',i:3);
  41.    for j:=1 to n do
  42.      begin
  43.        write(j:3,':');
  44.        read(a[i,j])
  45.      end;
  46.    write(',C:');
  47.    read(y[i]);
  48.    readln { clear line }
  49.  end;
  50.       writeln;
  51.       for i:=1 to n do
  52.  begin
  53.    for j:=1 to m do
  54.      write(a[i,j]:7:4);
  55.    writeln(':',y[i]:7:4)
  56.  end;
  57.      writeln
  58.     end  { if n>1 }
  59. end; { procedure get_data}
  60.  
  61. procedure write_data;
  62.  { print out the answeres }
  63.  
  64. var i : integer;
  65.  
  66. begin
  67.   for i:=1 to m do
  68.     write(coef[i]:9:5);
  69.   writeln
  70. end;  { write_data }
  71.  
  72. procedure gauss
  73.         (a : ary2s;
  74.   y : arys;
  75.      var coef : arys;
  76.   ncol : integer;
  77.      var error : boolean);
  78.  
  79. { matrix solution by Gaussian Elimination }
  80.  
  81. var
  82.  b : ary2s; { work array, nrow,ncol }
  83.  w : arys;  { work array, ncol long }
  84.  i,j,i1,k,
  85.  l,n : integer;
  86.  hold,sum,
  87.  t,ab,big: real;
  88.  
  89. begin
  90.   error:=false;
  91.   n:=ncol;
  92.   for i:=1 to n do
  93.     begin { copy to work arrays }
  94.       for j:=1 to n do
  95.  b[i,j]:=a[i,j];
  96.       w[i]:=y[i]
  97.     end;
  98.   for i:=1 to n-1 do
  99.     begin
  100.       big:=abs(b[i,i]);
  101.       l:=i;
  102.       i1:=i+1;
  103.       for j:=i1 to n do
  104.  begin  { search for largest element }
  105.    ab:=abs(b[j,i]);
  106.    if ab>big then
  107.      begin
  108.        big:=ab;
  109.        l:=j
  110.      end
  111.          end;
  112.     if big=0.0 then error:= true
  113.     else
  114.       begin
  115.  if l<>i then
  116.    begin
  117.      { interchange rows to put largest element on diagonal }
  118.      for j:=1 to n do
  119.        begin
  120.   hold:=b[l,j];
  121.   b[l,j]:=b[i,j];
  122.   b[i,j]:=hold
  123.        end;
  124.        hold:=w[l];
  125.        w[l]:=w[i];
  126.        w[i]:=hold
  127.      end; { if l<>i }
  128.    for j:=i1 to n do
  129.      begin
  130.        t:=b[j,i]/b[i,i];
  131.        for k:=i1 to n do
  132.   b[j,k]:=b[j,k]-t*b[i,k];
  133.        w[j]:=w[j]-t*w[i]
  134.      end { j-loop }
  135.    end { if big }
  136.  end; { i-loop }
  137.       if b[n,n]=0.0 then error:=true
  138.       else
  139.  begin
  140.    coef[n]:=w[n]/b[n,n];
  141.    i:=n-1;
  142.    { back substitution }
  143.    repeat
  144.      sum:=0.0;
  145.      for j:=i+1 to n do
  146.        sum:=sum+b[i,j]*coef[j];
  147.      coef[i]:=(w[i]-sum)/b[i,i];
  148.      i:=i-1
  149.    until i=0
  150.  end; { if b[n,n]=0 }
  151.       if error then writeln(chr(7),'ERROR: Matrix is singular')
  152. end; { GAUSS }
  153.  
  154. begin  { MAIN }
  155.   first:=true;
  156.   clrscr;
  157.   writeln;
  158.   writeln('Simultaneous solution by Gauss elimination');
  159.   repeat
  160.     get_data(a,y,n,m);
  161.     if n>1 then
  162.       begin
  163.  gauss(a,y,coef,n,error);
  164.  if not error then write_data
  165.       end
  166.   until n<2
  167. end.
  168.