File: KDI.FT of Tape: Various/ETH/f4
(Source file text)
SUBROUTINE DIAFOU(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 EPS/1.E-7/ C TEST OUTPUT 600 FORMAT(1H0,16(F7.2,1X)) 601 FORMAT(1H ) 602 FORMAT(1H ,16(F7.2,1X)) C IF(NA.LE.1) GO TO 219 DO 201 I=2,NA E(I-1)=E(I) 201 CONTINUE E(NA)=0. BX=0. FX=0. J=0 C JIT=0 DO 212 L=1,NA J=0 H=EPS*(ABS(D(L))+ABS(E(L))) IF(BX.LT.H) BX=H DO 202 M=L,NA IF(ABS(E(M))-BX)203,203,202 202 CONTINUE 203 CONTINUE IF(M.EQ.L) GOTO 211 204 CONTINUE IF(J.EQ.30) GOTO 217 J=J+1 P=(D(L+1)-D(L))/(2.*E(L)) R=SQRT(P*P+1.) H = D(L) - E(L)/(P+SIGN(R,P)) DO 205 I=L,NA D(I)=D(I)-H 205 CONTINUE FX=FX+H P=D(M) CO=1. S=0. M1=M-1 ML=M1+L DO 210 II=L,M1 I=ML-II G=CO*E(I) H=CO*P IF(ABS(P)-ABS(E(I)))207,206,206 206 CONTINUE CO=E(I)/P R=SQRT(CO*CO+1.) E(I+1)=S*P*R S=CO/R CO=1./R GO TO 208 207 CONTINUE CO=P/E(I) R=SQRT(CO*CO+1.) E(I+1)=S*E(I)*R S=1./R CO=CO/R 208 CONTINUE P=CO*D(I)-S*G D(I+1)=H+S*(CO*G+S*D(I)) DO 209 K=1,NA H=Z(K,I+1) Z(K,I+1)=S*Z(K,I)+CO*H Z(K,I)=CO*Z(K,I)-S*H 209 CONTINUE 210 CONTINUE E(L)=S*P D(L)=CO*P IF(ABS(E(L))-BX)211,211,204 211 CONTINUE D(L)=D(L)+FX C JIT=JIT+J 212 CONTINUE N1=NA-1 RKmTRm5RKmTRm5RKmTRm5RKmTRm5RKmTRm5RKmTRm5RKmTRm5RKmTRm5RKmTRm5RKmTRm5RKmTRm5RKmTRm5RKmTRm5RKmTRm5RKmTRm5RKmTRm5RKmTRm5RKmTRm5RKmTRm5RKmTRm5RKmTRm5RKUuUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUZ(J,I)=Z(J,K) Z(J,K)=P 215 CONTINUE 216 CONTINUE 219 CONTINUE IF (.NOT.ITEST) GO TO 360 WRITE(3,600) (D(J),J=1,NA) WRITE(3,601) DO 301 K=1,NA 301 WRITE(3,602) (Z(K,J),J=1,NA) 360 RETURN 217 CONTINUE STOP 11111 END