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