Unregistered
|
Вот практически не тронутый код, если чесно в паскале я практически ничего не понимаю, только могу понять код. У меня есть уже откомпиленая прога и исходники, исходники откомпилировать сам не могу ругается что версия tpcrt.tpu не та..уже даже с нета качал другую. Поправьте плиз этот код чтобы я его мог без проблем откопилитью и посмотреть результаты сам. | Код | program iwusnn;
uses
dos;
{$l egavga.obj}
procedure vgadrv; external;
const
nfx :byte = 4;
type
str16 = string[16];
arrayb = array[1..24] of byte;
arrayd = array[1..24] of double;
opmenu = array[1..18] of dirstr;
opxy = array[1..127] of str16;
sply = ^spoly;
spoly = record s :string; p :sply end;
grdim = record
pyt = ^yt;
yt = record
y, t :double;
py :pyt
end;
var
ptr :^integer;
py0, pyi, pyw :pyt;
ch :str16;
vx, frm :dirstr;
filc, filt, filq :str16;
fcfg, ftab, fq :text;
fl, qstab, qstart, equiv, grid :boolean;
key :word;
xc, yc, xc1, yc1, xm,
jj, l, m, nb, n, nr, nrr, nd, ier, nright,
na, ncx, mnu :byte;
i, j, code :integer;
c, cx, b0, b, a0, a, gd, dc, dr, qr, qi :arrayd;
kr :arrayb;
xlo, ylo, xhi, yhi, t, dt, tmin, tmax, temp, sr, si,
tconst, ymin, ymax :double;
directory :dirstr;
prgm :namestr;
dim :grdim;
procedure rooterr;
begin
if (ier > 0) and (ier < 5) then
begin
writeln(' Ошибка в вычислении корней ier = ',ier);
end
end;
function atan2(x, y :double) :double;
begin
if x = 0.0 then
if y = 0.0 then
atan2 := 0
else
if y > 0.0 then atan2 := pi/2
else atan2 := -pi/2
else
if x > 0.0 then
atan2 := arctan(y/x)
else
if y >= 0.0 then
atan2 := arctan(y/x) + pi
else
atan2 := arctan(y/x) - pi
end;
function fixn;
var
sign, nx, m, i :shortint;
stn :str16;
cnx :string[3];
begin
if (x = 0.0) or (n < 1) then
fixn := '0'
else
begin
sign := ord(x < 0.0);
x := abs(x);
nx := trunc(ln(x)/ln(10.0));
if x < 1.0 then nx := n - nx
else nx := n - nx - 1;
str(round(x*exp(nx*ln(10))),stn);
nx := nx + n - length(stn);
while copy(stn,length(stn),1) = '0' do
delete(stn,length(stn),1);
m := n - length(stn);
if nx - m <> 0 then
begin
if (m - nx > 3) or (nx - n > 2) then
begin
if (n - m > 1) then insert('.',stn,2);
str(n-nx-1, cnx);
stn := concat(stn,'e',cnx)
end
else if (m - nx <= 3) and (nx < m) then
for i := 1 to m-nx do stn := stn + '0'
else if (nx < n) and (nx > m) then
insert('.',stn,n-nx+1)
else
begin
if nx - n <> 0 then
for i := 1 to nx-n do stn := '0' + stn;
stn := '0.' + stn
end
end;
if sign = 1 then stn := '-' + stn;
fixn := stn;
end
end; {----- fixn -----}
procedure polrtt;
const
eps = 5.0e-7;
var
i, j, n, nt, nre, nc, n0, ii, jj, kr :byte;
ind :shortint;
d, x, y, temp :double;
r, t :arrayd;
procedure factor (n :byte; var a,r,t :arrayd; var nt :byte);
var
r1, t1, aa :arrayd;
temp, er, ar :double;
i, j, nr, nr1, ni, nt1 :byte;
label mtk;
begin
ar := 0.0;
for i := 1 to n - 1 do
ar := ar + sqr(a[i]);
ar := sqrt(ar/(n-1));
for i := 1 to n + 1 do
begin
r[i] := a[i];
if i > 1 then
r1[i-1] := (i-1) * a[i]
end;
nr := n;
nr1 := n - 1;
for i := 1 to n + 1 do
begin
if i = 1 then t[i] := 1.0
else t[i] := 0.0;
t1[i] := 0.0
end;
nt := 0;
repeat
for i := 0 to nr - nr1 do
begin
ni := nr + 1 - i;
r[ni] := r[ni] / r1[nr1 + 1];
for j := 0 to nr1 - 1 do
r[ni-nr1+j] := r[ni-nr1+j] - r[ni] * r1[j+1]
end;
for i := 1 to nr - nr1 + 1 do
for j := 1 to nt + 1 do
t1[i+j-1] := t1[i+j-1] + r[nr1+i] * t[j];
nt1 := nr - nr1 + nt;
for i := 1 to n + 1 do aa[i] := 0.0;
for i := 1 to nr1 + 1 do
for j := 1 to nt1 + 1 do
aa[i+j-1] := aa[i+j-1] + r1[i] * t1[j];
for i := 1 to nt1 + 1 do
begin
temp := t1[i];
t1[i] := t[i];
t[i] := temp
end;
nt := nt1;
for i := 1 to nr1 + 1 do
begin
temp := r[i];
r[i] := r1[i];
r1[i] := temp
end;
nr := nr1;
dec(nr1);
while abs(r1[nr1 + 1]/ar) < eps do
begin
if nr1 = 0 then goto mtk;
dec(nr1)
end;
mtk:
er := 0.0;
for i := 1 to n - 1 do
er := er + sqr(a[i] - aa[i]);
er := sqrt(er / (n - 2))/ar;
until (er <= eps) or (nr1 = 0);
if (nr1 = 0) and (er > eps) then
begin
r[1] := 1.0;
nt := n;
for i := 1 to n + 1 do t[i] := a[i]
end;
end; {----- factor -----}
procedure sturm (nt :byte; t :arrayd; var nr :byte);
var
p, s :arrayd;
temp, w :double;
i, j, ni, nleft, nright, np, ns :byte;
l1, l2, r1, r2 : boolean;
label mtk;
begin
nleft := 0;
nright := 0;
w := 0;
for i := 1 to nt + 1 do
begin
p[i] := t[i] / t[nt+1];
w := w + sqr(p[i]);
if i > 1 then s[i-1] := (i - 1) * p[i] / nt
end;
w := sqrt(w/(nt+1));
np := nt;
ns := nt - 1;
r1 := (p[np+1] > 0);
l1 := not(r1 xor ((np mod 2) = 0));
r2 := (s[ns+1] > 0);
l2 := not(r2 xor ((ns mod 2) = 0));
if r1 xor r2 then nright := nright + 1;
if l1 xor l2 then nleft := nleft + 1;
repeat
for i := 0 to np - ns do
begin
ni := np + 1 - i;
p[ni] := p[ni] / s[ns+1];
for j := 0 to ns - 1 do
p[ni-ns+j] := p[ni-ns+j] - p[ni] * s[j+1]
end;
for i := 1 to ns + 1 do
begin
temp := p[i];
p[i] := s[i];
s[i] := temp
end;
np := ns;
dec(ns);
while abs(s[ns+1]/w) < eps do
begin
if ns = 0 then goto mtk;
dec(ns)
end;
mtk:
w := 0;
for i := 1 to ns + 1 do
begin
s[i] := -s[i] / abs(s[ns+1]);
w := w + sqr(s[i])
end;
w := sqrt(w/(ns+1));
l1 := l2;
r1 := r2;
r2 := s[ns+1] > 0;
l2 := not (r2 xor ((ns mod 2) = 0));
if l1 xor l2 then nleft := nleft + 1;
if r1 xor r2 then nright := nright + 1;
until ns <= 0;
nr := nleft - nright
end; {----- sturm -----}
procedure newrea(n :byte; t :arrayd; var x :double);
var
f, temp, xl, xr, dx :double;
kit, i, j :integer;
begin
xl := 0.0; xr := 0.0;
for i := 2 to n + 1 do
if abs(t[i]) > xl then xl := abs(t[i]);
xl := 1.0 / (1.0 + xl / abs( t[1] ));
for i := 1 to n do
if abs(t[i]) > xr then xr := abs(t[i]);
xr := 1.0 + xr / abs(t[n+1]);
dx := 0.25 * (xr - xl);
x := xl;
kit := 0; j := 0;
repeat
inc(kit);
if kit >= 200 then
begin
inc(j);
if j = 10 then begin ier := 1; exit end;
kit := 0;
xl := -xl;
if xl > 0.0 then xl := xl + dx;
x := xl
end;
f := t[n+1];
for i := n downto 1 do f := f * x + t[i];
if n > 1 then
begin
temp := n * t[n+1];
for i := n downto 2 do
temp := temp * x + (i - 1) * t[i]
end
else temp := t[2];
x := x - f / temp;
until abs(f / temp / x) < eps;
end; {----- newrea -----}
procedure newcom(n :byte; t :arrayd; var x, y :double);
var
u, v, ux, vx, dx, dy, temp, xl, xr, dxl :double;
kit, i, j :integer;
begin
xl := 0.0; xr := 0.0;
for i := 2 to n + 1 do
if abs(t[i]) > xl then xl := abs(t[i]);
xl := 1.0 / (1.0 + xl / abs( t[1] ))/sqrt(2.0);
for i := 1 to n do
if abs(t[i]) > xr then xr := abs(t[i]);
xr := (1.0 + xr / abs(t[n+1]))/sqrt(2.0);
dxl := 0.25 * (xr - xl);
x := xl; y := xl;
kit := 0; j := 0;
repeat
inc(kit);
if kit >= 200 then
begin
inc(j);
if j = 10 then begin ier := 1; exit end;
kit := 0;
xl := -xl;
if xl > 0.0 then xl := xl + dxl;
x := xl; y := -xl
end;
u := t[n+1];
v := 0.0;
for i := n downto 1 do
begin
temp := x * v + y * u;
u := x * u - y * v + t[i];
v := temp
end;
ux := n * t[n+1];
vx := 0.0;
for i := n downto 2 do
begin
temp := x * vx + y * ux;
ux := x * ux - y * vx + (i - 1) * t[i];
vx := temp
end;
temp := sqr(ux)+sqr(vx);
dx := (u * ux + v * vx) / temp;
dy := (v * ux - u * vx) / temp;
x := x - dx;
y := y - dy;
until (abs(dx) + abs(dy)) / (abs(x) + abs(y)) < eps;
end; {----- newcom -----}
procedure residu(nr :byte; r :arrayd;
r0, x0, y0 :double; var kr :byte);
function sign(a :double) :double;
begin
if a >= 0 then sign := 1.0 else sign := -1.0
end;
var
phi, phip, dphi, darg, x, y, u, v, t :double;
i, j :integer;
begin
dphi := 2 * pi / nr / 16;
darg := 0.0;
for i := 0 to nr * 16 do
begin
x := x0 + r0 * cos(dphi * i);
y := y0 + r0 * sin(dphi * i);
u := r[nr+1];
v := 0;
for j := nr downto 1 do
begin
t := x * v + u * y;
u := x * u - y * v + r[j];
v := t
end;
if u = 0.0 then phi := sign(v) * pi / 2.0
else if u > 0.0 then phi := arctan (v / u)
else if y <> 0.0 then
phi := arctan (v / u) + sign(v) * pi
else phi := pi;
if i = 0 then phip := phi
else
begin
if ((abs(phi) > pi/2.0) or (abs(phip) > pi/2.0))
and (sign(phi) <> sign(phip)) then
begin
if sign(phi) > 0.0 then t := phi - phip - 2.0 * pi
else t := phi - phip + 2.0 * pi;
end
else t := phi - phip;
darg := darg + t;
phip := phi
end
end;
kr := round (darg / (2.0 * pi))
end; {----- residu -----}
begin {----- polrtt -----}
ier := 0;
if (na <= 0) or (na > 23) then
begin
ier := 2;
exit
end;
if a[na+1] = 0.0 then
begin
ier := 3;
exit
end;
n := na;
{ «?nN?N??N ???No?? ¬«??N? }
nr := 0;
nrr := 0;
krat[1] := 0;
while (a[1] = 0.0) and (n > 0) do
begin
krat[1] := krat[1] + 1;
n := n - 1;
for i := 1 to n+1 do a[i] := a[i+1];
end;
if krat[1] <> 0 then
begin
inc(nr);
inc(nrr);
qr[nr] := 0.0;
qi[nr] := 0.0
end;
if n = 0 then exit;
if n = 1 then
begin
inc(nr);
inc(nrr);
qr[nr] := -a[1] / a[2];
qi[nr] := 0.0;
krat[nr] := 1;
exit
end;
if n = 2 then
begin
d := sqr(a[2])-4.0*a[1]*a[3];
if abs(d/(sqr(a[1])+sqr(a[2])+sqr(a[3])))
< sqr(eps) then d := 0;
if d = 0 then
begin
inc(nr);
inc(nrr);
qr[nr] := -0.5 * a[2] / a[3];
qi[nr] := 0;
krat[nr] := 2;
exit
end;
if d < 0 then
begin
inc(nr);
qr[nr] := -0.5 * a[2] / a[3];
qi[nr] := 0.5 * sqrt( -d ) / a[3];
krat[nr] := 1;
inc(nr);
qr[nr] := qr[nr-1];
qi[nr] := -qi[nr-1];
krat[nr] := 1
end
else
begin
if a[2] < 0.0 then d := -0.5 * (a[2] - sqrt(d))
else d := -0.5 * (a[2] + sqrt(d));
inc(nr);
qr[nr] := d / a[3];
qi[nr] := 0.0;
krat[nr] := 1;
inc(nr);
qr[nr] := a[1] / d;
qi[nr] := 0.0;
krat[nr] := 1;
inc(nrr,2);
end;
exit
end;
{ oa¬?«???aµ?? »«???«?a C = R * ?
******* R -- ?.«.n. C ? C'
******* T -- »«???«? ? »?«????? ¬«????? }
factor (n, a, r, t, nt);
if nt = 1 then
begin
inc(nr);
inc(nrr);
qr[nr] := -t[1] / t[2];
qi[nr] := 0.0;
krat[nr] := n;
exit
end;
{ e?????N??N ????a nN???o??N????? ¬«??N? }
sturm (nt, t, nre);
inc(nrr, nre);
{ e?????N??N nN???o??N????? ¬«??N? }
if nre > 0 then
for i := 1 to nre do
begin
newrea(nt + 1 - i, t, x);
if ier = 1 then exit;
nr := nr + 1;
qr[nr] := x;
qi[nr] := 0.0;
krat[nr] := 1;
{ e?¬???N??N o?????N??«u« ¬«??? }
for j := nt + 1 - i downto 2 do
t[j] := t[j] + x * t[j+1];
for j := 1 to nt + 1 - i do t[j] := t[j+1]
end;
{ e?????N??N ¬«?»?N¬???? ¬«??N? }
nc := (nt - nre) div 2;
if nc > 0 then
for i := 1 to nc do
begin
newcom(2 * (nc+1-i), t, x, y);
if ier = 1 then exit;
for j := nr + 1 to nr + 2 do
begin
qr[j] := x;
qi[j] := abs(y);
krat[j] := 1
end;
nr := nr + 2;
qi[nr] := -qi[nr];
{ e?¬???N??N o?????N??«u« ¬«??? }
temp := sqr(x) + sqr(y);
t[2*(nc+1-i)] := t[2*(nc+1-i)] + 2*x*t[2*(nc-i)+3];
for j := 2 * (nc - i) + 1 downto 3 do
t[j] := t[j] + 2 * x * t[j+1] - temp * t[j+2];
for j := 1 to 2 * (nc - i) + 1 do
t[j] := t[j+2];
end;
d := 0;
for i := 1 to nr do
d := d + sqrt(sqr(qr[i]) + sqr(qi[i]));
d := d/nr;
for i := 1 to nr do
begin
if abs(qr[i])/d < eps then qr[i] := 0;
if abs(qi[i])/d < eps then qi[i] := 0;
end;
{ e?????N??N ¬?a??«??? ¬«??? }
if nt < n then
begin
n0 := 0;
if (qr[1] = 0.0) and (qi[1] = 0.0) then n0:=1;
for i := 1 to nre + nc do
begin
{ e?????N??N ???. ?a???«???? }
if i <= nre then ii := n0 + i
else ii := n0 + 2 * i - nre - 1;
ind := -1;
for jj := n0 + 1 to n0 + nre + 2*nc do
if jj <> ii then
begin
if ind < 0 then
begin
y := sqr(qr[ii] - qr[jj]);
temp := y + sqr(qi[ii] - qi[jj]);
ind := 1;
end
else
begin
y := sqr(qr[ii] - qr[jj]);
if temp > y + sqr(qi[ii] - qi[jj]) then
temp := y + sqr(qi[ii] - qi[jj]);
end;
end;
{ Ean??? «¬????«??? o«¬??u «?N?Nn?«u« ¬«??? }
temp := 0.5 * sqrt(temp);
x := qr[ii];
y := qi[ii];
residu (n - nt, r, temp, x, y, kr);
if kr > 0 then
begin
if i <= nre then krat[ii] := krat[ii] + kr
else
begin
krat[ii] := krat[ii] + kr;
krat[ii+1] := krat[ii+1] + kr;
end
end;
end; { for }
end; { if }
j := 0;
for i := 1 to nr do j := j + krat[i];
if j <> na then ier := 4;
end; {----- polrtt -----}
procedure tabfreq;
const eps = 1.0e-40;
var
i, j, y, js :word;
w0, w1, dw, w, am, p, x :double;
code, count :integer;
s :string[32];
nrb, nrrb :byte;
qrb, qib :arrayd;
krb :arrayb;
rdk :char;
begin
vx := '1(t)';
tconst := 1;
ncx := 2;
cx[1] := 1; cx[2] := -0.5; cx[3] := 0.2;
//xlo := 10; ylo := 10; xhi := 90; yhi := 90;
//equiv := false; grid := false;
n := 5;
a0[1] := 1; a0[2] := 2; a0[3] := 3; a0[4]:=4; a0[5]:=5; a0[6]:=6;
m := 0;
b0[1] := 1;// b0[2] := 2;// b0[3] := 3; b0[4]:=4;
///------------
w0:=1; // нач частота
//until (code = 0) and ( ((a0[1]=0) and (w0 > 0)) or
// ((a0[1]<>0) and (w0 >= 0))) ;
w1:=10; // кон частота
dw:=1; // шаг
//until (code = 0) and (dw < (w1 - w0));
//writeln(fq, 'w':16, 'A(w)':16, 'A(w) дБ':16,
// 'fi(w) град':16);
td:=0;
tr:=td;
polrtt(n, a0, qr, qi, nr, nrr, kr, ier);
rooterr;
if (ier > 0) and (ier < 5) then exit;
if m > 0 then
begin
polrtt(m, b0, qrb, qib, nrb, nrrb, krb, ier);
rooterr;
if (ier > 0) and (ier < 5) then exit
end;
j := 0;
js := 0;
rdk := #32;
repeat
w := w0 + j*dw;
inc(j);
count := 0;
am := abs(b0[m+1]/a0[n+1]);
p := 0;
if b0[m+1]*a0[n+1] < 0.0 then
p := p - pi;
if m > 0 then
begin
for i := 1 to nrrb do
for jj := 1 to krb[i] do
begin
am := am*sqrt(sqr(qrb[i]) + sqr(w));
p := p + atan2(-qrb[i], w)
end;
for i := nrrb + 1 to nrb do
begin
for jj := 1 to krb[i] do
begin
x := sqr(sqr(qrb[i]) + sqr(qib[i]) + sqr(w)) -
sqr(2*qib[i]*w);
if x < eps then inc(count)
else am := am*sqrt(x);
p := p + atan2(sqr(qrb[i]) + sqr(qib[i]) - sqr(w),
-2*qrb[i]*w)
end;
inc(i)
end
end;
for i := 1 to nrr do
for jj := 1 to kr[i] do
begin
am := am/sqrt(sqr(qr[i]) + sqr(w));
p := p - atan2(-qr[i], w)
end;
for i := nrr + 1 to nr do
begin
for jj := 1 to kr[i] do
begin
x := sqr(sqr(qr[i]) + sqr(qi[i]) + sqr(w)) -
sqr(2*qi[i]*w);
if x < eps then dec(count)
else am := am/sqrt(x);
p := p - atan2(sqr(qr[i]) + sqr(qi[i]) - sqr(w),
-2*qr[i]*w)
end;
inc(i)
end;
if count > 0 then am := 0;
if count = 0 then
begin
writeln(fixn(w, nfx):16, fixn(am, nfx):16,
fixn(20*ln(am)/ln(10.0), nfx):16,
fixn(p*180.0/pi, nfx):16);
writeln(fq, fixn(w, nfx):16, fixn(am, nfx):16,
fixn(20*ln(am)/ln(10.0), nfx):16,
fixn(p*180.0/pi, nfx):16)
end
else
if count > 0 then
begin
writeln(fixn(w, nfx):16, fixn(am, nfx):16,
'- тьма':16, fixn(p*180.0/pi, nfx):16);
writeln(fq, fixn(w, nfx):16, fixn(am, nfx):16,
'- тьма':16, fixn(p*180.0/pi, nfx):16)
end
else
begin
writeln(fixn(w, nfx):16,'Резонанс':24);
writeln(fq,fixn(w, nfx):16,'Резонанс':24)
end;
inc(js);
if (js = 20) and (w < w1) then
begin
js := 0;
writeln;
fastcenter(cht, 23, $70);
rdk := readkey
end
until (w >= w1) or (rdk = #27);
close(fq);
writeln;
if rdk <> #27 then
begin
fastcenter(' Конец таблицы ',22, textattr);
fastcenter(cht, 23, $70);
readkey
end;
normalcursor;
window(1, 1, 80, 25)
end; {----- tabfreq -----}
begin {----- main -----}
textattr := $1b;
if registerbgidriver(@vgadrv) < 0 then
begin
writeln(' Ошибка при регистрации драйвера.');
halt(1);
end;
clrscr;
tabfreq;
end.
|
|
Перенос исходников из TP в Delphi, Что-то не получается. 
Загрузка ...
