|
DataMuseum.dkPresents historical artifacts from the history of: CP/M |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about CP/M Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 13824 (0x3600)
Types: TextFile
Names: »LL3.PAS«
└─⟦cd307176b⟧ Bits:30002666 Programmer fra Forlaget FAG ApS
└─ ⟦this⟧ »LL3.PAS«
program LLIGNING; (* Martin Rasmussen, 3xF , januar 1985 *)
const (* COMPAS PASCAL version 3.07, Piccoline *)
maxm=10; maxn=10;
maxmn=20; (* maxmn = maxm+maxn *)
type
fil1type = record
a:array(.1..maxn,1..maxmn.) of real;
rn,rm:integer;
end;
printype = (cons,prin,spog,clos);
var
r:fil1type;
n,m,i,j:integer;
detfac:real;
svar:char;
fil:string(.12.);
fil1:file of fil1type;
prt:boolean;
outf:text;
procedure menu; forward;
procedure nulstil; forward;
procedure stop; forward;
procedure printer(mode:printype); forward;
procedure forklaring; forward;
procedure erklaringer; forward;
procedure inddata; forward;
procedure indlas1; forward;
procedure indlas2; forward;
procedure rettelser; forward;
procedure retdata; forward;
procedure hentdata; forward;
procedure gemdata; forward;
procedure gauss; forward;
procedure uddata; forward;
procedure losning; forward;
procedure menu;
begin
repeat
write(clrhom);writeln;
writeln(' L I N E Æ R E L I G N I N G E R');
writeln;
writeln;
writeln(' Der kan vælges mellem følgende muligheder:');
writeln;
writeln(' 1. Løsning af ny opgave.');
writeln;
writeln(' 2. Løsning af gammel opgave.');
writeln;
writeln(' 3. Gentag udskrivning af løsningen.');
writeln;
writeln(' 4. Forklaring.');
writeln;
writeln(' 5. Stop kørslen.');
writeln;
write(' Anfør det ønskede nummer > ');
readln(svar); writeln;
if svar in (.'1'..'4'.) then write(clrhom);
case svar of
'1':begin
erklaringer;
inddata;
rettelser;
gemdata;
printer(spog);
if prt then uddata;
gauss;
losning;
printer(clos);
end;
'2':begin
hentdata;
rettelser;
gemdata;
printer(spog);
if prt then uddata;
gauss;
losning;
printer(clos);
end;
'3':begin
printer(spog);
losning;
printer(clos);
end;
'4':forklaring;
end;
until svar='5';
end; (* menu *)
procedure nulstil;
begin
fill(r,size(r),0);
n:=0; m:=0; i:=0; j:=0; detfac:=0;
prt:=false;
end; (* nulstil *)
procedure stop;
begin
writeln; writeln; writeln;
writeln(' ** Fejlmeldingen er uden betydning. **');
if 1/0=0 then;
end; (* stop *)
procedure printer;
begin
if mode=spog then
begin
write(' Ønskes udskrift på skærm/printer? (s/p) ');
readln(svar); writeln;
if svar in (.'p','P'.) then mode:=prin else mode:=cons;
end;
case mode of
cons :begin
assign(outf,'con:');
rewrite(outf); prt:=false;
end;
prin :begin
assign(outf,'lst:');
rewrite(outf); prt:=true;
end;
clos : begin
close(outf);
prt:=false;
end;
end;
end; (* printer *)
procedure forklaring;
begin
write(clrhom);writeln;
writeln(' F O R K L A R I N G.');
writeln;
writeln(' *******************************************************');
writeln(' * DETTE PROGRAM LØSER LINEÆRE LIGNINGER PÅ *');
writeln(' * PÅ FØLGENDE FORM. *');
writeln(' * *');
writeln(' * *');
writeln(' * A11*X1 + A12*X2 + ... + A1N*XN = B1 ... B1M *');
writeln(' * . . . . . *');
writeln(' * . . . . . *');
writeln(' * AM1*X1 + AM2*X2 + ... + AMN*XN = BM ... BNM *');
writeln(' * *');
writeln(' * HVOR *');
writeln(' * N = ANTAL UBEKENDTE (OG ANTAL LIGNINGER) *');
writeln(' * M = ANTAL HØJRESIDER *');
writeln(' * *');
writeln(' * *');
writeln(' * (c) Martin Rasmussen. Tommy Borch *');
writeln(' * Forlaget FAG Januar 1984. *');
writeln(' *******************************************************');
writeln;
write(' Tast return > '); readln(svar);
write(clrhom);writeln;
writeln(' ********************************************************');
writeln(' * ALLE ELEMENTER ANBRINGES I EN MATRIX A(N,N+M) *');
writeln(' * HVOR A(1:N,1:N) INDEHOLDER KOEFFICIENTERNE MENS *');
writeln(' * A(1:N,N+1:N+M) INDEHOLDER HØJRESIDERNE. *');
writeln(' * *');
writeln(' * LØSNINGERNE GEMMES SOM SØJLEVEKTORER I *');
writeln(' * A(1:N,N+1:N+M). *');
writeln(' * LIGNINGSSYSTEMETS DETERMINANT BEREGNES OG UDSKRIVES *');
writeln(' * *');
writeln(' * HVIS DETERMINANTEN ER 0 (ELLER MEGET NÆR 0) STOPPER *');
writeln(' * PROGRAMMET MED EN MEDDELELSE OM, AT MATRICEN ER *');
writeln(' * SINGULÆR, OG AT LIGNINGSSYSTEMET IKKE HAR NOGEN *');
writeln(' * ENTYDIG LØSNING. HEREFTER FØLGER EN FEJLMEDDELELSE, *');
writeln(' * SOM ER UDEN BETYDNING, OG KØRSLEN STOPPER. *');
writeln(' * *');
writeln(' * DEN INVERSE MATRIX TIL EN MATRIX A KAN BEREGNES VED *');
writeln(' * AT INDTASTE N X N ENHEDSMATRICEN SOM HØJRESIDERNE. *');
writeln(' * *');
writeln(' * IØVRIGT HENVISES TIL KAPITEL 2 I BOGEN *');
writeln(' * "LINEÆR PROGRAMMERING" AF MORTEN BLOMHØJ, *');
writeln(' * KLAVS FRISDAHL OG FRANK MØLGAARD OLSEN (FAG) *');
writeln(' *******************************************************');
write(' Tast return > ');readln(svar);
end; (* forklaring *)
procedure erklaringer;
var m1:integer;
begin
nulstil;
write(clrhom);writeln;
repeat
write(' Antal ubekendte (max ',maxn,') ? ');
readln(n); writeln;
write(' Antal højresider (max ',maxm,') ? ');
readln(m1); writeln;
until (n>0) and (m1>0) and (n<=maxn) and (m1<=maxm);
m:=m1+n;
end; (* erklaringer *)
procedure inddata;
begin
if (n<=9) and (m<=9) then indlas1 else indlas2;
end; (* inddata *)
procedure indlas1;
var
i,j,pos,pos1,pos2,fejl:integer;
svar:string(.20.);
begin
write(clrhom);writeln(' LIGNINGER: ');
for i:=1 to n do
begin
for j:=1 to n do
begin
pos:=10*(j-1);
pos1:=pos mod 70+4;
pos2:=i*2+pos div 70;
gotoxy(pos1,pos2); writeln('0 X',j,'+');
end;
gotoxy(pos1+8,pos2); writeln('= ');
for j:=n+1 to m do
begin
pos:=10*(j-1);
pos1:=pos mod 70+4;
pos2:=i*2+pos div 70;
gotoxy(pos1,pos2); writeln('0');
end;
end;
for i:=1 to n do
begin
for j:=1 to m do
begin
pos:=10*(j-1);
pos1:=pos mod 70+4;
pos2:=i*2+pos div 70;
repeat
gotoxy(pos1,pos2); readln(svar);
val(svar,r.a(.i,j.),fejl);
until fejl=0;
end;
end;
end; (* indlas1 *)
procedure indlas2;
var
i,j:integer;
begin
write(clrhom);
write(' LINÆRE LIGNINGER MED ',n,' UBEKENDTE OG ');
writeln(m-n,' HØJRESIDER.');
writeln('Kun koefficienter forskellig fra 0 skal indtastes.');
writeln('Tast først nummeret på søjlen og så koefficientens talværdi.');
writeln('Søjlenummer 0 afslutter en række i koefficient-matricen .');
writeln;
writeln('Række Søjle koefficient');
for i:=1 to n do
begin
j:=0;
repeat
j:=j+1;
write(i:3,'':12); read(j);
if (j>0) and (j<=n) then
begin
write('':20,'A(',i,',',j,') = ');
readln(r.a(.i,j.));
end else
begin
writeln;
end;
until (j=0) or (j=n);
writeln;
writeln('':3,'HØJRESIDE:',i);
j:=0;
repeat
j:=j+1;
write(i:3,'':12); read(j);
if (j>0) and (j<=m-n) then
begin
write('':20,'A(',i,',',n+j,') = ');
readln(r.a(.i,n+j.));
end else
begin
writeln;
end;
until (j=0) or (j=m-n);
writeln;
end;
end; (* indlas2 *)
procedure rettelser;
begin
repeat
printer(cons);
uddata;
printer(clos);
write(' Er dette korrekt? (j/n) ');
readln(svar); writeln;
if not(svar in (.'j','J'.)) then retdata;
until svar in (.'j','J'.);
end; (* rettelser *)
procedure retdata;
var svar:char;
begin
repeat
writeln;
write(' Rettelser i : (a) A-matricen. ');
writeln('(venstresiderne)');
write(' (b) B-matricen. ');
writeln('(højresiderne)');
writeln(' (p) Matrixen på printer.');
writeln(' (s) Stop rettelser');
repeat
write(' Vælg bogstav > ');
read(svar);
if ord(svar)>96 then svar:=chr(ord(svar)-32);
until svar in (.'A','B','C','P','S'.);
writeln;
case svar of
'A':begin
repeat
write(' Anfør rækkenummer: '); read(i);
write('. søjlenummer: '); readln(j);
until (i in (.1..n.)) and (j in (.1..n.));
write(' A(',i,',',j,') = ');
write(r.a(.i,j.):0:4,' = ');
readln(r.a(.i,j.));
end;
'B':begin
repeat
write(' Anfør rækkenummer: '); read(i);
write('. Højreside nummer: '); readln(j);
until (i in (.1..n.)) and (j in (.1..m-n.));
write(' A(',i,',',n+j,') = ');
write(r.a(.i,n+j.):0:4,' = ');
readln(r.a(.i,n+j.));
end;
'P':begin
printer(prin);
uddata;
printer(clos);
end;
end;
until svar='S';
end; (* retdata *)
procedure hentdata;
begin
nulstil;
repeat
write(' Hvad er filens navn? (højst 8 bogstaver) ');
buflen:=8; readln(fil); writeln;
until len(fil)<>0;
fil:=fil+'.LLD';
assign(fil1,fil); reset(fil1);
read(fil1,r); close(fil1);
n:=r.rn; m:=r.rm;
end; (* hentdata *)
procedure gemdata;
begin
write(' Skal disse data gemmes på en fil? (j/n) ');
svar:='j'; readln(svar); writeln;
if svar in (.'j','J'.) then
begin
repeat
write(' Hvad er filens navn? (højst 8 bogstaver) ');
buflen:=8; readln(fil); writeln;
until len(fil)<>0;
fil:=fil+'.LLD';
r.rn:=n; r.rm:=m;
assign(fil1,fil); rewrite(fil1);
write(fil1,r); close(fil1);
end;
end; (* gemdata *)
procedure gauss;
var
permute:array(.1..maxn.) of integer;
i,j,k,i0,j0:integer;
max,factor,twofac:real;
begin
writeln;
writeln(' ANTAL GENNEMLØB:');
detfac:=1;
for i:=1 to n do
begin
max:=0;
for j:=1 to n do max:=max+sqr(r.a(.i,j.));
if (max>1) or (max<0.25) then
begin
twofac:=exp(ln(2)*(-int(ln(max)/1.3893+1)));
for j:=1 to m do r.a(.i,j.):=r.a(.i,j.)*twofac;
detfac:=detfac/twofac;
end;
end;
for k:=1 to n do
begin
write(k:4);
max:=0;
for i:=k to n do
begin
for j:=k to n do
begin
factor:=abs(r.a(.i,j.));
if max<factor then
begin
max:=factor; i0:=i; j0:=j;
end;
end;
end;
if max<0.000001 then
begin
write(clrhom);writeln; writeln;
write(' SINGULÆRT SYSTEM. ');
writeln('OPGAVEN HAR IKKE EN ENTYDIG LØSNING.');
writeln;
stop;
end;
max:=r.a(.i0,j0.);
detfac:=detfac*max;
if i0<>k then
begin
detfac:=-detfac;
for j:=k to m do
begin
factor:=r.a(.k,j.);
r.a(.k,j.):=r.a(.i0,j.);
r.a(.i0,j.):=factor;
end;
end;
permute(.k.):=k;
if j0<>k then
begin
detfac:=-detfac;
permute(.k.):=j0;
for i:=1 to n do
begin
factor:=r.a(.i,k.);
r.a(.i,k.):=r.a(.i,j0.);
r.a(.i,j0.):=factor;
end;
end;
for i:=k+1 to n do
begin
factor:=r.a(.i,k.)/max;
for j:=k+1 to m do r.a(.i,j.):=r.a(.i,j.)-
r.a(.k,j.)*factor;
end;
end;
writeln;
(* Løsning *)
for k:=n+1 to m do
begin
for i:=n downto 1 do
begin
factor:=r.a(.i,k.);
for j:=i+1 to n do factor:=factor-
r.a(.i,j.)*r.a(.j,k.);
r.a(.i,k.):=factor/r.a(.i,i.);
end;
end;
for i:=n-1 downto 1 do
begin
i0:=permute(.i.);
if i0<>i then
begin
for k:=n+1 to m do
begin
factor:=r.a(.i,k.);
r.a(.i,k.):=r.a(.i0,k.);
r.a(.i0,k.):=factor;
end;
end;
end;
end; (* gauss *)
procedure uddata;
begin
if not prt then write(clrhom);
writeln(outf); writeln(outf);
for j:=1 to 79 do write(outf,'-'); writeln(outf);
for i:=1 to n do
begin
for j:=1 to n do
begin
if j mod 7=0 then writeln(outf);
write(outf,r.a(.i,j.):12:4);
end;
write(outf,' : ');
for j:=n+1 to m do
begin
if (j-n) mod 7=0 then writeln(outf);
write(outf,r.a(.i,j.):12:4);
end;
writeln(outf);
end;
for i:=1 to 79 do write(outf,'-'); writeln(outf);
end; (* uddata *)
procedure losning;
begin
write(clrhom);
if prt then write(outf,@12);
for i:=1 to 23 do write(outf,'-');
write(outf,' Løsning til ligningerne ');
for i:=1 to 31 do write(outf,'-'); writeln(outf);
writeln(outf); writeln(outf);
for i:=1 to n do
begin
write(outf,'':25,'X(',i,') = ');
for j:=1 to m-n do write(outf,r.a(.i,n+j.):12:4);
writeln(outf);
end;
writeln(outf);
write(outf,' LIGNINGS-SYSTEMETS DETERMINANT ER ');
if detfac >= 1E8 then writeln(outf,detfac)
else writeln(outf,detfac:0:4);
if abs(detfac)<0.00005 then
writeln(outf,' ADVARSEL! LØSNINGERNE KAN VÆRE MEGET UNØJAGTIGE.');
writeln(outf); writeln(outf); writeln(outf);
write('Tast return >'); readln(svar);
end; (* losning *)
begin
menu;
writeln; writeln;
end.
«eof»