Algoritma program Pascal untuk lokalisasi akar fungsi polinom dengan aturan tanda Descartes, batas selang akar, dan tabulasi.
Program Lokalisasi_Akar_The_Queen_of_Science;uses wincrt;
var
i, j, k, l, cek, max : integer;
a, b, c, z, cekt, tawal, jarak, bakar, ro, maks : real;
koef, koefl : array[1..7] of real;
np, nq : array[1..4] of real;
label 1, 2, 3, 4, 5;
function y(x:real):real;
begin
y:= koef[1]*x*x*x*x*x*x + koef[2]*x*x*x*x*x + koef[3]*x*x*x*x + koef[4]*x*x*x + koef[5]*x*x + koef[6]*x + koef[7];
end;
begin
1:
{Input}
{1. Bentuk fungsi yang diinginkan}
writeln('Program Lokalisasi Polinomial. (Maksimal pangkat 6)');
writeln('');
writeln('Bentuklah fungsi yang anda inginkan.');
writeln('Fungsi umum: (f(x) = ax^6 + bx^5 + cx^4 + dx^3 + ex^2 + fx + g)');
write('a = ');readln(koef[1]);koefl[1]:= koef[1];
write('b = ');readln(koef[2]);koefl[2]:= koef[2];
write('c = ');readln(koef[3]);koefl[3]:= koef[3];
write('d = ');readln(koef[4]);koefl[4]:= koef[4];
write('e = ');readln(koef[5]);koefl[5]:= koef[5];
write('f = ');readln(koef[6]);koefl[6]:= koef[6];
write('g = ');readln(koef[7]);koefl[7]:= koef[7];
clrscr;goto 3;
2:
{Optional}
writeln('Apakah sudah sesuai? 1. Sudah 2. Belum');readln(i);
if i = 1 then
begin
clrscr;goto 3;
end;
if i = 2 then
begin
clrscr;i:= 0;goto 1;
end;
3:
{2. Pencetakan fungsi yang diinginkan}
write('Fungsi anda: f(x) = ');
for j:= 1 to 5 do
begin
if koef[j] <> 0 then
begin
write('(',koef[j]:0:2,')x^',7-j,' + ');
end;
end;
if koef[6] <> 0 then
begin
write('(',koef[6]:0:2,')x + ');
end;
if koef[7] <> 0 then
begin
writeln('(',koef[7]:0:2,')');
end;
if koef[7] = 0 then
begin
writeln('',koef[7]:0:0);
end;
{Optional}
if i = 0 then
begin
goto 2;
end;
{3. Input jarak antar titik dan iterasi maksimal}
writeln('Masukkan jarak antar titik.');
write(' Jarak = ');readln(jarak);
writeln('Masukkan iterasi maksimal program.');
write(' Max = ');readln(max);
writeln('');
{Output}
{1. Lokalisasi aturan tanda Descartes}
{1.1. Akar real positif}
a:= 0;
k:= 1;
4:
{1.1.1. Penentuan banyak pergantian}
for i:= k to 6 do
begin
for j:= i+1 to 7 do
begin
if koef[i]*koef[j] < 0 then
begin
a:= a + 1;k:= j;goto 4;
end;
end;
end;
{1.1.2. Pencarian akar}
j:= 0;
for i:= 0 to 3 do
begin
b:= a - 2*i;
if b <= a then
begin
np[j+1]:= b;j:= j + 1;
end;
end;
{1.2. Akar real negatif}
a:= 0;
k:= 1;
{2.2.1. Penginputan nilai (-x) ke fungsi}
for i:= 1 to 3 do
begin
koef[2*i]:= (-1)*koef[2*i];
end;
{1.2.2. Penentuan banyak pergantian}
5:
for i:= k to 6 do
begin
for j:= i+1 to 7 do
begin
if koef[i]*koef[j] < 0 then
begin
a:= a + 1;k:= j;goto 5;
end;
end;
end;
{1.2.3. Pencarian akar}
j:= 0;
for i:= 0 to 3 do
begin
b:= a - 2*i;
if b <= a then
begin
nq[j+1]:= b;j:= j + 1;
end;
end;
{1.3. Kesimpulan}
{1.3.1. Penentuan banyak maksimal dari akar yang didapatkan}
for i:= 1 to 6 do
begin
if bakar = 0 then
begin
if koef[i] <> 0 then
begin
bakar:= 7 - i;
end;
end;
end;
{1.3.2. Penentuan banyak anggota yang akan dikombinasikan}
k:= 0;
for i:= 1 to 4 do
begin
if np[i] >= 0 then
begin
k:= k+1;
end;
if nq[i] >= 0 then
begin
l:= l+1;
end;
end;
{1.3.3. Pencetakan kemungkinan kesimpulan}
writeln('===============================================================================');
write('Kemungkinan kesimpulan');
for i:= 1 to k do
begin
if np[i] >= 0 then
begin
for j:= 1 to l do
begin
if nq[j] >= 0 then
begin
c:= bakar - np[i] - nq[j];
writeln('');
if np[i] <> 0 then
begin
if nq[j] > 0 then
begin
write('',np[i]:0:0,' akar real positif dan ',nq[j]:0:0,' akar real negatif ');
end;
if nq[j] = 0 then
begin
write('',np[i]:0:0,' akar real positif ');
end;
if c > 0 then
begin
write('dan ',c:0:0,' akar bilangan kompleks');
end;
end;
if np[i] = 0 then
begin
if nq[j] > 0 then
begin
write('',nq[j]:0:0,' akar real negatif ');
if c > 0 then
begin
write('dan ',c:0:0,' akar bilangan kompleks');
end;
end;
if nq[j] = 0 then
begin
write('',c:0:0,' akar bilangan kompleks');
end;
end;
end;
end;
end;
end;
{2. Lokalisasi cara Batas Selang Akar}
{2.1. Pengembalian nilai koefisien yang berubah pada Lokalisasi aturan tanda Descartes.}
for i:= 1 to 7 do
begin
koef[i]:= koefl[i];
end;
{2.2. Proses pencarian batas selang akar.}
for i:= 1 to 7 do
begin
if maks < abs(koef[i]) then
begin
maks:= abs(koef[i]);
end;
end;
ro:= 1 + maks;
tawal:= -ro;
writeln;writeln('===============================================================================');
writeln('Batas letak akar');
writeln('Akar-akar real f(x) terletak pada interval (',(-ro):0:4,',',ro:0:4,')');
{3. Lokalisasi cara tabulasi}
writeln('===============================================================================');
writeln('Interval akar');
i:= 0;
repeat
z:= tawal+jarak;
if y(tawal)*y(z) < 0 then
begin
writeln('Ada akar pada (',tawal:1:4,',',z:1:4,')');cek:= cek + 1;
end;
if y(tawal)*y(z) = 0 then
begin
if y(tawal) = 0 then
begin
if tawal <> cekt then
begin
writeln('Akarnya pada x = ',tawal:1:4);cek:= cek + 1;
end;
end;
if y(z) = 0 then
begin
writeln('Akarnya pada x = ',z:1:4);cek:= cek + 1;cekt:= z;
end;
end;
if i = max then
begin
if cek = 0 then
begin
writeln('Setelah ',max,' iterasi, dapat disimpulkan bahwa tidak');
writeln('ada akar pada selang (',(tawal-(max*jarak)):1:4,',',tawal:1:4,')');
end;
end;
tawal:= z;
i:= i + 1;
until i = max+1;
writeln('===============================================================================');
{Optional}
writeln('');
writeln('Ingin mencoba lagi? 1. Ya 2. Tidak');readln(j);
if j = 1 then
begin
clrscr;i:= 0;cek:= 0;goto 1;
end
else
begin
writeln('');
writeln('Terima kasih sudah menggunakan program ini.');
end;
Tidak ada komentar:
Posting Komentar