home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / TURBOPAS / PAS_ENG.ZIP / SOLVEC.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1985-07-19  |  3.5 KB  |  175 lines
  1. program solvec;  { -> 119 }
  2. { pascal program to perform simultaneous solution by Gauss-Jordan elimination}
  3. { for complex coefficients }
  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.  aryc2 = array[1..maxr,1..maxc,1..2] of real;
  12.  aryc = array[1..maxr,1..2] of real;
  13.  
  14. var y : arys;
  15.  coef : arys;
  16.  a,b : ary2s;
  17.  n,m,i,j : integer;
  18.  error : boolean;
  19.  
  20.  
  21.  
  22.  
  23. procedure get_data(var a: ary2s;
  24.      var y: arys;
  25.      var n,m: integer);
  26.  
  27. { get complex values for n and arrays a,y }
  28.  
  29. var c : aryc2;
  30.  v : aryc;
  31.  i,j,k,l : integer;
  32.  
  33. procedure show;
  34.  { print original data }
  35. var i,j,k : integer;
  36.  
  37. begin { show }
  38.   writeln;
  39.   for i:=1 to n do
  40.     begin
  41.       for j:=1 to m do
  42.  for k:=1 to 2 do
  43.    write(c[i,j,k]:7:4,' ');
  44.       writeln(':',v[i,1]:7:4,':',v[i,2]:7:4)
  45.     end;
  46.   n:=2*n;
  47.   m:=n;
  48.   writeln;
  49.   for i:=1 to n do
  50.     begin
  51.       for j:=1 to m do
  52.  write(a[i,j]:7:4,' ');
  53.       writeln(':',y[i]:9:5)
  54.     end;
  55.   writeln
  56. end;  { show }
  57.  
  58. begin  { procedure get_data }
  59.   writeln;
  60.   repeat
  61.     write('How many equations? ');
  62.     readln(n);
  63.     m:=n
  64.   until n<maxr;
  65.   if n>1 then
  66.     begin
  67.       for i:=1 to n do
  68.  begin
  69.    writeln('Equation',i:3);
  70.    k:=0;
  71.    l:=2*i-1;
  72.    for j:=1 to n do
  73.      begin
  74.        k:=k+1;
  75.        write('Real',j:3,':');
  76.        read(c[i,j,1]);  { read real part }
  77.        a[l,k]:=c[i,j,1];
  78.        a[l+1,k+1]:=c[i,j,1];
  79.        k:=k+1;
  80.        write('Imag',j:3,':');
  81.        read(c[i,j,2]);  { imaginary part }
  82.        a[l,k]:=-c[i,j,2];
  83.        a[l+1,k-1]:=c[i,j,2]
  84.      end;  { j-loop }
  85.    write('Real const:');
  86.    read(v[i,1]);  { real constant }
  87.    y[l]:=v[i,1];
  88.    write('Imag const:');
  89.    readln(v[i,2]); { imag constant }
  90.    y[l+1]:=v[i,2]
  91.  end;  { i-loop }
  92.       show  { the original DATA }
  93.     end  { if n>1 }
  94. end; { procedure get_data }
  95.  
  96.  
  97. procedure write_data;
  98.  
  99. { print out the answers }
  100.  
  101. var i,j : integer;
  102.  re,im : real;
  103.  
  104. function mag(x,y: real): real;
  105. { polar magnitude }
  106. begin
  107.   mag:=sqrt(sqr(x)+sqr(y))
  108. end; { function mag }
  109.  
  110. function atan(x,y: real): real;
  111. { arctan in degrees }
  112. const pi180 = 57.2957795;
  113. var   a : real;
  114.  
  115. begin { atan }
  116.   if x=0.0 then
  117.     if y=0.0 then atan:=0.0
  118.     else atan:=90.0
  119.   else { x<>0 }
  120.     if y=0.0 then atan:=0.0
  121.   else { x and y <>0 }
  122.     begin
  123.       a:=arctan(abs(y/x))*pi180;
  124.       if x>0.0 then
  125.  if y>0.0 then atan:=a { x,y>0 }
  126.  else atan:=-a  { x>0, y<0 }
  127.       else  { x<0 }
  128.  if y>0.0 then atan:=180.0-a { x<0, y>0 }
  129.  else atan:=180.0+a  { x,y<0 }
  130.   end  { else }
  131. end; { function atan }
  132. begin
  133.   writeln('   REAL    Imaginary  Magnitude Angle');
  134.   for i:=1 to (m div 2) do
  135.     begin
  136.       j:=2*i-1;
  137.       re:=coef[j];
  138.       im:=coef[j+1];
  139.       writeln(re:11:5,im:11:5,mag(re,im):11:5,atan(re,im):11:5)
  140.     end; { for }
  141.    writeln
  142. end;  { write_data }
  143.  
  144.  
  145.  
  146. {external procedure gaussj
  147.  (var  b : ary2s;
  148.   y : arys;
  149.   var      coef : arys;
  150.       ncol : integer;
  151.   var     error : boolean);}
  152.  
  153. {$I GAUSSJ.LIB}
  154.  
  155. begin  { MAIN program }
  156.   clrscr;
  157.   writeln;
  158.   writeln;
  159.   lowvideo;
  160.   writeln('Simultaneous solution with complex coefficients');
  161.   writeln('by Gauss-Jordan elimination');
  162.   normvideo;
  163.   repeat
  164.     get_data(a,y,n,m);
  165.     if n>1 then
  166.       begin
  167.  for i:=1 to n do
  168.    for j:=1 to n do
  169.      b[i,j]:=a[i,j]; { setup work array }
  170.  gaussj(b,y,coef,n,error);
  171.  if not error then write_data
  172.       end
  173.   until n<2
  174. end.
  175.