C Programma vychisleniia udarnogo spektra dlia vosproizvedeniia
C VUP v tcekhe 7
REAL eps,Ap,FZ(101),DIS(100),f(101),fc(100),gam1(100),SHy(100),
&Sy(100),SpN(100)
C eps -- postoiannaia raspredeleniia tcentralnykh chastot polosovykh
C filtrov apparatury vosproizvedeniia VUP ( Dlia 1/3 oktavnykh
C polos eps=0.23) 0.13 dlia tc. 7
C N -- poriadok polosovogo filtra apparatury vosproizvedeniia VUP
C M -- chislo polos polosovogo filtra apparatury vosproizvedeniia VUP
C f(M+1) -- granitcy chastot (Gtc) polosovykh filtrov apparatury
C vosproizvedeniia VUP
C Ap,ed.g -- maksimalnoe znachenie VUP,ukazannoe v normiruiushchem dokumente
C K -- chislo polos spektra zadaniia VUP
C FZ(K+1),Gtc -- chastoty zadaniia spektra VUP
C DIS(K) -- massiv dispersii (%) spektra zadaniia VUP
COMMON K,FZ,SPN
EXTERNAL FLIN
data M/31/,f/1.76,2.22,2.80,3.53,4.45,5.60,7.06,8.90,11.20,14.13,
& 17.8,22.3,28.06,35.6,45,55,70,90,113,141,181,
%226,282,356,450,565,710,900,1130,1415,1800,2260,69*0/,
&fc/2.0,2.5,3.1,4.0,5.0,6.3,7.9,10.0,12.6,15.9,
&20,25,31.5,40,50,63,80,100,125,160,200,250,315,400,500,
&630,800,1000,1250,1600,2000,69*0/
open(unit=1,status='unknown',file='rezult')
C******************************************************************
801 write (*,*) ' Vvedite velichinu EPS , gde eps -- postoiannaia
& raspredeleniia tcentralnykh chastot polosovykh
& filtrov apparatury vosproizvedeniia VUP
& ( Dlia 1/3 oktavnykh polos vvedite eps=0.23,
& 0.13 DLIa Tc 7)'
read (*,*,err=802) eps
goto 201
802 write (*,*) ' Vy oshiblis !'
goto 801
C *****************
201 write(*,*) ' Vvedite Ap maksimalnoe znach-ie VUP po norme'
N=4
read (*,*,err=202) Ap
goto 203
202 write (*,*) ' Vy oshiblis! '
goto 201
c ****************
203 write (*,*) ' Vvedite K norme'
read (*,*,err=204) K
goto 205
204 write (*,*) ' Vy oshiblis! '
goto 203
c ***************
205 write (*,*) ' Vvedite massiv chastot FZ'
fz(1)=0.
do 1111 i=1,K+1
207 write(*,2222) I
2222 format (' FZ(',i2,')= ',$)
read(*,*,err=206) FZ(I+1)
goto 33
206 write (*,*) ' Vy oshiblis! Vvedite zanovo '
goto 207
33 if (i.eq.1) goto 1111
if (FZ(I+1).gt.0.and.FZ(I+1).gt.FZ(I)) goto 1111
write (*,700) i,i-1
700 format(' Vy oshiblis ! U Vas FZ(',i2,') menshe, chem FZ(',i2,')
& !'/' Proverte iskhodnye dannye. Vvedite zanovo')
goto207
1111 CONTINUE
c ****************************
fz(k+3)=2500.
2003 write (*,*) ' ‚¢¥¤¨â¥ massiv DIS(%) dlia normy VUP -- K shtuk'
DIS(1)=0.
do 53 i=1,K
212 write(*,444) I
444 format (' DIS(',i2,')= ',$)
read(*,*,err=210) DIS(I+1)
goto 53
210 write (*,*) ' Vy oshiblis ! Vvedite zanovo'
goto 212
53 continue
DIS(k+2)=0.
k=k+2
C PROVERKA PRAVILNOSTI VVODA MASSIVA DIS
SUMD=0.
DO 2000 I=1,K
2000 SUMD=SUMD+DIS(I)
IF (ABS(SUMD-100.).LT.5.E-1) GOTO 2001
WRITE (*,*) ' Vy oshiblis u Vas summapnaia dispepsiia ne 100 '
write (*,*) ' ******* Vvedite zanovo i ppavilno ! ****'
k=k-2
goto 2003
c ****************************
2001 write (1,*) ' Iskhodnye dannye'
write (1,*) ' *******************'
write(1,2010) AP,eps,K-2
2010 format (2x,'** Ap= ',f7.2,' ** EPS= ',f5.3,' ** K= ',i2,/)
write(1,2007)
2007 format (' FZ(I) - FZ(I+1) ',' DIS')
write (1,2008)
2008 format (' ------------------------------ ')
do 2005 i=2,k-1
2005 write (1,2006) fz(I),fz(I+1),dis(I)
2006 format (2x,f7.1,' - ',f7.1,3x,f7.2)
write (1,2011)
2011 format (////,' REZULTATY RASChETA',/)
C
write(*,123)
123 format(
*' **************************************'/
*' * *'/
*' * Zhdite idet schet!!! *'/
*' * *'/
*' **************************************')
C ** Vych-ie norm. spektralnoi plotnosti, zadavaemogo VUP
DO 3 i=1,K
3 SpN(i)=DIS(i)/100./(FZ(I+1)-FZ(I))
C1 Vychislenie koeffitcientov gamma1(i) dlia kazhdogo chastotnogo poddiapazona
C filtrov apparatury vos-iia VUP
C** write (1,*) ' i f(i) f(i+1) fc(i) cc '
DO 2 i=1,M
C flintemp = FLIN (1)
C print * , flintemp
cc=OIN(f(i),f(i+1),1.e-3,0)
C cc=OIN(f(i),f(i+1),1.e-3,FLIN)
gam1(i)=sqrt(cc/(f(i+1)-f(i)))
3330 format (2x,i3,4(2x,e11.5))
2 continue
C2 Paschet maks. znachenii otnositelnogo udarnogo spektra
DO 4 i=1,M
SHy(i)=gam1(i)*f(i+1)
3334 format (2x,i3,2(2x,e11.5))
4 continue
C3 Vybor maksimalnogo SHy0
Nmax=1
SHmax=SHy(1)
DO 20 i=2,M
IF (SHmax.GE.SHy(i)) goto 20
Nmax=i
SHmax=SHy(i)
20 CONTINUE
C ** Opr-ie absoliutnogo znacheniia udarnogo spektra
Sy0=3.141593/SQRT(2.*eps/N)*Ap
C4 Opr-em znacheniia udarnogo spektra na drugikh chastotakh
write (1,900)
900 format (3x,43('-'))
write (1,901)
901 format (3x,'| i : f(i) : f(i+1) : fc(i),Gtc : Sy(i) |')
write (1,900)
DO 5 i=1,M
Sy(i)=fc(i)/fc(Nmax)*gam1(i)/gam1(Nmax)*Sy0
write (1,30) i,f(i),f(i+1),fc(i),Sy(i)
5 continue
30 format (4x,i2,3x,f6.1,3x,f6.1,3x,f6.1,1x,f10.2)
write (*,*) 'STOP'
end
c********************************************************
FUNCTION FLIN (X0)
REAL X(101),Y(100)
COMMON N,X,Y
DO 1 I=1,N
IF (X0.GE.X(i).AND.X0.LT.X(i+1)) GOTO 3
GOTO 1
3 FLIN=Y(I)
GOTO 4
1 CONTINUE
4 RETURN
END
c****************************************************
FUNCTION OIN (A,B,EPS,F)
N=1
1 OIN=0
if (n.GT.512) goto 5
DL=(B-A)/N
DO 2 I=1,N
X1=A+(I-1)*DL
X2=X1+DL
C 2 OIN=OIN
2 OIN=OIN+0.5*(F(X1)+F(X2))*DL
s=oin
IF(N-1) 3,3,4
3 N=N*2
GO TO 1
4 if(abs(s).le.1.e-6) goto 3
EPS1=ABS((OIN-S)/OIN)
IF(EPS1.LE.EPS) GO TO 5
GOTO 3
5 RETURN
END