Perkalian matrix

uses crt;
var
a,b,c : array [1..50,1..50] of integer;
i,j,k,x,y,z : integer;
begin
clrscr;
writeln('Ukuran matrix A');
write('Baris : '); readln(x);
write('Kolom : '); readln(y);
writeln;
writeln('Ukuran matrix B');
writeln('Baris : ',y);
write('Kolom : '); readln(z);
for i:=1 to x do
for j:=1 to y do
begin

write('Elemen A[',i,',',j,'] : ');
readln(a[i,j]);
end;
writeln;
for i:=1 to y do
for j:=1 to z do
begin


Download source code lengkapnya di sini

Baca selengkapnya...

Unit Adjoin

unit adjoin;

interface
type matrix = array [1..10,1..10] of integer;
mi=record
e : matrix;
end;
min = array [1..10,1..10] of mi;
var
i,j,row,col,x,y,k,l : byte;
A : matrix;
function pangkat(var x,n : integer):integer;
procedure tukar(var a,b : integer);
procedure transpose(var A:matrix);


implementation
function pangkat(var x,n : integer):integer;
var
p,i : integer;
begin
p := 1;
for i := 1 to n do
p := p * x;
pangkat:=p;
end;
procedure tukar(var a,b : integer);
var
temp : integer;
begin
temp := a;
a := b;
b := temp;
end;


procedure transpose(var A : matrix);
begin
for i := 2 to row do
for j := 1 to (i-1) do
tukar(A[i,j],A[j,i]);
end;

procedure minor(var m : min; A : matrix);
begin
for i := 1 to (row-1) do
for j := 1 to (col-1) do
begin
x:= 0;
for k :=1 to row do
begin
x:=x+1;
y := 0;
for l := 1 to col do
begin
y:=y+1;


Download source code unit lengkapnya di sini

Pada unit ini juga terdapat prosedur pencarian determinan dan invers matrik..
Keren kan...

Komen yaw..

Baca selengkapnya...

Mencari Covarian

USES CRT;
var
n,i : integer;

x,sigma,sigmax,sigmay,ratax,ratay,cov : real;
procedure covar;
var
x,y,px,py,k : array [1..100] of real;
begin
write('n = '); readln(n);
sigmax := 0;
sigmay := 0;
for i := 1 to n do

Download program lengkapnya di sini ..

Baca selengkapnya...

Administrasi mahasiswa

Program Administrasi_Mahasiswa;
uses crt;
const
pkkspp = 400000;
infospp = 600000;
elekspp = 500000;
bogaspp = 450000;
ptikspp = 500000;
pkkprak = 100000;
infoprak = 500000;
elekprak = 450000;
bogaprak = 600000;
ptikprak = 350000;
sehat : real = 10000;
var

nm,jur : string;
nojur : byte;
tahun :integer;
spp,prak : real;
tot : real;
begin
clrscr;
writeln('Administrasi Mahasiswa Fakultas Teknik dan Kejuruan');
writeln('===================================================');
write('Nama : '); readln(nm);
writeln('Keterangan Jurusan : ');
writeln('1. PKK');
writeln('2. D3 Informatika');
writeln('3. D3 Elektro');
writeln('4. D3 Boga Perhotelan');
writeln('5. PTIK');
write('Jurusan (tulis no saja) : '); readln(nojur);
write('Tahun Masuk : '); readln(tahun);
if tahun<2004 then
begin

if nojur = 1 then
begin
spp := pkkspp;
jur := 'PKK'
end
else if nojur = 2 then
begin
spp :=infospp;
jur := 'D3 Informatika';
end
else if nojur = 3 then
begin
spp :=elekspp;
jur := 'D3 Elektro'
end
else if nojur = 4 then
begin
spp :=bogaspp;
jur := 'D3 Boga Perhotelan';
end
else if nojur= 5 then
begin
spp :=ptikspp;
jur := 'PTIK'
end
else
writeln('Jurusan salah, tolong ulangi !!');

end
else
begin
if nojur = 1 then
begin
spp := pkkspp;
prak:= pkkprak;
jur := 'PKK'
end

else if nojur= 2 then
begin
spp :=infospp;
prak:= infoprak;
jur := 'D3 Informatika';
end
else if nojur = 3 then
begin
spp :=elekspp;
prak:=elekprak;
jur := 'D3 Elektro';
end
else if nojur = 4 then
begin
spp :=bogaspp;
prak:=bogaprak;
jur := 'D3 Boga Perhotelan';
end
else if nojur= 5 then
begin
spp :=ptikspp;
prak:=ptikprak;
jur := 'PTIK';
end
else
writeln('Jurusan salah, tolong ulangi !!');
end;
tot := spp+prak+sehat;
writeln('Nama : ',nm);
writeln('Jurusan : ',jur);
writeln('Tahun Masuk : ',tahun);
writeln('Uang SPP : Rp. ',spp:7:2);
writeln('Uang Praktikum : Rp. ',prak:7:2);
writeln('Uang Kesehatan : Rp. ',sehat:7:2);
writeln('---------------------------------');
writeln('Total Pembayaran : Rp. ',tot:7:2);
writeln('=================================================');
readln;
end.

Baca selengkapnya...

Mengetahui tahun kabisat

Program kabisat;
uses crt;
var
tahun : longint;
begin
clrscr;
writeln('=================================');
writeln('Mengecek Tahun Kabisat atau Bukan');
write('Masukan tahun : '); readln(tahun);
if tahun mod 400 = 0 then
writeln ('Tahun ',tahun,' merupakan kabisat')
else if tahun mod 100 = 0 then
writeln ('Tahun ',tahun,' bukan merupakan kabisat')
else if tahun mod 4 = 0 then

Download source cide lengkap nya di sini.

Baca selengkapnya...

Unit Sorting

unit sort;
interface
uses crt;
type
larik = array [1..100] of integer;
var
i,j,n,y:byte;
copyL,l : larik;
procedure tukar(var a,b:integer);
procedure bubble_asc(var l:larik; n:byte);
procedure bubble_dsc(var l:larik; n:byte);
procedure select_min_asc(var l:larik; n:byte);
procedure select_min_dsc(var l:larik; n:byte);
procedure select_max_asc(var l:larik; n:byte);
procedure select_max_dsc(var l:larik; n:byte);
procedure insert_asc(var l:larik; n:byte);
procedure insert_dsc(var l:larik; n:byte);
procedure anim(var jml:byte);

implementation
procedure tukar(var a,b:integer);
var temp: integer;
begin
temp:=a;
a:=b;
b:=temp;
end;
procedure bubble_asc(var l:larik; n:byte);
begin
for i:=1 to n do
for j:=n downto i+1 do
if l[j] < l[j-1] then
begin
tukar(l[j],l[j-1])
end;
end;
procedure bubble_dsc(var l:larik; n:byte);
begin
for i:=1 to n do
for j:=n downto i+1 do
if l[j] > l[j-1] then
begin
tukar(l[j],l[j-1])
end;
end;


Pada unit ini akan terdapat prosedur - prosedur pengurutan data (sorting) dari ASC dan DESC. Juga terdapat prosedur untuk membuat animasi menu pada pascal. Keren kan....

Download source code dan *.TPU nya di sini.

Baca selengkapnya...

Pengguaan case

Program tokoPD;
uses crt;
const dancowb = 10000;
dancows = 4250;
dancowk = 2100;
indob = 8500;
indos = 4000;
indok = 2025;
milob = 7750;
milos = 4000;
milok = 2200;
suprib = 9600;
supris = 5100;
suprik = 2600;
sustab = 17000;
sustas = 14500;

sustak = 8300;
ovalb = 11250;
ovals = 6500;
ovalk = 3200;
var
no : byte;
ukuran : char;
banyak : longint;
bayar : real;
begin
clrscr;
writeln('===============================================');
writeln(' P & D Toserba');
writeln('Susu yang tersedia di P & D Toserba : ');
writeln('1. Dancow');
writeln('2. Indomilk');
writeln('3. Milo');
writeln('4. Suprima');
writeln('5. Sustagen');
writeln('6. Ovaltime');
writeln('--------------------------------------');
write('No susu : '); readln(no);
write('Ukuran (b:besar,s:sedang,k:kecil) : '); readln(ukuran);
write('Banyak barang : '); readln(banyak);
case no of
1 : begin
case ukuran of
'b' : bayar:=dancowb*banyak;
's' : bayar:=dancows*banyak;
'k' : bayar:=dancowk*banyak;
else writeln('Ukuran salah !!');
end;

Download source code lengkap nya di sini.

Baca selengkapnya...

Menghitung Jumlah huruf pada sebuah kata / kalimat

uses crt;
var
kata : string;
h : array ['A'..'Z'] of byte;
j : char;
i : byte;
begin
clrscr;
write('Input kata : ');readln(kata);
for i := 1 to length(kata) do
begin

for j := 'A' to 'Z' do
begin
if kata[i]= j then
begin

Download program lengkapnya di sini

Baca selengkapnya...

Gaji Pegawai

Program Gaji;
uses crt;
var
nama,alamat : string;
gaji_pkok,tunjangan,pajak,bersih : real;
begin
clrscr;
write('Nama Pegawai : '); readln(nama);
write('Alamat : '); readln(alamat);

write('Gaji Pokok : ');readln(gaji_pkok);
tunjangan := 15/100*gaji_pkok;
pajak := 7.5/100*gaji_pkok;
bersih :=


Download source code lengkap nya di sini.

Baca selengkapnya...

Metode Bagi dua

uses crt;
const epsilon=0.00001;
var
a,b,c,fa,fb,fc : real;

begin
writeln('Mencari akar dari persamaan f(x)=(x^3 + 1)/3');
writeln(' Dengan Metode Bagi Dua');
writeln('============================================');
write('Masukkan batas awal(a) : '); readln(a);
fa:=(a*a + 1)/3;

writeln('f(a) = ',fa:0:5);
repeat
write('Masukkan batas akhir(b) : '); readln(b);
fb:=(b*b +1)/3;
writeln('f(b) = ',fb:0:5);
if fa*fb < 0 then
begin
writeln('Syarat OK (f(a)*f(b)<0)');
writeln('f(a)*f(b) = ',(fa*fb):0:5);
end
else

Download di sini untuk source code lengkap nya..

Komen yaw..

Baca selengkapnya...

Regula Falsi

program regula_falsi;
uses crt;
label ulang;
var
x1,x2,x3,y1,y2,y3 : real;
i : integer;
Ab :char;
data1 : real;
begin

ulang:
clrscr;
writeln('Tentukan nilai akar dari persamaan f(x)=x^3+x^2-3x-3=0 dengan Regula Falsi');
write('Masukan nilai x1 = ');readln(x1);
y1 := x1 * x1 * x1 + x1 * x1 - 3 * x1 - 3;
writeln(' Nilai f(x1)= ',y1:0:4);
repeat
begin
write( 'Masukan nilai x2 = ' ); readln(x2);
y2 := x2 * x2 * x2 + x2 * x2 - 3 * x2 - 3;
write(' Nilai f(x2)= ',y2:0:4);
end;
if (y1*y2)<0 then
Writeln(' Syarat Nilai Ok')
else
Writeln(' Nilai X2 Belum Sesuai');
until ( y1 * y2 ) <0;
writeln;
writeln('Penyelesaian persamaan karekteristik dengan metoda regula falsi');
writeln('----------------------------------------------------------------------');
writeln(' n x f(x) error ');
writeln('----------------------------------------------------------------------');
repeat
begin
i:= i + 1; x3 := ( x2-( y2 / ( y2 - y1))*(x2-x1));
y3 := x3 * x3 * x3 + x3 * x3 - 3 * x3 - 3;
if i<10 then
writeln(' ',i,' : ',x3,' : ',y3,' : ',abs(y3),' : ')
else
writeln(i,' : ',x3,' : ',y3,' : ',abs(y3),' : ');
if ( y1 * y3 ) <0 then
begin
x2 := x3 ; y2 := y3 ;
end
else
begin
x1 := x3 ; y1 := y3;
end;
end;
until abs( y3 ) < 1E-08;
writeln('----------------------------------------------------------------------');
writeln('Akar persamaannya= ',x3);
writeln('Errornya=' ,abs( y3 ));
writeln('----------------------------------------------------------------------');
writeln('Apakah anda ingin mengulangi (y/t): ');
readln(ab);
if (ab='y') or (ab='Y') then
goto ulang;
end.

Baca selengkapnya...

Faktorial

Program FAKTORIAL;

uses crt;

var Faktor : real;
Cacah,
Bil_Awal,
Bil_Akhir,
Konter,
Baris : integer;

begin
clrscr;
writeln('MEMBUAT TABEL FAKTORIAL');
write('BILANGAN AWAL : ');readln(Bil_Awal);
write('BILANGAN AKHIR : ');readln(Bil_Akhir);writeln;


writeln(' TABEL FAKTORIAL');
writeln;
writeln('--------------------------------');
writeln(' BILANGAN HARGA FAKTORIAL');
writeln('--------------------------------');writeln;
Baris := 11;
for Cacah := Bil_Awal to Bil_Akhir do

Mau tau lanjutannya download aj y..Di sini..

Baca selengkapnya...