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

(Source file text) 

---

	SUBROUTINE FITFOU
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
CDC	JUST SO WE DON'T MISS THIS VITAL DECLARATION!!
C	DIMENSION=KMAX*4
	REAL DEL(44),ROT(44)
	LOGICAL IMAX
C
600	FORMAT(1H0,T10,'LOOP =',I4,'   VARIANCE CHI =',F8.5//)
601	FORMAT(T10,'REDUCED LINEARITY RANGE =',F6.3)
602	FORMAT(T10,'PARAMETER NO. ',I2,' TRUNCATED')
603	FORMAT(T10,'MARQUARDT PARAM. =',F10.3)
605	FORMAT(///T10,'FIT NICHT BEENDET')
C
	NA=K1*4
	K3=SQRT(FLOAT(K1))
	AMARQ=AMARQI
	LOOP=0
	VAR=VARI
C TEST OUTPUT
110	CALL OUTFOU(0)
	CALL SUBFOU(.F.)
	WRITE(3,600) LOOP,CHI
	IF (LOOP.EQ.0) GO TO 129
	IF (CHISQ.LT.CHILST) GO TO 126
	DO 120 J=1,NA
	J1=((J-1)/4)+1
	J2=J-J1*4+4
	Q(J1,J2)=Q(J1,J2)-DEL(J)
120	DEL(J)=0.
	LOOPLW=LOOP+1
	IF (VAR.GT.VARMIN) GO TO 122
	IF (AMARQI.EQ.0) GO TO 350
	AMARQ=AMARQ*UPMARQ
	WRITE(3,603) AMARQ
	GO TO 180
122	VAR=VAR*DNVAR
	WRITE(3,601) VAR
	CALL SETFOU(VAR)
	DO 124 J=1,NA
	ROT(J)=ROT(J)/DNVAR
	IF (ABS(ROT(J)).LT.1.) GO TO 124
	ROT(J)=SIGN(1.,ROT(J))
	ASSIGN 124 TO MAXRET
	GO TO 400
124	CONTINUE
	GO TO 240 
126	IF (AMARQ.LE.AMARQI) GO TO 127
	AMARQ=AMARQ*DNMARQ
	GO TO 130
127	VAR=VARI
C OR 127	IF (VAR.LT.VARI) VAR=VAR*UPVAR
	IF (IMAX) GO TO 130
	IF (LOOP.LE.LOOPLW) GO TO 130
	IF (SNORM.LT.FISTOP) GO TO 360
	GO TO 130
129	CHIINI=CHI
130	IMAX=.FALSE.
	LOOP=LOOP+1
	CHILST=CHISQ*(1.+FISTOP)
	IF (LOOP.GT.MLOOP) GO TO 350
	CALL SETFOU(VAR)
	CALL NORFOU
180	DO 190 J=1,NA
190	AR(J,J)=DIAGEL(J)*(1.+AMARQ)
	CALL TRIFOU(NA)
	CALL DIAFOU(NA)
	DO 210 J=1,NA
C	COMPULSORY FOR SECOND DERIVS.
	D(J)=ABS(D(J))
	ROT(J)=0.
	DO 220 K=1,NA
220	ROT(J)=ROT(J)+Z(K,J)*C(K)
	IF (ABS(ROT(J)).LT.D(J)) GO TO 230
	ROT(J)=SIGN(1.,ROT(J))
	ASSIGN 214 TO MAXRET
	GO TO 400
230	ROT(J)=ROT(J)/D(J)
214	CONTINUE
210	CONTINUE
240	SNORM=0.
	DO 300 J=1,NA
	DEL(J)=.0
	TNORM=.0
	DO 310 K=1,NA
	TNORM=TNORM+Z(J,K)*Z(J,K)/D(K)
	DEL(J)=DEL(J)+Z(J,K)*ROT(K)
310	CONTINUE
	IF (IMAX) GO TO 330
	SNORM=SNORM+DEL(J)*DEL(J)/TNORM
330	J1=((J-1)/4)+1
	J2=J-J1*4+4
	DEL(J)=DEL(J)*D1(J1,J2)
	Q(J1,J2)=Q(J1,J2)+DEL(J)
	IF (J2.NE.4) GO TO 320
	IF (ABS(Q(J1,4)).LT.30.) GO TO 320
	QM=SIGN(30.,Q(J1,4))
	DEL(J)=QM-Q(J1,4)+DEL(J)
	Q(J1,4)=QM
320	AR(J,J)=TNORM*CHISQ*D1(J1,J2)*D1(J1,J2)
300	CONTINUE
	GO TO 110
C
C FINAL OUTPUT
C
350	WRITE(3,605)
360	CALL OUTFOU(1)
	RETURN
C
C	TRUNCATION INTERNAL SUBROUTINE
C
400	TEMAX=0.
	DO 410 M=1,NA
	TEMTST=ABS(Z(M,J))
	IF (TEMTST.LT.TEMAX) GO TO 410
	TEMAX=TEMTST
	MAXI=M
410	CONTINUE
	IMAX=.TRUE.
	IF (ITEST) WRITE(3,602) MAXI
	GO TO MAXRET,(124,214)
C
	END

---