{ Diagnostika nasosa }
{$N+}
uses crt,graph,bmp_plus,Windos;
const jjk=2;{L=5;}n=12;pkr=100;fmax=11025/2; {alf1=0.5;}
type mascp=array[1..{2048}4096] of single ;
mask=array[0..{1024}2048] of single ;
mascpptr=^mascp;
mas=array[1..20,0..30] of single;
mast=array[0..30] of single;
masL=array[1..10] of single;
mas3=array[0..10] of single;
masd=array [1..3] of integer;
masf=array [1..10] of text;
maskd=array [0..10] of string;
maskdd=array [1..10] of single;
masust=array [1..4] of single;
var ans,no,yes, ch: char; xx: byte; datafile : file of byte; frr,fr,fp, fpi: text;s,mpp,fname,ds:string;
kdj1,kdj,kj,kj1, kd, nd, ig, tip, jj, mp, kn,kv, cnt,m:integer; data,datai: masd;
sabb, sgarm, ss: maskd;Fs, Asr :maskdd;ficx: masf; AAs:mas3;
alfa,xxk, betdd,prd, MinTr,{Mintrem,} Minn11,MinTrl1,al :maskdd;
const Au : masust = (0.25,0.41,0.63,1);
var dt,a,f,xk:mask;
x,y:mascpptr;
ygg, yss, yg,Fg:mas;
Ft,skrat, Ygpr: masL;
Tx,as,asi : mast;
StTr,Tr,Tr1,n1,Tr2,n2,alfs,bets,alff,bet,Votn,Votn1,alffa,alf,Fdd,Tremm, n11, nn,TTTr,Trl1: masL;
ftk,fm,fv,d,kftk,kfn,kfv,dtk,dv,dn,z,df,km,Wob,Asned,lx,ly,
Sa,Tcrj,Trj,AprS,STrl1,bt,yys,ysa,fd,Tppr, sygg,kper,Pikfak,Ass,Ys,Fdv,Fk,mx,skx, wob1,maxx,sx,sy,
Aaotn,Apr,Ao,MaxFdd,MaxFs,Mints,Mintls,MinTrr: single;
kjj, ttr, mm, nm, i,j,k,L: integer;
func,sd,sd1:string;
Gd,Gm,Xc,Xb,Yc,Yb:integer;
ii, dlinaOsiX,dlinaOsiY:integer;
Procedure Sumgarm(var Ax : mask; kn1,kv1 :integer; var SYg: single);
var s: single; i : integer;
Begin
s:=0;
for i:=kn1 to kv1 do
begin
s:=S+sqr(ax[i]);
{ sy:=Sy+ay[i];}
end;
SYg:=sqrt(s);
End;
Procedure Maxgarm(var P:mask; knn,kvv: integer; var maxgg:integer);
var maxg,mk,max:single;im :integer;
begin
mk:=P[knn];
im:=knn;
maxg:=fmax*(km/2)/k*im;
For i:=knn to kvv do
begin
if p[i]>mk then
begin
mk:=p[i];
Max:=mk;
im:=i;
Maxg:=fmax*(km/2)/k*im;
end; end;
maxgg:=round(maxg/f[1]);
end;
Procedure Podshipnik(var wob2 : single; var aF: masL; var awob: single);
var Am,maxf:single; im:integer;
Function Max(var p: mask):single;
var mk:single; knn,kvv :integer;
begin
knn:=round(0.9*wob2/60/f[1]);
kvv:=round(1.1*wob2/60/f[1]);
mk:=P[knn];
im:=knn;
maxf:=fmax*(km/2)/k*im;
For i:=knn to kvv do
begin
if p[i]>mk then
begin
mk:=p[i];
Max:=mk;
im:=i;
Maxf:=fmax*(km/2)/k*im;
end; end;
end;
begin
Am:=Max(a);
awob:=maxf*60;
For i:=1 to L do
aF[i]:=maxf*skrat[i];
end;
Procedure BuildP(var AA,tt:mask; Ft: masL; wob11,w :single; fname: string);
var Fg: masL; fgr, amin,fmin,Amax,Fmaxx : single; a1,t1: mas3;kf,k1: integer;
Function Max(var p: mask):single;
var mk:single;
begin
mk:=P[1];
For i:=2 to k do
if p[i]>mk then mk:=p[i];
Max:=mk;
end;
Function Min(var pp: mask): single;
var mmk:single;
begin
mmk:=PP[1];
For i:=2 to k do
if pp[i] < mmk then mmk:=pp[i];
Min:=mmk;
end;
begin
if w=2 then
begin
Amin:=Min(aa);
if Amin <= 0 then
begin
for i:=1 to k do
aa[i]:=aa[i]+abs(Amin);
end
else begin
for i:=1 to k do
aa[i]:=aa[i];
end;
Fmaxx:=tt[k];
Amax := Max(aa);
end;
if w=1 then begin
Fmaxx:=1.05*fd;
Amax := Max(aa);
end ;
Gd:=Detect;
InitGraph(Gd,Gm,'C:\PASCAL\BGI');
if GraphResult <> grok then
halt(1);
SetBkColor(15);
Xc:=100;
Xb:=(GetMaxX div 2);
Yc:=420;Yb:=50;
dlinaOsiX:=500;
dlinaOsiY:=400;
ly:=dlinaOsiY/(1.1*Amax);
lx:=dlinaOsiX/Fmaxx*0.9;
SetColor(8);
Line(Xc,Yc,Xc+dlinaOsiX,Yc);
Line(Xc,Yc,Xc,Yc-dlinaOsiY);
OutTextXY(xc-20,yc-dlinaOsiY-10,'A ');
if w=2 then
OutTextXY(xc+dlinaOsiX-10,yc-14,'T,c')
else
OutTextXY(xc+dlinaOsiX-40,yc-14,'f,ѓж');
for i:=0 to 10 do
begin
t1[i]:=(Fmaxx )/10*(i);
Line(Xc+round(t1[i]*lx),Yc-2,
Xc+round(t1[i]*lx),Yc+2);
if (w=2) then
str(t1[i]:2:2,sd)
else
str(t1[i]:2:0,sd);
OutTextXY(Xc+round(t1[i]*lx),Yc+6,sd);
end;
for i:=0 to 10 do
begin
a1[i]:=Amax/10*i;
Line(Xc-2,Yc-round(a1[i]*ly),
Xc+2,Yc-round(a1[i]*ly));
str(a1[i]:2:3,sd1);
OutTextXY(Xc-46,Yc-round(a1[i]*ly),sd1);
end;
if w <> 2 then
begin
SetColor(red);
fmin:=0;
for j:=1 to L do
begin
kn:=round(0.9*Ft[j]/f[1]);
kv:=round(1.1*Ft[j]/f[1]);
Maxgarm(A,kn,kv,ig);
Fg[j]:=f[ig];
if (Fg[j]-fmin) > 0 then
begin
Line(Xc+round((Fg[j]-fmin)*lx),Yc,Xc+round((Fg[j]-fmin)*lx),Yc-dlinaOsiY);
OutTextXY(xc-25+round((Fg[j]-fmin)*lx),yc-dlinaOsiY-round(10*0.1*j), sabb[j]);
SetColor(blue);
str(Fg[j]:3:0,sd);
OutTextXY(Xc+round((Fg[j]-fmin)*lx)-15,Yc+17,sd);
end; end;end;
SetColor(8);
if w=2 then
k1:=k;
if (w=1) or (w=3) then
k1:=round(fd*1.05/f[1]);
MoveTo(Xc + round(tt[1]*lx),Yc-round(aa[1]*ly));
for i:=2 to k1 do
begin
SetColor(Green);
LineTo(Xc + round(tt[i]*lx),Yc-round(aa[i]*ly));
end;
{ save_bmp(1,1,640,480,fname,4); }
ReadKey;
CloseGraph;
End;
procedure Spektr(var AX, AY; Dim: Word; D: Integer);
var
x: array [1..4096] of Single absolute AX;
y: array [1..4096] of Single absolute AY;
I, J, N, L, K, LE, LE1,IP, NV2, NM1: Integer;
Arg, U1, U2, U3, C, S, T1, T2, T3, T4: Single;
begin
N := 1 shl Dim;
if D = -1 then FillChar(Y, N*SizeOf(Single), 0);
for L := 1 to Dim do
begin
LE := 1 shl (Dim+1-L);
LE1 := LE div 2;
U1 := 1;
U2 := 0;
Arg := Pi/LE1;
C := Cos(Arg);
S := D*Sin(Arg);
for J := 1 to LE1 do
begin
I := J;
while I <= N do
begin
IP := I + LE1;
T1 := X[i] + X[IP];
T2 := Y[i] + Y[IP];
T3 := X[i] - X[IP];
T4 := Y[i] - Y[IP];
X[IP] := T3*U1 - T4*U2;
Y[IP] := T4*U1 + T3*U2;
X[i] := T1;
Y[i] := T2;
I := I + LE;
end;
U3 := U1*C - U2*S;
U2 := U2*C + U1*S;
U1 := U3;
end;
end;
NV2 := N div 2;
NM1 := N-1;
J := 1;
for I := 1 to NM1 do
begin
if I < J then
begin
T1 := X[J];
T2 := Y[J];
X[J] := X[i];
Y[J] := Y[i];
X[i] := T1;
Y[i] := T2;
end;
K := NV2;
while K < J do
begin
J := J - K;
K := K div 2;
end;
J := J + K
end;
if D = 1 then Exit;
for I:=1 to N do
begin
X[i] := X[i] / N*2;
Y[i] := Y[i] / N*2;
end;
X[1] := 0;
end;