Получение формы Жордано: form . exe

 

uses wincrt;

label 1;

type mas=array[1..10,1..10]of real;

var A,M,M1,S,R,R1,A1:mas;

 z,max:real;

 f,jj,tt,ww,v,h,b,y,i,j,w,k,e,l,q,x,u,n1:byte;

 p,o:array[1..10]of real;

 t:array [1..10]of boolean;

 

procedure Umnogenie(b,c:mas; n:byte; var v:mas);

var i,j,k:byte;

begin

for i:=1 to n do

 for j:=1 to n do

 begin

 v[i,j]:=0;

 for k:=1 to n do

 v[i,j]:=b[i,k]*c[k,j]+v[i,j];

 end;

end;

 

procedure dan(n:byte; var a:mas);

label 1,2;

var y:byte;

begin

For y:=1 to n-1 do

begin

 if a[1,n]=0 then

 begin

 if y>1 then begin

 max:=abs(a[1,n]);

 w:=1;

 for i:=1 to n-y do

 if abs(a[i,n])>max then begin max:=abs(a[i,j]); w:=i; end;

 

 if max=0 then

 begin

 for l:=n downto n-y+1 do

 begin

 p[f]:=a[l,n];

 t[f]:=false;

 f:=f-1;

 end;

 t[f+1]:=true;

 x:=x+1;

 u:=n-y;

 if y=n-1 then begin o[q]:=a[1,1]; q:=q+1; end else dan(u,a);

 goto 2;

 end;

 

 for j:=1 to n do

 begin

 z:=a[1,j];

 a[1,j]:=a[w,j];

 a[w,j]:=z;

 end;

 

 for k:=1 to n do

 begin

 z:=a[k,1];

 a[k,1]:=a[k,w];

 a[k,w]:=z;

 end;

 goto 1;

 end

 else

 begin

 max:=abs(a[1,2]);

 w:=1;e:=2;

 for i:=1 to n-1 do

 if abs(a[i,n])>max then begin max:=abs(a[i,j]); w:=i; e:=n; end;

 for j:=2 to n do

 if abs(a[1,j])>max then begin max:=abs(a[i,j]); w:=1; e:=j; end;

 if abs(a[n,1])>max then begin max:=abs(a[n,1]); w:=n; e:=1; end;

 if max=0 then

 begin

 o[q]:=a[n,n];

 

 q:=q+1;

 u:=n-1;

 if n=2 then begin o[q]:=a[1,1]; q:=q+1; o[q]:=a[n,n]; q:=q+1; end else dan(u,a);

 goto 2;

 end;

 

 

 if (w>1) and (e=n) then

 begin

 for j:=1 to n do

 begin

 z:=a[1,j];

 a[1,j]:=a[w,j];

 a[w,j]:=z;

 end;

 

 for k:=1 to n do

 begin

 z:=a[k,1];

 a[k,1]:=a[k,w];

 a[k,w]:=z;

 end;

 goto 1;

 end;

 

 if (w=n) and (e=1) then

 begin

 for j:=1 to n do

 begin

 z:=a[1,j];

 a[1,j]:=a[n,j];

 a[n,j]:=z;

 end;

 

 for k:=1 to n do

 begin

 z:=a[k,1];

 a[k,1]:=a[k,n];

 a[k,n]:=z;

 end;

 goto 1;

 end;

 

 if w=1 then

 begin

 for j:=1 to n do

 begin

 z:=a[n,j];

 a[n,j]:=a[e,j];

 a[e,j]:=z;

 end;

 

 for k:=1 to n do

 begin

 z:=a[k,n];

 a[k,n]:=a[k,e];

 a[k,e]:=z;

 end;

 goto 1;

 end;

 

 end;

 

end;

1:

 for i:=1 to n do

 for j:=1 to n do

 if i<>(j+1) then M[i,j]:=0

 else M[i,j]:=1;

 for i:=1 to n do

 for j:=1 to n do

 if (i+1)<>j then M1[i,j]:=0

 else M1[i,j]:=1;

 

 

 for i:=1 to n do

 if i<>n then begin M[i,n]:=a[i,n]; M1[i,1]:=-a[i+1,n]/a[1,n]; end

 else begin M[i,n]:=a[i,n]; M1[i,1]:=1/a[1,n]; end;

 Umnogenie(M1,A,n,S);

 Umnogenie(S,M,n,A);

if y=n-1 then

begin

 for l:=n downto 1 do

 begin

 p[f]:=a[l,n];

 t[f]:=false;

 f:=f-1;

 end;

 t[f+1]:=true;

 x:=x+1;

end;

end;

2:

end;

 

procedure ObrMatr(A:mas;Var AO:mas; n:byte);

 const e=0.00001;

 var i,j:integer;

 a0:mas;

 procedure MultString(var A,AO:mas;i1:integer;r:real);

 var j:integer;

 begin

 for j:=1 to n do

 begin

 A[i1,j]:=A[i1,j]*r;

 AO[i1,j]:=AO[i1,j]*r;

 end;

 end;

 procedure AddStrings(var A,AO:mas;i1,i2:integer;r:real);

 {Процедура прибавляет к i1 строке матрицы a i2-ю умноженную на r}

 var j:integer;

 begin

 for j:=1 to n do

 begin

 A[i1,j]:=A[i1,j]+r*A[i2,j];

 AO[i1,j]:=AO[i1,j]+r*AO[i2,j];

 end;

 end;

 function Sign(r:real):shortint;

 begin

 if (r>=0) then sign:=1

 else sign:=-1;

 end;

 

 begin {начало основной процедуры}

 

 for i:=1 to n do

 for j:=1 to n do

 a0[i,j]:=A[i,j];

 for i:=1 to n do

 begin {К i-той строке прибавляем (или вычитаем)

 j-тую строку взятую со знаком i-того

 элемента j-той строки. Таким образом,

 на месте элемента a[i,i] возникает сумма

 модулей элементов i-того столбца (ниже i-той строки)

 взятая со знаком бывшего элемента a[i,i],

 равенство нулю которой говорит о несуществовании

 обратной матрицы }

 for j:=i+1 to n do

 AddStrings(A,AO,i,j,sign(A[i,i])*sign(A[j,i])); { Прямой ход }

 if (abs(A[i,i])>e) then

 begin

 MultString(a,AO,i,1/A[i,i]);

 for j:=i+1 to n do

 AddStrings(a,AO,j,i,-A[j,i]);

 end

 else begin writeln('Обратной матрицы не существует.');

 halt;

 end

 end;{Обратный ход:}

 if (A[n,n]>e) then begin

 for i:=n downto 1 do

 for j:=1 to i-1 do

 begin

 AddStrings(A,AO,j,i,-A[j,i]);

 end; end

 else writeln('Обратной матрицы не существует.');

 end;

procedure EdMatr(Var E:mas; n:byte);

 var i,j:byte;

 begin

 for i:=1 to n do

 for j:=1 to n do

 if i<>j then E[i,j]:=0 else E[i,i]:=1;

 end;

 

{procedure UmnogMatr(A,F:mas; Var R:mas; n:byte);

 Var s:real;

 l,i,j:byte;

 begin

 for i:=1 to n do

 for j:=1 to n do

 begin

 s:=0;

 for l:=1 to n do

 s:=s+A[i,l]*F[l,j];

 R[i,j]:=s;

 end;

 end; }

 

begin

writeln('Vvedite razmernost` matrici A');

readln(ww);

f:=ww;

n1:=ww;

for i:=1 to ww do

begin

 for j:=1 to ww do

 begin

 write('a[',i,j,']=');

 Readln(A[i,j]);

 A1[i,j]:=A[i,j];

 end;

 

end;

 

q:=1;

x:=0;

dan(ww,a);

 

 

for i:=1 to q-1 do

writeln('Koren` har-ogo ur-iya=',o[i]:2:2);

writeln;

 

i:=ww+1;

 

if (x=1)or(x>1) then

 begin

 for v:=1 to x do

 

 begin

 tt:=0;

 repeat

 tt:=tt+1;

 i:=i-1;

 until t[i]<>false;

 write('l^',tt,' + ');

 for jj:=ww downto i do

 begin

 tt:=tt-1;

 write(-p[jj]:2:2,'*l^',tt,' + ');

 end;

 ww:=i-1;

 writeln;

 end;

 

 end;

 

for i:=1 to n1 do

 begin

 for j:=1 to n1 do

 read(R[i,j]);

 readln;

 end;

 

EdMatr(R1,n1);

ObrMatr(R,R1,n1);

Umnogenie(R1,A1,n1,A);

Umnogenie(A,R,n1,M1);

 

for i:=1 to n1 do

 begin

 for j:=1 to n1 do

 write(' ',M1[i,j]:2:3,' ');

 writeln;

 end;

end.

Анализ программы

 

Протестируем работу программы на примере. Пусть имеем матрицу А

 

 

Характеристический полином имеет вид:

Собственные числа 20.713, 4.545, 2.556, -5.814

 

Собственные векторы , , ,

 

Список используемой литературы

 

Я.М.Григоренко, Н.Д.Панкратова «Обчислювальні методи» 1995р.

В.Д.Гетмнцев «Лінійна алгебра і лінійне програмування» 2001р.

Д.Мак-Кракен, У.Дорн «Программирование на ФОРТРАНЕ» 1997г.

http://alglib.manual.ru/eigen/danilevsky.php

http://doors.infor.ru/allsrs/alg/index.html