File: KSC.FT of Tape: Various/ETH/f4

(Source file text) 

---

	SUBROUTINE SCOPE(LALL,LONE,ISTARP)
C
	COMMON /TITLE/ ADENT,GLOBAL,DITOMO,RUN,ICREAT
	COMMON /FITPAR/ JIT,FISTOP,AMARQI,UPMARQ,DNMARQ,VARI,
     $  UPVAR,DNVAR,VARMIN,MLOOP,LOOPLW,ISTART,ISTOP,ITEST,IDEFIX
	COMMON /PARAM/ DKHI,SHFACT(11),CHISQ,DK,DL,HANG
     $  ,HUP,HDOWN,CAPMO,AMI,PS,PT,SOLLT,TEMP,TV,ES,AKL,AKV,EICH
	COMMON /EFFMU/ FRE1(11),FRE2(11),PERMAS(11)
	COMMON /PEAKS/ TASWI,KBLOW,KBLOW1,KMAX,K1,K3,CHI,
     $  Q(11,4),HIGHT(21),INDEX(21)
	COMMON /VECT/ C(44),D1(11,4),DIAGEL(44),D(44),E(44)
	COMMON /DATIN/ F(512),NP
	COMMON /CONST/ PI,TWOPI
	COMMON /PLOTC/ PLTBUF(400)
	COMMON /FAF/ A(2049),B(2049),N
	DIMENSION AR(44,44),Z(44,44)
	EQUIVALENCE (A,AR),(B,Z)
	INTEGER RUN
	REAL K3
	LOGICAL ITEST,TASWI
C
	LOGICAL LALL,LONE
C
100	FORMAT(1H1,T50,"INITIAL  SPECTRUM",1H )
105	FORMAT(1H1,T50,"RESIDUAL SPECTRUM",1H )
110	FORMAT(1X,"FREQUENCY (T)",T107,"AMPLITUDE",7X,"PHASE"/)
120	FORMAT(1X,1PE11.4,T19,80A1,T105,1PE11.4,6X,0PF7.2)
C
	IF (LONE) WRITE(0,100)
	IF (.NOT.LONE) WRITE(0,105)
	NN=((NP-1)/256+1)*256
	ISTAR=ISTARP
	IST=ISTAR+1
	IEND=ISTAR+NN
	IASCAL=N/NN
	SCAL1=1.E-20
	ISTEP=1
	IF(LALL) ISTEP=IASCAL/2
	DO 10 I=IST,IEND
	J=I*ISTEP
	COMP=ABS(A(J))*IASCAL
	IF (COMP.GT.SCAL1) SCAL1=COMP
10	CONTINUE
	FAKTOR=79./SCAL1
	DO 12 J=1,80
12	PLTBUF(J)=1H 
	DO 15 I=IST,IEND
	J=I*ISTEP
	IF(LALL) PHA=B(J)*180./PI
	AMPL=A(J)*IASCAL
	IF(LALL) FNU=J/(IASCAL*DK*1.E-3*NN)
	LINDEX=1+INT(FAKTOR*AMPL+.5)
	AMPL=AMPL*EICH
	PLTBUF(LINDEX)=1H*
C	WRITE(0,120) FNU,(PLTBUF(K),K=1,80),AMPL,PHA
	PLTBUF(LINDEX)=1H 
15	CONTINUE
	RETURN
	END

---