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

(Source file text) 

---

	SUBROUTINE SERFOU(IPASS)
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
	REAL NF
C
100	FORMAT(1H1,T10,'PASS 1 SEARCH;   CHI = ',G14.5,//)
110	FORMAT(1H1,T10,'PASS 2 SEARCH;   CHI = ',G14.5,//)
120	FORMAT(1H0,T10,'FINAL  SEARCH;   CHI = ',G14.5,//)
130	FORMAT(1H ,T10,'NEW KBLOW =',I5,/)
160	FORMAT(1H ,T10,'NF-PH-AF-TA =',4(G14.5,2X),//)
C
	KEEP=K1
	KBLMIN=FLOAT(N/NP)*1.5
	KLAST=KMAX+1
	INEW=ISIGN(1,IPASS)
	IF (IPASS.GT.0) WRITE(3,100) CHI
	IF (IPASS.LT.0) WRITE(3,110) CHI
	IF (IPASS.EQ.0) WRITE(3,120) CHI
	IF (IPASS.EQ.0) KLAST=KMAX*2+1
	IF (IPASS.LE.0) GO TO 6
	KBLOW1=FLOAT((N/NP)*KBLOW)/100.
	TASWI=.F.
	KLAST=KMAX/2+1
	K1=1
2	JA=K1+1
	JE=KMAX*2+1
	DO 5 J=JA,JE
	INDEX(J)=0
5	HIGHT(J)=0.
	GO TO 1
6	DO 4 J=2,K1
	HIGHT(J)=ABS(Q(J,3))
4	INDEX(J)=-INEW*IFIX(Q(J,1)*FLOAT(N)/TWOPI)
1	I=3*N/NP
3	JA=I-KBLOW1
	JE=I-1
	DO 10 J=JA,JE
	IF (A(J+1).LT.A(J)) GO TO 15
10	CONTINUE
	JA=I
	JE=I+KBLOW1/2-1
	DO 12 J=JA,JE
	IF (A(J+1).GT.A(J)) GO TO 20
12	CONTINUE
	GO TO 35
15	JA=I
	JE=I+KBLOW1-1
	DO 30 J=JA,JE
	IF (A(J+1).GT.A(J)) GO TO 20
30	CONTINUE
	JA=I-KBLOW1/2
	JE=I-1
	DO 32 J=JA,JE
	IF (A(J+1).LT.A(J)) GO TO 20
32	CONTINUE
35	HIGH=A(I)*FLOAT(N/NP)
	IND=I*INEW
	DO 40 K=2,KLAST
	IDIST=IABS(I-IABS(INDEX(K)))
	IF (IDIST.LT.KBLMIN) GO TO 45
	IF (IDIST.GE.2*KBLMIN) GO TO 36
	DO 37 LL=2,KLAST
	IF (K.EQ.LL) GO TO 37
	IDIST=IABS(IABS(INDEX(K))-IABS(INDEX(LL)))
	IF (IDIST.LT.KBLMIN) GO TO 45
37	CONTINUE
36	IF (HIGH.LT.HIGHT(K)) GO TO 40
	IF (K.EQ.KLAST) GO TO 52
	LE=KLAST-K
	DO 50 LL=1,LE
	L=KLAST-LL
	HIGHT(L+1)=HIGHT(L)
	INDEX(L+1)=INDEX(L)
	IF (IPASS.EQ.0) GO TO 50
	DO 53 M=1,4
53	Q(L+1,M)=Q(L,M)
50	CONTINUE
52	HIGHT(K)=HIGH
	INDEX(K)=IND
	IF (K1.LT.KLAST) K1=K1+1
	GO TO 45
40	CONTINUE
45	I=I+KBLOW1/2-1
20	I=I+1
	IF (I.LE.N/2-KBLOW1) GO TO 3
	IF (IPASS.LE.0) GO TO 25
	CALL TAUFOU(INDEX(2),FNU,PHI,AF,TAU)
	IF (ABS(TAU).LT.2.) GO TO 25
	IF (TASWI) GO TO 25
	TASWI=.T.
	KBLOW1=KBLOW1*(1.+(ABS(TAU)-2.)/3.)
	K1=2
	WRITE(3,130) KBLOW1
	GO TO 2
25	KK=K1
	HIGH=CHISQ
	IF (IPASS.EQ.0) HIGH=CHISQ/100.
	HIGH=SQRT(HIGH/K1)/2.
	K1=2
	DO 57 I=3,KK
	IF (HIGHT(I).GT.HIGH) GO TO 56
	INDEX(I)=0
	HIGHT(I)=0.
	GO TO 57
56	K1=K1+1
57	CONTINUE
	DO 60 I=2,K1
	IF (INDEX(I)*INEW.LT.0) GO TO 60
CDC	REMOVE 5
	MID=INDEX(I)*INEW-64
	IF (MID.LT.0) MID=0
	MIDMAX=N/2-64
	IF (MID.GT.MIDMAX) MID=MIDMAX
	CALL SCOPE(.T.,.T.,MID)
	CALL TAUFOU(INDEX(I)*INEW,FNU,PHI,AF,TAU)
	IF (IPASS.EQ.0) GO TO 58
	Q(I,1)=TWOPI*FNU/NP
	Q(I,2)=PHI
	Q(I,3)=AF
	Q(I,4)=-TAU
58	NF=FNU/DL
	PH=PHI*180./PI
	AM=AF*EICH
	TA=-TAU/DL
	WRITE(3,160) NF,PH,AM,TA
60	CONTINUE
	IF (IPASS.EQ.0) K1=KEEP
	RETURN
	END

---