Đăng ngày: 07:39 24-04-2009
{Ví dụ: Từ HPT 4 ẩn:
a11.x1+a12.x2+a13.x3+a14.x4 = b1
a21.x1+a22.x2+a23.x3+a24.x4 = b2
a31.x1+a32.x2+a33.x3+a34.x4 = b3
a41.x1+a42.x2+a43.x3+a44.x4 = b4.
Chương trình đưa HPT về dạng:
a11.x1+a12.x2+a13.x3+a14.x4 = b1
a22.x2+a23.x3+a24.x4 = b2
a33.x3+a34.x4 = b3
a44.x4 = b4.
Từ đó tính được x4=b4/a44, rồi x3=(b3-a34.x4)/a33, ..., x1=....}
uses crt;
const n=4;
type Mang_2_Chieu=array[1..n,1..n] of integer;
Mang_1_Chieu=array[1..n] of integer;
var a : Mang_2_Chieu;
b : Mang_1_Chieu;
Lan : byte;
procedure Nhap(var a:Mang_2_chieu; var b:Mang_1_chieu);
var i,j:byte;
begin
for i:=1 to n do
begin
for j:=1 to n do a[i,j]:=random(9)-random(9);
b[i]:=random(9)-random(9);
end
end;
Procedure Xuat(a:Mang_2_chieu; b:Mang_1_chieu);
var i,j,k,maxd : byte;
d:array[1..n] of byte;
xN:string[12];
begin
for j:=1 to n do
begin
str(a[1,j],xN);
if a[1,j]>=0 then xN:='+'+xN;
maxd:=length(xN);
for i:=2 to n do
begin
str(a[i,j],xN);
if a[i,j]>=0 then xN:='+'+xN;
if length(xN)>maxd then maxd:=length(xN);
end;
d[j]:=maxd;
end;
textcolor(7);
writeln('He phuong trinh lan thu ',Lan,' la:');
for i:=1 to n do
begin
textcolor(7);
write('(',i,') ');
for j:=1 to n do
begin
str(a[i,j],xN);
if a[i,j]>=0 then xN:='+'+xN;
if (a[i,j]=0) and (i>j) then textcolor(12)
else textcolor(15);
write(xN:d[j]);
textcolor(11);
write('.x',j);
end;
textcolor(14);
write(' = ');
writeln(b[i]);
end
end;
procedure DoiCho(var a,b:integer);
var c:integer;
begin
c:=a;
a:=b;
b:=c;
end;
function USCLN(a,b:integer):integer;
var c : integer;
begin
a:=abs(a);
b:=abs(b);
if a<b then DoiCho(a,b);
while b>0 do
begin
c:=a mod b;
a:=b;
b:=c;
end;
USCLN:=a;
end;
procedure GianUoc(var a:Mang_2_chieu; var b:Mang_1_chieu);
var i,j : byte;
usc : integer;
begin
for i:=1 to n do
begin
usc:=b[i];
for j:=1 to n do usc:=USCLN(usc,a[i,j]);
if usc>1 then
begin
for j:=1 to n do a[i,j]:=a[i,j] div usc;
b[i]:=b[i] div usc;
end;
end;
end;
procedure BienDoi(var a:Mang_2_chieu;
var b:Mang_1_chieu;
Lan:byte);
var i,j : byte;
aLL,aiL : integer;
begin
i:=Lan;
while (a[i,Lan]=0) and (i<=n) do i:=i+1;
if (i>Lan) and (i<=n) then
begin
for j:=1 to n do DoiCho(a[Lan,j],a[i,j]);
DoiCho(b[Lan],b[i]);
end;
aLL:=a[Lan,Lan];
for i:=Lan+1 to n do
if a[i,Lan]<>0 then
begin
aiL:=a[i,Lan];
for j:=Lan to n do
a[i,j]:=a[i,j]*aLL-a[Lan,j]*aiL;
b[i]:=b[i]*aLL-b[Lan]*aiL;
end;
GianUoc(a,b);
Xuat(a,b);
readkey;
end;
procedure BienLuan;
var x : array[1..n] of real;
i,j : byte;
s,P : real;
xR : string;
begin
i:=1;
while (a[i,i]<>0) and (i<=n) do i:=i+1;
textcolor(15);
if i<=n then
writeln('Dap so: Hpt vo nghiem hoac vo so nghiem')
else
begin
s:=0;
i:=n;
repeat
P:=b[i]-s;
x[i]:=P/a[i,i];
i:=i-1;
s:=0;
for j:=i+1 to n do s:=s+a[i,j]*x[j];
until i=0;
writeln('Dap so: Hpt co 1 nghiem duy nhat:');
for j:=1 to n do
begin
str(x[j]:0:14,xR);
while xR[length(xR)]='0' do delete(xR,length(xR),1);
if xR[length(xR)]='.' then delete(xR,length(xR),1);
textcolor(11);
write('x',j);
textcolor(14);
writeln(' = ',xR);
end;
end;
end;
BEGIN
textmode(c80);
randomize;
repeat
clrscr;
writeln('Giai he phuong trinh theo thuat toan Gauss:');
Lan:=0;
Nhap(a,b);
Xuat(a,b);
readkey;
for Lan:=1 to n do BienDoi(a,b,Lan);
BienLuan;
textcolor(7);
write('Go Esc de thoat, phim khac de tiep tuc...');
until readkey=#27
END.
Chú ý:
Sau khi chạy ngon bạn có thể thay n lớn hơn và random lớn hơn chút ít.... OK.
dat_nm93 10:43 31-05-2009
dat_nm93 10:43 31-05-2009
ttm021287 09:09 12-05-2009
Cháu chào chú, khi nào chú rảnh cháu mời chú qua blog cháu nhé,,hì.......
Chucs chú buỏi sáng an lành
DeLi_Cio 10:36 10-05-2009
Chúc bác buổi sáng may mắn & an lành
Lã Chí An 08:15 10-05-2009
chúc chú buổi sáng tốt lành nhé! Có thời gian qua blog cháu nhé chú!
thằng khùn lãng tử, lạnh lùng, lun chờ em 11:08 09-05-2009