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

(Source file text) 

---

	SUBROUTINE FILFOU
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
	INTEGER IN(10)
	REAL H(84)
C
500	FORMAT(10A6)
510	FORMAT(I5,5X,E20.13)
520	FORMAT(4E20.13)
600	FORMAT(1H0,T10,10A6)
C
	IZAHL=0
1	READ(6,500) IN
	IF (IN(1).NE.6HFILTER) GO TO 1
	IZAHL=IZAHL+1
	IF (IZAHL.NE.IDEFIX) GO TO 1
	WRITE(3,600) IN
	READ(6,510) IFILT,FNORM
	ILINE=IFILT/4+1
	IPOS=-4
	DO 2 I=1,ILINE
	IPOS=IPOS+4
2	READ(6,520) (H(IPOS+K),K=1,4)
	NNEW=NP-IFILT+1
	DO 10 I=1,NNEW
	SUM=0.
	DO 20 K=1,IFILT
	SUM=SUM+H(K)*F(I+K-1)
20	CONTINUE
	F(I)=SUM*FNORM
10	CONTINUE
	K=NNEW+1
	DO 30 I=K,NP
30	F(I)=0.
C	IFILT MUST BE ODD!!!!!!!!!
	IFILT=(IFILT-1)/2
	HUP=HUP/(1+IFILT*DK*.001*HUP)
	NP=NNEW
	HDOWN=HUP/(1+NP*DK*.001*HUP)
	END

---