File: SCOFOU.FT of Tape: Various/ETH/f2

(Source file text) 

---

	SUBROUTINE SCOPE(LALL,LONE,ISTARP)
C
	COMMON /TITLE/ ADENT,GLOBAL,RUN,ICREAT
	COMMON /FITPAR/ JIT,FISTOP,AMARQI,UPMARQ,DNMARQ,VARI,
     $  UPVAR,DNVAR,VARMIN,MLOOP,LOOPLW,ISTART,ISTOP,ITEST,IDEFIX
	COMMON /PARAM/ DKHI,SHFACT,CHISQ,ITORQ,IDILA,DK,DL,HANG
     $  ,HUP,HDOWN,AMI,PS,PT,SOLLT,TEMP,TV,ES,AKL,AKV,CAP,EICH
	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 ITORQ,IDILA,ITEST,TASWI
C
	LOGICAL LALL,LONE
C
CDC100	FORMAT(1H1,T50,#INITIAL  SPECTRUM#,1H )
CDC105	FORMAT(1H1,T50,#RESIDUAL SPECTRUM#,1H )
CDC110	FORMAT(1X,#FREQUENCY (T)#,T107,#AMPLITUDE#,7X,#PHASE#/)
CDC120	FORMAT(1X,1PE11.4,T19,80A1,T105,1PE11.4,6X,0PF7.2)
C
CDC	IF (LONE) WRITE(3,100)
CDC	IF (.NOT.LONE) WRITE(3,105)
CDC	NN=((NP-1)/256+1)*256
CDC	ISTAR=ISTARP
CDC	IST=ISTAR+1
CDC	IEND=ISTAR+NN
CDC	IASCAL=N/NN
CDC	SCAL1=1.E-20
CDC	ISTEP=1
CDC	IF(LALL) ISTEP=IASCAL/2
CDC	DO 10 I=IST,IEND
CDC	J=I*ISTEP
CDC	COMP=ABS(A(J))*IASCAL
CDC	IF (COMP.GT.SCAL1) SCAL1=COMP
CDC10	CONTINUE
CDC	FAKTOR=79./SCAL1
CDC	DO 12 J=1,80
CDC12	PLTBUF(J)=1H 
CDC	DO 15 I=IST,IEND
CDC	J=I*ISTEP
CDC	IF(LALL) PHA=B(J)*180./PI
CDC	AMPL=A(J)*IASCAL
CDC	IF(LALL) FNU=J/(IASCAL*DK*1.E-3*NN)
CDC	LINDEX=1+INT(FAKTOR*AMPL+.5)
CDC	AMPL=AMPL*EICH
CDC	PLTBUF(LINDEX)=1H*
CDC	WRITE(3,120) FNU,(PLTBUF(K),K=1,80),AMPL,PHA
CDC	PLTBUF(LINDEX)=1H 
CDC15	CONTINUE
CDC	RETURN
CDC	END
CDC	REMOVE THE FOLLOWING PDP PART
100	FORMAT(1H ,'START NOW:',I4,$)
C150	FORMAT(1H ,'SCALE=',2(F10.4,2X))
C155	FORMAT(1H ,'VALUES=',3(F10.4,2X))
C160	FORMAT(1H ,'FNUPHIAFTAU=',4(F10.4,2X))
170	FORMAT(1H ,/,20(2H+ ,/))
200	FORMAT(I4)
C
	FN=256./1.25
	ISTAR=ISTARP
5	NN=256
C	IF (LONE) GO TO 6
	WRITE(4,100) ISTAR
	READ(4,200) ISTAR
	IF (ISTAR.LT.0) RETURN
6	IF (LALL) NN=NN/2
	IST=ISTAR+1
	IEND=ISTAR+NN
	SCAL1=1.E-20
	SCAL2=1.E-20
	DO 10 I=IST,IEND
	COMP=2.*ABS(A(I))
	IF (COMP.GT.SCAL1) SCAL1=COMP
10	CONTINUE
	DO 15 I=IST,IEND
	FI=FLOAT(I-IST)/FN
15	CALL PLOTR(1,FI,A(I)/SCAL1+.5,I-ISTAR)
	IF (.NOT.LALL) GO TO 30
	DO 20 I=IST,IEND
	COMP=2.*ABS(B(I))
	IF (COMP.GT.SCAL2) SCAL2=COMP
20	CONTINUE
	DO 25 I=IST,IEND
	FI=FLOAT(I+NN-IST)/FN
25	CALL PLOTR(1,FI,B(I)/SCAL2+.5,I-ISTAR+NN)
30	SCAL1=SCAL1/2.
	SCAL2=SCAL2/2.
C	WRITE(4,150) SCAL1,SCAL2
C	SCAL1=B(IST+1)-B(IST)
C	IF (.NOT.LALL) GO TO 50
C	WRITE(4,155) A(IST),B(IST),SCAL1
C	CALL TAUFOU(IST,FNU,PHI,AF,TAU)
C	WRITE(4,160) FNU,PHI,AF,TAU
50	CONTINUE
C	IF (LONE) WRITE(4,170)
C	IF (.NOT.LONE) GO TO 5
	GO TO 5
	RETURN
	END

---