File: KTR.FT of Tape: Various/ETH/f4
(Source file text)
SUBROUTINE TRIFOU(NA) 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 DATA TOL/1.E-07/ C TEST OUTPUT 600 FORMAT(1H0,16(F7.2,1X)) 601 FORMAT(1H ) 602 FORMAT(1H ,16(F7.2,1X)) C IF (.NOT.ITEST) GO TO 350 WRITE(3,600) (C(J),J=1,NA) WRITE(3,601) DO 300 K=1,NA 300 WRITE(3,602) (AR(K,J),J=1,NA) 350 Z(1,1)=1. IF(NA.LE.1) RETURN DO 1 I=1,NA DO 1 J=1,NA Z(J,I)=AR(I,J) 1 CONTINUE C DO 9 II=2,NA L=NA-II I=L+2 FX=Z(I,I-1) G=0. IF(L.EQ.0) GOTO 100 DO 2 K=1,L G=G+Z(I,K)**2 2 CONTINUE 100 CONTINUE H=G+FX*FX IF(G.GT.TOL) GOTO 3 E(I)=FX H=0. GOTO 9 3 L=L+1 G=-SIGN(SQRT(H),FX) E(I)=G H=H-FX*G Z(I,I-1)=FX-G FX=0. DO 6 J=1,L Z(J,I)=Z(I,J)/H G=0. DO 4 K=1,J G=G+Z(J,K)*Z(I,K) 4 CONTINUE J1=J+1 IF(J1.GT.L) GOTO 110 DO 5 K=J1,L G=G+Z(K,J)*Z(I,K) 5 CONTINUE 110 CONTINUE E(J)=G/H FX=FX+G*Z(J,I) 6 CONTINUE HH=FX/(H+H) DO 8 J=1,L FX=Z(I,J) G=E(J)-HH*FX E(J)=G DO 7 K=1,J Z(J,K)=Z(J,K)-FX*E(K)-G*Z(I,K) 7 CONTINUE 8 CONTINUE 9 D(I)=H D(1)=0. E(1)=0. DO 15 I=1,NA L=I-1 IF(ABS(D(I)).LT.1.E-08)GO TO 13 IF(L.EQ.0) GOTO 13 DO 12 J=1,L G=0. DO 10 K=1,L G=G+Z(I,K)*Z(K,J) 10 CONTINUE DO 11 K=1,L Z(K,J)=Z(K,J)-G*Z(K,I) 11 CONTINUE 12 CONTINUE 13 D(I)=Z(I,I) Z(I,I)=1. IF(L.EQ.0) GOTO 15 DO 14 J=1,L Z(I,J)=0. Z(J,I)=0. 14 CONTINUE 15 CONTINUE RETURN END