home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 December / simtel1292_SIMTEL_1292_Walnut_Creek.iso / msdos / turbopas / pas_sci.arc / SOLVGJ2.PAS < prev    next >
Pascal/Delphi Source File  |  1985-07-22  |  2KB  |  109 lines
  1. program solvgj2;        { -> 111 }
  2. { pascal program to perform simultaneous solution by Gauss-Jordan elimination}
  3. { there may be more equations than unknowns }
  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.     ary2    = ary2s;    { for square }
  12.  
  13. var    y    : ary;
  14.     coef,yy    : arys;
  15.     a,b    : ary2s;
  16.     n,m,i,j    : integer;
  17.     first,
  18.     error    : boolean;
  19.  
  20.  
  21. procedure get_data(var a: ary2s;
  22.            var y: ary;
  23.            var n,m: integer);
  24.  
  25. { get the values for n and arrays a,y }
  26.  
  27. var    i,j    : integer;
  28.  
  29. begin
  30.   writeln;
  31.   repeat
  32.     write('How many unknowns? ');
  33.     readln(m);
  34.     if first then first:=false else ClrScr;
  35.   until m<maxc;
  36.   if m>1 then
  37.     begin
  38.       repeat
  39.     write('How many equations? ');
  40.     readln(n)
  41.       until n>=m;
  42.     for i:=1 to n do
  43.     begin
  44.       writeln('Equation',i:3);
  45.       for j:=1 to m do
  46.         begin
  47.           write(j:3,':');
  48.           read(a[i,j])
  49.         end;
  50.       write(',C:');
  51.       readln(y[i])    { clear line }
  52.     end;    { i-loop }
  53.       writeln;
  54.       for i:=1 to n do
  55.     begin
  56.       for j:=1 to m do
  57.         write(a[i,j]:7:4,' ');
  58.       writeln(':',y[i]:7:4)
  59.     end;
  60.       writeln
  61.     end        { if n>1 }
  62. end;    { procedure get_data }
  63.  
  64. procedure write_data;
  65.  
  66. { print out the answers }
  67.  
  68. var    i    : integer;
  69.  
  70. begin
  71.   for i:=1 to m do
  72.     write(coef[i]:9:5);
  73.   writeln
  74. end;    { write_data }
  75.  
  76. {external procedure square
  77.  (        y : ary;
  78.   var        a : ary2s;
  79.   var        g : arys;
  80.     nrow,ncol : integer);}
  81.  
  82. {$I C:SQUARE.LIB}
  83.  
  84. {external procedure gaussj
  85.  (var        b : ary2s;
  86.         y : arys;
  87.   var         coef : arys;
  88.          ncol : integer;
  89.   var        error : boolean);}
  90.  
  91. {$I C:GAUSSJ.LIB}
  92.  
  93. begin        { MAIN program }
  94.   first:=true;
  95.   ClrScr;
  96.   writeln;
  97.   writeln('Best fit to simultaneous equations');
  98.   writeln('By Gauss-Jordan');
  99.   repeat
  100.     get_data(a,y,n,m);
  101.     if m>1 then
  102.       begin
  103.     square(a,y,b,yy,n,m);
  104.     gaussj(b,yy,coef,m,error);
  105.     if not error then write_data
  106.       end
  107.   until m<2
  108. end.
  109.