PROGRAMMES EN LANGAGE PASCALE

PROJET ANALYSE NUMÉRIQUE SYSTEM ES LINÉAIRE

(GAUSS - GAUSS SEIDEL - GAUSS JORDAN- GR AMER)

 program sustemelineaire;
{ programme du pacale pour une perfexion de la solution }
{ de Gauss-Seidel aussi l'elimination de Gauss et la MEthode de gramer }
{ il est inclue la procedure SEID }
uses crt;

const maxr = 43;
rmax = 3;
cmax = 3;
maxc = 43;
type
tab1 = array[1..maxr] of real;
tab2 = array[1..maxr,1..maxr] of real;
arys = array[1..cmax] of real;
ary2s = array[1..rmax,1..cmax] of real;


var
n,m : integer;
first,
error : boolean;
t,y : tab1;
coeff,coef: tab1;
z,a : tab2;

p,erreur : boolean;
b : tab2;
i,j : integer;
tt,cof : arys;
k : ary2s;

yesno : char;

procedure menu; {cette procedure est un menu du programme}

begin
clrscr;
gotoxy(40,40); write('HISTORIQUE=H' );
gotoxy(7,6); writeln('Programme principale des methode pour resoudre un systeme lineaire ');
gotoxy(22,10); writeln('1: M‚thode de Gauss............');
gotoxy(22,12); writeln('2: M‚thode de Gauss-Seidel.....');
gotoxy(22,14); writeln('3: M‚thode de Gauss jordant....');
gotoxy(22,16); writeln('4: M‚thode de gramer ordre 3...');
gotoxy(22,18); writeln('5: Exit........................');
gotoxy(30,20); write('Votre choix (1/2/3/4/5):');

end; {fin du menu}



procedure saisir(var k: ary2s;
var tt: arys;
var n: integer);

{ Entrez les valeure de la matrice k et tt }

var i,j : integer;

begin { procedure saisir }
writeln;
n:=rmax;
for i:=1 to n do
begin
writeln(' Equation',i:3);
for j:=1 to n do
begin
write(j:3,':');
read(k[i,j])
end;
write(',C:');
readln(tt[i])
end;
writeln;
for i:=1 to n do
begin
for j:=1 to n do
write(k[i,j]:7:4,' ');
writeln(':',tt[i]:7:4)
end;
writeln
end; { procedure saisir }

procedure imprimer;
{ imprimer les solution }

var i : integer;

begin { imprimer la solution }
for i:=1 to n do
write(cof[i]:9:5);
writeln
end; { write_data }


procedure solve(k: ary2s;
tt: arys;
var cof: arys;
n: integer;
var error: boolean);

var
b : ary2s;
i,j : integer;
det : real;



function deter(k: ary2s): real;
{ fonction de calculer le determinant de la matrice carre de dimention 3 }

var
sum : real;

begin { function deter }
sum:=k[1,1]*(k[2,2]*k[3,3]-k[3,2]*k[2,3])
-k[1,2]*(k[2,1]*k[3,3]-k[3,1]*k[2,3])
+k[1,3]*(k[2,1]*k[3,2]-k[3,1]*k[2,2]);
deter:=sum
end; { function deter }



procedure setup(var b: ary2s;
var cof: arys;
j: integer);

var i : integer;

begin { setup }
for i:=1 to n do
begin
b[i,j]:=tt[i];
if j>1 then b[i,j-1]:=k[i,j-1]
end;
cof[j]:=deter(b)/det
end; { setup }

begin { procedure solve }
error:=false;
for i:=1 to n do
for j:=1 to n do
b[i,j]:=k[i,j];
det:=deter(b);
if det=0.0 then
begin
error:=true;
writeln(chr(7),'ERROR: matrix is singular.')
end
else
begin
setup(b,cof,1);
setup(b,cof,2);
setup(b,cof,3);
end { else }
end; {procedure solve }
procedure gramer;
begin
ClrScr;
writeln;
writeln('Solution par la M‚thode de Cramers ');
repeat
saisir(k,tt,n);
solve(k,tt,cof,n,error);
if not error then imprimer;
writeln;
write('Encore?');
readln(yesno);
ClrScr
until(yesno<>'O')and(yesno<>'o') ;
clrscr;
menu;
end;

{................................seid...................................}


procedure affichage(var a : tab2;var y : tab1;var n,m: integer);
{ Entrez les valeur de la matrise a et b est l afficher}
var i,j : integer;

begin
writeln;
repeat
write('donner le nombre equation? ');
readln(n);
if first then first:=true else ClrScr
until n<maxr;
m:=n;
if n>1 then
begin
for i:=1 to n do
begin
writeln('Equation',i:3);
for j:=1 to n do
begin
write('a[',i,',',j,']':3,':');
read(a[i,j])
end;
write(' b[',i,',',j,']:');
read(y[i]);
readln
end;
writeln;
for i:=1 to n do
begin
for j:=1 to m do
write(a[i,j]:7:4,' ');
writeln(':',y[i]:7:4)
end;
writeln
end { si n>1 }
else if n<0 then n:=-n;
m:=n
end; { procedure affichage }

procedure resultat; {cette procedure donne le resultat finale}

var i: integer;

begin
for i:=1 to m do
writeln('x',i,'=',coeff[i]:9:4);
writeln;

end; { resultat }

procedure seid { la procedure de gauss seidel }
(a : tab2;
y : tab1;
var coef: tab1;
ncol : integer;
var error: boolean);
{solution par la methode de Gauss Seidel }

const tol = 1.0E-4;
max = 100;

var done : boolean;
i,j,k,l,n: integer;

nextc,hold,
sum,lambda,
ab,big : real;

begin
repeat
write('le facteur de Relaxation ? ');
readln(lambda)
until (lambda<2) and (lambda>0.0);
error:=false;
n:=ncol;
for i:=1 to n-1 do
begin
big:=abs(a[i,i]);
l:=i;
for j:=i+1 to n do
begin

ab:=abs(a[j,i]);
if ab>big then
begin
big:=ab;
l:=j
end
end;
if big=0.0 then error:=true
else
begin
if l<>i then
begin

for j:=1 to n do
begin
hold:=a[l,j];
a[l,j]:=a[i,j];
a[i,j]:=hold
end;
hold:=y[l];
y[l]:=y[i];
y[i]:=hold
end
end
end;
if a[n,n]=0.0 then error:=true
else
begin
for i:=1 to n do
coef[i]:=0.0;
i:=0;
repeat
i:=i+1;
done:=true;
for j:=1 to n do
begin
sum:=y[j];
for k:=1 to n do
if j<>k then
sum:=sum-a[j,k]*coef[k];
nextc:=sum/a[j,j];
if abs(nextc-coef[j])>tol then
begin
done:=false;
if nextc*coef[j]<0.0 then
nextc:=(coef[j]+nextc)*0.5
end;
coef[j]:=lambda*nextc+(1.0-lambda)*coef[j];
writeln(i:4,',coef(',j,')=',coef[j])
end
until done or (i>max)
end; { si a[n,n]=0 }
if i>max then error:=true;
if error then writeln(' Matrice est singulier')
end; { Procedure SEID }

procedure gaussseid; {Procedure generale de Gauss seidel}
var choix:char;
begin
first:=true;
ClrScr;
writeln;
writeln('la methode de Gauss-Seidel pour les solutions des systeme lineaire ');
repeat
affichage(a,y,n,m);
if n>1 then
begin
seid(a,y,coef,n,error);
if not error then resultat
end
until n<2;
clrscr;
menu;
end;

{************************* Methode de Gauss *****************************}

procedure gauss(z: tab2;t: tab1;var coeff: tab1;ncol: integer;var erreur: boolean);
var
b : tab2;
w : tab1;
i,j,i1,k,l,n : integer;
f,som,s,ab,big: real;
begin
erreur:=false;
n:=ncol;
for i:=1 to n do
begin
for j:=1 to n do
b[i,j]:=z[i,j];
w[i]:=t[i]
end;
for i:=1 to n-1 do
begin
big:=abs(b[i,i]);
l:=i;
i1:=i+1;
for j:=i1 to n do
begin
ab:=abs(b[j,i]);
if ab>big then
begin
big:=ab;
l:=j
end
end;
if big=0.0 then erreur:= true
else
begin
if l<>i then
begin

for j:=1 to n do
begin
f:=b[l,j];
b[l,j]:=b[i,j];
b[i,j]:=f
end;
f:=w[l];
w[l]:=w[i];
w[i]:=f
end;
for j:=i1 to n do
begin
s:=b[j,i]/b[i,i];
for k:=i1 to n do
b[j,k]:=b[j,k]-s*b[i,k];
w[j]:=w[j]-s*w[i]
end;
end;
end;
if b[n,n]=0.0 then erreur:=true
else
begin
coeff[n]:=w[n]/b[n,n];
i:=n-1;
repeat
som:=0.0;
for j:=i+1 to n do
som:=som+b[i,j]*coeff[j];
coeff[i]:=(w[i]-som)/b[i,i];
i:=i-1
until i=0
end;
if erreur then writeln(chr(7),'ERREUR: MATRISE EST SINGULIER')
end; { GAUSS }
{....................menu pricipale de la methode de gauss.................}
procedure gausse;

begin
p:=true;
textcolor(yellow);
ClrScr;
writeln(' ','Syst‚mes lin‚aires Ax=b ');
writeln;
writeln(' ','M‚thode Elimination de Gauss ');
writeln(' ', ' ------------------------------------');
repeat
affichage(z,t,n,m);
if n>1 then
begin
gauss(z,t,coeff,n,erreur);
if not erreur then resultat
end
until n<2 ;
clrscr;
menu;
end;


procedure gaussj
(var b: tab2; { square matrix of coefficients }
y: tab1; { constant vector }
var coef: tab1; { solution vector }
ncol: integer; { order of matrix }
var error: boolean); { true if matrix singular }

{ Gauss Jordan matrix inversion and solution }

{ B(n,n) coefficient matrix becomes inverse }
{ Y(n) original constant vector }
{ W(n,m) constant vector(s) become solution vector }
{ DETERM is the determinant }
{ ERROR=1 if singular }
{ INDEX(n,3) }
{ NV is number of constant vectors }

label 99;

var
w : array[1..maxc,1..maxc] of real;
index : array[1..maxc,1..3] of integer;
i,j,k,l,nv,
irow,icol,
n,l1 : integer;
determ,pivot,
hold,sum,t,
ab,big : real;




procedure swap(var a,b: real);
var hold : real;

begin { swap }
hold:=a;
a:=b;
b:=hold
end; { procedure swap }


procedure gausj2;
label 98;
var i,j,k,l,l1 : integer;


procedure gausj3;

var l : integer;

begin { procedure gausj3 }
{ interchange rows to put pivot on diagonal }
if irow<>icol then
begin
determ:=-determ;
for l:=1 to n do
swap(b[irow,l],b[icol,l]);
if nv>0 then
for l:=1 to nv do
swap(w[irow,l],w[icol,l])
end { if iroe<>icol }
end; { gausj3 }

begin { procedure gausj2 }
{ actual start of gaussj }
error:=false;
nv:=1; { single constant vector }
n:=ncol;
for i:=1 to n do
begin
w[i,1]:=y[i]; { copy constant vector }
index[i,3]:=0
end;
determ:=1.0;
for i:=1 to n do
begin
{ search for largest element }
big:=0.0;
for j:=1 to n do
begin
if index[j,3]<>1 then
begin
for k:=1 to n do
begin
if index[k,3]>1 then
begin
writeln('ERROR: matrix is singular');
error:=true;
goto 98 { abort }
end;
if index[k,3]<1 then
if abs(b[j,k])>big then
begin
irow:=j;
icol:=k;
big:=abs(b[j,k])
end
end { k-loop }
end
end; { j-loop }

index[icol,3]:=index[icol,3]+1;
index[i,1]:=irow;
index[i,2]:=icol;

gausj3; { further subdivision of gaussj }
{ divide pivot row by pivot column }
pivot:=b[icol,icol];
determ:=determ*pivot;
b[icol,icol]:=1.0;

for l:=1 to n do
b[icol,l]:=b[icol,l]/pivot;
if nv>0 then
for l:=1 to nv do
w[icol,l]:=w[icol,l]/pivot;

{ reduce nonpivot rows }

for l1:=1 to n do
begin
if l1<>icol then
begin
t:=b[l1,icol];
b[l1,icol]:=0.0;
for l:=1 to n do
b[l1,l]:=b[l1,l]-b[icol,l]*t;
if nv>0 then
for l:=1 to nv do
w[l1,l]:=w[l1,l]-w[icol,l]*t;
end { if l1<>icol }
end
end; { i-loop }
98:
end; { gausj2 }

begin { gaus-jordan main program }
gausj2; { first half of gaussj }
if error then goto 99;
{ interchange columns }
for i:=1 to n do
begin
l:=n-i+1;
if index[l,1]<>index[l,2] then
begin
irow:=index[l,1];
icol:=index[l,2];
for k:=1 to n do
swap(b[k,irow],b[k,icol])
end { if index }
end; { i-loop }
for k:=1 to n do
if index[k,3]<>1 then
begin
writeln(chr(7),'ERROR: matrix is singular');
error:=true;
goto 99 { abort }
end;
for i:=1 to n do
coef[i]:=w[i,1];
99:
end; { procedure gaussj }

procedure gaussjordant;
begin { MAIN program }
first:=true;
ClrScr;
writeln;
writeln('Simultaneous solution by Gauss-Jordan elimination');
repeat
affichage(a,y,n,m);
if n>1 then
begin
for i:=1 to n do
for j:=1 to n do
b[i,j]:=a[i,j]; { setup work array }
gaussj(b,y,coef,n,error);
if not error then imprimer
end
until n<2;
clrscr;
menu;
end;
procedure historique;
begin
clrscr;
gotoxy(34,9);writeln('Edition Par:');
gotoxy(32,10);writeln('ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ');
gotoxy(31,13);writeln('ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ» ');
gotoxy(31,14);writeln('º AHABRI MONSSIF º ');
gotoxy(31,15);writeln('ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ ');
readln;
clrscr;
menu;
end;

{***************************** programme principale ******************************}

var choix:char;
begin
menu;
repeat
readln(choix);
case choix of
'1':gausse;
'2':gaussseid;
'3':gaussjordant;
'4':gramer;
'h':historique;
'5':exit
end;
until choix='5'
end.