File: KUNG5F.CD of Tape: Various/ETH/cd1
(Source file text)
KUNGFU,9621,CM60000,CT31. PERMF,LGO. FTN(BL,OPT,R). CATALOG,LGO,FITBIN. .EOR. PROGRAM KUNGFU(OUTPUT=240B,TAPE3=OUTPUT,TAPE5=240B, $ TAPE6=240B,TAPE7=240B) 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 400 FORMAT(1H1,T30,#$$$$$$$$$$ KUNGFU VERSION NUMBER #,A2, $ # $$$$$$$$$$#/) 500 FORMAT(8(F10.4/),6(I5/),L1/,I5/,I5) 600 FORMAT(# FISTOP#0PF10.4/# AMARQI#F10.4/# UPMARQ#F10.4/ $ # DNMARQ#F10.4/# VARI #F10.4/# UPVAR #F10.4/# DNVAR # $ F10.4/# VARMIN#F10.4/# MLOOP #I5/# LOOPLW#I5/# ISTART# $ I5/# ISTOP #I5/# KMAX #I5/# KBLOW #I5/ $ # ITEST #L1/# FILTER#I5/# SERMIN#I5/) C READ(6,500) FISTOP,AMARQI,UPMARQ,DNMARQ,VARI, $ UPVAR,DNVAR,VARMIN,MLOOP,LOOPLW,ISTART,ISTOP, $ KMAX,KBLOW,ITEST,IDEFIX,JIT IF (KMAX.GT.10) STOP 10 C TEST OUTPUT WRITE(3,600) FISTOP,AMARQI,UPMARQ,DNMARQ,VARI, $ UPVAR,DNVAR,VARMIN,MLOOP,LOOPLW,ISTART,ISTOP, $ KMAX,KBLOW,ITEST,IDEFIX,JIT C IVERS=2H5F 1 IOK=0 2 WRITE(3,400) IVERS CALL INIFOU(IOK) NN=NP CALL SUBFOU(.T.) CALL RELFOU(.T.,NN) CALL SCOPE(.T.,.T.,0) CALL SERFOU(1) CALL FITFOU CALL SUBFOU(.T.) CALL RELFOU(.T.,NN) CALL SERFOU(-1) CALL FITFOU CALL OUTFOU(-1) CALL SUBFOU(.T.) CALL RELFOU(.T.,NN) CALL SERFOU(0) CALL SCOPE(.T.,.F.,0) IF (IOK.EQ.2) GO TO 1 IF (IOK.EQ.1) REWIND 5 GO TO 2 END BLOCK DATA BLKFOU 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 DATA ADENT,GLOBAL,RUN,ICREAT /#X#,#XX#,0,0/ DATA JIT,FISTOP,AMARQI,UPMARQ,DNMARQ,VARI,UPVAR, $ DNVAR,VARMIN,MLOOP,LOOPLW,ISTART,ISTOP,ITEST,IDEFIX $ /0,.01,.001,10.0,.2,1.,1.4142,.25,.05,20,1,1,99,.F.,0/ DATA DKHI,SHFACT,CHISQ,ITORQ,IDILA,DK,DL,HANG $ ,HUP,HDOWN,AMI,PS,PT,SOLLT,TEMP,TV,ES,AKL,AKV,CAP,EICH $ /0.,0.,0.,.F.,.F.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0., $ 0.,0.,0.,0.,0./ DATA TASWI,KBLOW,KBLOW1,KMAX,K1,K3,CHI,Q,HIGHT,INDEX $ /.F.,100,8,10,1,1.,1.,44*0.,21*0.,21*0./ DATA C,D1,DIAGEL,D,E /44*0.,44*0.,44*0.,44*0.,44*0./ DATA F,NP /512*0.,512/ DATA PI,TWOPI /3.141592654,6.283185308/ DATA PLTBUF/400*0./ DATA A,B,N /2049*0.,2049*0.,4096/ END SUBROUTINE INIFOU(IOK) 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 501 FORMAT(A1,A2,A1,I2,A4) 502 FORMAT(A1,A2,A1,A2,A4) 503 FORMAT(F8.1) 504 FORMAT(I2,20(/F9.4)) 506 FORMAT(I6) C 615 FORMAT(1H0,T10,#--------------BAD FILE---------------#, $ A1,A2,#D#,I2,///) 620 FORMAT(1H0,T10,#----- FILE NUMBER #,I2, $ # OUT OF RANGE -----#,////) 625 FORMAT(1H0,T10,#----- END-OF-FILE AT FILE #,I3,# -----#,///) C RUN=ISTART-1 GO TO 90 200 WRITE(3,615) ADENT,GLOBAL,RUN 90 READ(5,502) ADENT,GLOBAL,AMIST,AMIST,ICREAT IF (EOF(5).EQ.0.) GO TO 93 RUN=RUN+1 WRITE(3,625) RUN STOP 93 IF (ADENT.NE.1HW.AND.ADENT.NE.1HM) GO TO 90 BACKSPACE 5 READ(5,501) ADENT,GLOBAL,AMIST,RUN,ICREAT IF (RUN.LT.ISTART) GO TO 90 IF (RUN.LE.ISTOP) GO TO 95 WRITE(3,620) RUN STOP 95 READ(5,506) NP IF (NP.LE.0.OR.NP.GT.512) GO TO 200 IF (AMIST.EQ.1HX) IOK=IOK+1 ISTART=RUN IF (IOK.NE.0) GO TO 101 DO 100 I=1,NP 100 READ(5,503) F(I) 101 IF (IOK.EQ.2) READ(5,504) IVAR,(AMIST,K=1,IVAR) READ(5,504) IVAR,DK,HANG,HUP,HDOWN,AMI,PS,PT,SOLLT,TEMP $ ,TV,SHIFT,PERMAS,ES,AKL,CHISQ,AKV,(AMIST,K=1,4) IF (IVAR.LE.20) GO TO 105 READ (5,503) (AMIST,K=21,IVAR) 105 IF (IOK.EQ.1) READ(5,504) IVAR,(AMIST,K=1,IVAR) IF (IOK.EQ.0) GO TO 106 DO 104 I=1,NP IF (IOK.EQ.2) READ(5,503) AMIST READ (5,503) F(I) IF (IOK.EQ.1) READ(5,503) AMIST 104 CONTINUE 106 IF (HUP.GT.20.) HUP=HUP/10000. IF (HDOWN.GT.20.) HDOWN=HDOWN/10000. IF (PT.GT.10.) PT=PT/1000. IF (TEMP.LT.1.) TEMP=5. IF (TEMP.GT.5.) TEMP=5. IF (IDEFIX.NE.0) CALL FILFOU DKHI=DK*HUP*.001 DL=DK*1.E-3*NP SHFACT=14.69*PERMAS*TEMP/(DK*HUP*PI) K1=1 DO 120 K=2,KMAX DO 117 I=1,4 117 Q(K,I)=0. 120 CONTINUE A0=0. A1=0. A2=0. A3=0. DO 30 IX=1,NP I=IX-1 FUNC=F(IX)/NP H2=FLOAT(I)/NP PLEG1=2.*H2-1. PLEG2=6.*H2*H2-6.*H2+1. PLEG3=20.*H2*H2*H2-30.*H2*H2+12.*H2-1. A0=A0+FUNC A1=A1+PLEG1*FUNC A2=A2+PLEG2*FUNC A3=A3+PLEG3*FUNC 30 CONTINUE Q(1,1)=A0 Q(1,2)=A1*3. Q(1,3)=A2*5. Q(1,4)=A3*7. CALL CAPFOU RETURN END SUBROUTINE RELFOU(LANA,NR) 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 LOGICAL LANA C NN=N/2 NRP=NR/2 IF (LANA) GO TO 11 B(1)=0. B(NN+1)=0. CALL REAFOU(NN,NRP,LANA) GO TO 12 11 DO 15 K=1,NRP A(K)=A(2*K-1) B(K)=A(2*K) 15 CONTINUE C CALL SCOPE(.T.) 12 K=NRP IF (.NOT.LANA) K=NN CALL COMFOU(LANA,-NN,K) IF (.NOT.LANA) GO TO 20 A(NN+1)=A(1) B(NN+1)=B(1) CALL REAFOU(NN,NRP,LANA) B(1)=0. B(NN+1)=0. DO 50 I=1,NN AS=A(I) BS=B(I) 40 A(I)=SQRT(AS*AS+BS*BS) B(I)=ATAN2(BS,AS) 50 CONTINUE GO TO 26 20 DO 25 KK=1,NRP K=NRP-KK+1 A(2*K)=B(K) A(2*K-1)=A(K) 25 CONTINUE 26 CONTINUE RETURN END 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)*JIT)/100. 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 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 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 SUBROUTINE REAFOU(NN,NR,LANA) 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 LOGICAL LANA C NH=NN/2 HR=SIN(PI/(4.*FLOAT(NH))) R=-4.*HR*HR DC=-R/2. DS=SIN(PI/(2.*FLOAT(NH))) FA=.5 IF (LANA) FA=1./FLOAT(N) CK=1. SK=0. SHIFT=(FLOAT(NR)-.5)/NN HR=SIN(PI*SHIFT/2.) WR=-4.*HR*HR WDC=-WR/2. WDS=SIN(PI*SHIFT) WCK=1. WSK=0. KK=NH+1 DO 3 K=1,KK NK=NN-K+2 FR=A(K)+A(NK) FI=B(K)-B(NK) GR=A(K)-A(NK) GI=B(K)+B(NK) HR=GR*CK+GI*SK HI=GI*CK-GR*SK AK=(FR+HI)*FA BK=(HR-FI)*FA A(K)=AK*WCK+BK*WSK B(K)=BK*WCK-AK*WSK ANK=(FR-HI)*FA BNK=(HR+FI)*FA A(NK)=-BNK*WCK-ANK*WSK B(NK)=+ANK*WCK-BNK*WSK DC=R*CK+DC CK=CK+DC DS=R*SK+DS SK=SK+DS WDC=WR*WCK+WDC WCK=WCK+WDC WDS=WR*WSK+WDS WSK=WSK+WDS 3 CONTINUE RETURN END SUBROUTINE COMFOU(LANA,NC,NR) 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 LOGICAL LANA C NI=NC NC=IABS(NC) NH=NC/2 NQ=NH/2 NE=5*NQ/2 CT=0. IM=1 NPR=NC IF (NR.EQ.NC) GO TO 3 LL=1 K=NR GO TO 10 9 LL=LL*2 10 K=2*K IF (K.LE.NC) GO TO 9 NPR=NC/LL NPMNR=NPR-NR IF (NPMNR.EQ.0) GO TO 14 DO 12 KK=1,NPMNR K=NPR-KK+1 A(K)=0. B(K)=0. 12 CONTINUE 14 LH=NPR 13 IF (LH.GE.NC) GO TO 15 DO 50 JJ=1,LH J=LH-JJ+1 A(J+LH)=A(J) B(J+LH)=B(J) 50 CONTINUE LH=2*LH GO TO 13 15 I=LL IM=LL 16 I=I/2 IF (I.LT.1) GO TO 17 CT=CT+SQRT(1.+CT*CT) GO TO 16 17 CONTINUE 3 LH=NPR 19 IF (LH.LE.1) GO TO 20 LH=LH/2 M=7 C CALL SCOPE(.T.) DC=-2./(1.+CT*CT) DS=-CT*DC H=2.*DC CI=1. SI=0. IF (LANA) DS=-DS DO 30 I=1,IM ASSIGN 110 TO INVRET GO TO 100 110 KM=J+LH-1 DO 40 K=J,KM KD=K+LH PRE=A(K) PIM=B(K) QR=A(KD)*CI-B(KD)*SI QI=A(KD)*SI+B(KD)*CI A(K)=PRE+QR B(K)=PIM+QI A(KD)=PRE-QR B(KD)=PIM-QI 40 CONTINUE CI=CI+DC SI=SI+DS DC=H*CI+DC DS=H*SI+DS 30 CONTINUE IM=IM*2 CT=CT+SQRT(1.+CT*CT) GO TO 19 20 J=1 M=0 DO 60 I=2,NC ASSIGN 120 TO INVRET GO TO 100 120 IF (J.GE.I) GO TO 60 H=A(I) A(I)=A(J) A(J)=H H=B(I) B(I)=B(J) B(J)=H 60 CONTINUE IF (.NOT.LANA.OR.NI.LT.0) GO TO 67 H=1./FLOAT(NC) DO 66 I=1,NC A(I)=H*A(I) B(I)=H*B(I) 66 CONTINUE 67 CONTINUE RETURN C 100 M=M+1 GO TO (201,202,201,204,201,202,201,208),M 201 J=J+NH GO TO 210 202 J=J-NQ GO TO 210 204 J=J-NE GO TO 210 208 J=1 K=1 M=I-1 220 M=M+M IF (M.EQ.0) GO TO 210 IF (M.LT.NC) GO TO 230 M=M-NC J=J+K 230 K=K+K GO TO 220 210 GO TO INVRET,(110,120) C END SUBROUTINE TAUFOU(IST,FNU,PHI,AF,TAU) 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 NU=IST AM12=A(NU)-A(NU-1) AM32=A(NU+1)-A(NU) AMSL=(AM12+AM32)/2. AMCUR=(AM32-AM12)/2. DNU=-AMSL/(2.*AMCUR) AM=A(NU)-AMSL*AMSL/(4.*AMCUR) IDNU=IFIX(DNU) DNU=DNU-IDNU NU=NU+IDNU FNU=(NU+DNU-1.)*NP/N ANU=TWOPI*FNU HLFINT=FLOAT(NP)/2. CONV=FLOAT(N)/TWOPI PHI12=B(NU)-B(NU-1) IF (ABS(PHI12).GT.PI) PHI12=PHI12-SIGN(TWOPI,PHI12) PHI32=B(NU+1)-B(NU) IF (ABS(PHI32).GT.PI) PHI32=PHI32-SIGN(TWOPI,PHI32) PHISL=(PHI12+PHI32)/2. PHICUR=(PHI32-PHI12)/2. PHI=B(NU)+PHISL*DNU+PHICUR*DNU*DNU SDBPHI=SIN(2.*PHI) CDBPHI=COS(2.*PHI) SNU=SIN(ANU) CNU=COS(ANU) SIMOM=(CNU-SNU/ANU)*SDBPHI*HLFINT/ANU SINTGR=1./(1.+CDBPHI*SNU/ANU) SINCNT=SIMOM*SINTGR AF=AM*SINTGR*N/NP PHI=PHI-SIMOM*TWOPI/HLFINT DPHDNU=PHISL+2.*PHICUR*DNU DPHDNU=DPHDNU*CONV+SINCNT TAUCNT=DPHDNU/HLFINT IF (ABS(TAUCNT).LE.0.99) GO TO 5 X2=SIGN(PI*100.,TAUCNT) GO TO 30 5 X1=SIGN(1.,TAUCNT)/(1.-ABS(TAUCNT)) IF (ABS(TAUCNT).LT.0.5) X1=TAUCNT*3. DIF1=1.E10 10 DUM=EXP(2.*X1) TH=(DUM-1.)/(DUM+1.) X2=TH/(1.-TAUCNT*TH) DIF2=X2-X1 IF (ABS(DIF1).LT.1.E-6) GO TO 20 O=DIF2/DIF1 P=O/(1.-O) 20 X2=X2+P*DIF2 IF (ABS(X2-X1).LT.1.E-3) GO TO 30 X1=X2 DIF1=DIF2 GO TO 10 30 TAU=X2*2. IF (ABS(TAU).GT.10.) TAU=SIGN(10.,TAU) PHI=AMOD(PHI/PI+1.+FNU-FNU/NP,2.)*PI-PI C WRITE(4,100) NU,FNU,DNU,ANU,HLFINT,CONV,PHI,PHISL C $ ,PHICUR,DPHDNU,TAUCNT,TAU,PI,SINCNT,SDBPHI,CNU,SNU C100 FORMAT(1H ,I4,2(8(F10.4,1X)/)) END SUBROUTINE SUBFOU(INA) 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 LOGICAL INA C CHISQ=0. DO 30 IX=1,NP I=IX-1 H2=FLOAT(I)/NP H3=2.*H2-1. H4=6.*H2*H2-6.*H2+1. H5=20.*H2*H2*H2-30.*H2*H2+12.*H2-1. R1=-F(IX)+Q(1,1)+Q(1,2)*H3+Q(1,3)*H4+Q(1,4)*H5 FLD1OV=1.+I*DKHI SQTFLD=SQRT(FLD1OV) IF (ITORQ) SQTFLD=1./SQTFLD IF (K1.LT.2) GO TO 20 DO 40 L=2,K1 QL1=Q(L,1) QL4=Q(L,4) CO=COS(I*QL1-Q(L,2)) AM=Q(L,3)*SQTFLD/(1.-EXP(-SHFACT*QL1*FLD1OV)) E8=1./(1.-EXP(-QL4)) E9=EXP(-H2*QL4) EX=Q(L,4)*E8*E9 R1=R1+AM*CO*EX 40 CONTINUE 20 CHISQ=CHISQ+R1*R1 IF (INA) A(IX)=-R1 30 CONTINUE CHISQ=CHISQ/(NP-K1*4) CHI=SQRT(CHISQ) RETURN END SUBROUTINE NORFOU 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 AND KMAX,10 REAL DER1(44),DER2(11,10) C NA=K1*4 DO 10 I=1,NA C(I)=0. DO 20 J=1,NA AR(I,J)=0. 20 CONTINUE 10 CONTINUE DO 30 IX=1,NP I=IX-1 H2=FLOAT(I)/NP H3=2.*H2-1. H4=6.*H2*H2-6.*H2+1. H5=20.*H2*H2*H2-30.*H2*H2+12.*H2-1. R1=-F(IX)+Q(1,1)+Q(1,2)*H3+Q(1,3)*H4+Q(1,4)*H5 FLD1OV=1.+I*DKHI SQTFLD=SQRT(FLD1OV) IF (ITORQ) SQTFLD=1./SQTFLD DO 40 L=2,K1 LX=L-1 QL1=Q(L,1) QL2=Q(L,2) QL4=Q(L,4) CO=COS(I*QL1-QL2) SI=SIN(I*QL1-QL2) AM=Q(L,3)*SQTFLD/(1.-EXP(-SHFACT*QL1*FLD1OV)) E8=1./(1.-EXP(-QL4)) E9=EXP(-H2*QL4) E3=1.-E8-H2 EX=QL4*E8*E9 E1=E8*E9*(1.+QL4*E3) R1=R1+AM*CO*EX DER1(LX*4+1)=-I*SI*AM*EX*D1(L,1) DER1(LX*4+2)=SI*AM*EX*D1(L,2) DER1(LX*4+3)=CO*EX*D1(L,3) DER1(LX*4+4)=CO*AM*E1*D1(L,4) C IF SECOND DERIVATIVE C E2=E1*E3+E8*E9*(E3-Q(L,4)*E8*(1-E8)) C DER2(LX,1)=-I*I*CO*AM*EX*D1(L,1)*D1(L,1) C DER2(LX,2)=I*CO*AM*EX*D1(L,1)*D1(L,2) C DER2(LX,3)=-CO*AM*EX*D1(L,2)*D1(L,2) C DER2(LX,4)=-I*SI*EX*D1(L,1)*D1(L,3) C DER2(LX,5)=SI*EX*D1(L,2)*D1(L,3) C DER2(LX,6)=0. C DER2(LX,7)=-I*SI*AM*E1*D1(L,1)*D1(L,4) C DER2(LX,8)=SI*AM*E1*D1(L,2)*D1(L,4) C DER2(LX,9)=CO*E1*D1(L,3)*D1(L,4) C DER2(LX,10)=CO*AM*E2*D1(L,4)*D1(L,4) 40 CONTINUE DER1(1)=D1(1,1) DER1(2)=D1(1,2)*H3 DER1(3)=D1(1,3)*H4 DER1(4)=D1(1,4)*H5 DERX=0. DO 50 KL=1,K1 L=KL-1 M1=0 DO 60 NL=1,4 I=NL+4*L C(I)=C(I)-DER1(I)*R1 IF (L.EQ.0) GO TO 75 LJ=4*L DO 70 J=1,LJ AR(J,I)=AR(J,I)+DER1(J)*DER1(I) 70 CONTINUE 75 DO 80 M=1,NL J=M+4*L M1=M1+1 C IF SECOND DERIVATIVE C IF (L.NE.0) DERX=R1*DER2(L,M1) AR(J,I)=AR(J,I)+DER1(J)*DER1(I)+DERX 80 CONTINUE 60 CONTINUE 50 CONTINUE 30 CONTINUE DO 100 J=1,NA 100 DIAGEL(J)=AR(J,J) RETURN END SUBROUTINE TRIFOU(NA) 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 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 SUBROUTINE DIAFOU(NA) 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 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 DO 216 I=1,N1 K=I P=D(I) II=I+1 DO 214 J=II,NA IF(D(J)-P) 213,214,214 213 CONTINUE K=J P=D(J) 214 CONTINUE IF(K.EQ.I) GOTO 216 D(K)=D(I) D(I)=P DO 215 J=1,NA P=Z(J,I) Z(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 SUBROUTINE OUTFOU(LOGOUT) 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 C LOOKOUT WITH DIM!! DIMENSION QN(11,4),DN(11,4) EQUIVALENCE (QN,D),(DN,E) C 599 FORMAT(1H1,T10,#JOSS =#,1L1,# DILA =#,1L1,# RUN =#, $ I2,# ANGLE =#,F6.1) 600 FORMAT(//T10,#P0#,T30,#P1#,T50,#P2#,T70,#P3#/) 601 FORMAT(T11,F8.3,T30,F8.3,T50,F8.3,T70,F8.3) 602 FORMAT(/T10,#NF#,T30,#PH#,T50,#AF#,T70,#TF#/) 603 FORMAT(T10,F9.3,T30,F8.3,T50,1PE12.3,T70,0PF8.3) 604 FORMAT(//T10,#STANDARD DEVIATIONS#/) 605 FORMAT(1H0,#X#,T10,#Q(X+1)#,T30,#Q(X+2)#,T50,#Q(X+3)#, $ T70,#Q(X+4)#) 606 FORMAT(1H ,I2,T10,F8.3,T30,F8.3,T50,F8.3,T70,F8.3) 610 FORMAT(#$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ $$$$$$$$$$$$$$$$$$$$$$$$$#) 620 FORMAT(A1,A2,A1,I2) 630 FORMAT(I2) 640 FORMAT(8(1PE10.3)) C ICHAN=3 IF (LOGOUT.NE.0) GO TO 90 WRITE(ICHAN,605) DO 50 K=1,K1 KX=(K-1)*4 50 WRITE(ICHAN,606) KX,(Q(K,J),J=1,4) RETURN 90 DO 120 J=1,4 QN(1,J)=Q(1,J) 120 DN(1,J)=SQRT(AR(J,J)) DO 100 K=2,K1 KK=4*(K-1) QN(K,1)=Q(K,1)*NP/(DL*TWOPI) QN(K,2)=Q(K,2)*180./PI QN(K,3)=Q(K,3)*EICH QN(K,4)=Q(K,4)/DL DN(K,1)=SQRT(AR(KK+1,KK+1))*NP/(DL*TWOPI) DN(K,2)=SQRT(AR(KK+2,KK+2))*180./PI DN(K,3)=SQRT(AR(KK+3,KK+3))*EICH 100 DN(K,4)=SQRT(AR(KK+4,KK+4))/DL IF (LOGOUT.EQ.-1) GO TO 200 WRITE(ICHAN,599) ITORQ,IDILA,RUN,HANG WRITE(ICHAN,600) WRITE(ICHAN,601) (QN(1,J),J=1,4) WRITE(ICHAN,602) WRITE(ICHAN,603) ((QN(I,J),J=1,4),I=2,K1) WRITE(ICHAN,604) WRITE(ICHAN,600) WRITE(ICHAN,601) (DN(1,J),J=1,4) WRITE(ICHAN,602) WRITE(ICHAN,603) ((DN(I,J),J=1,4),I=2,K1) 130 CONTINUE RETURN 200 ICHAN=7 ICREAT=1HM IF (ITORQ.AND.IDILA) ICREAT=1HD IF (ITORQ.AND..NOT.IDILA) ICREAT=1HT WRITE(ICHAN,610) IMIST=1 WRITE(ICHAN,630) IMIST WRITE(ICHAN,620) ADENT,GLOBAL,ICREAT,RUN IMIST=8 WRITE(ICHAN,630) IMIST FNP=FLOAT(NP) WRITE(ICHAN,640) DK,HANG,HUP,PS,TEMP,TV,EICH,FNP WRITE(ICHAN,610) IMIST=2 WRITE(ICHAN,630) IMIST WRITE(ICHAN,630) K1 WRITE(ICHAN,640) ((QN(I,J),J=1,4),(DN(I,J),J=1,4),I=1,K1) RETURN END SUBROUTINE SETFOU(VAR) 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 DO 120 L=1,4 120 D1(1,L)=VAR/K3 DO 130 L=2,K1 D1(L,1)=VAR*PI/(NP*K3) D1(L,2)=VAR*PI/K3 D1(L,3)=VAR*SQRT(ABS(Q(L,3)*Q(2,3)))/K3 130 D1(L,4)=VAR*(1.+ABS(Q(L,4)))/K3 RETURN END SUBROUTINE CAPFOU 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 600 FORMAT(1H0,T10,#DE HAAS VAN ALPHEN FIT BY#) 601 FORMAT(1H+,T38,#W.JOSS#) 602 FORMAT(1H+,T38,#WM/WW#) 603 FORMAT(1H+,T48,#MATERIAL OR GLOBAL NUMBER= #,A2) 604 FORMAT(1H+,T81,#RUN NUMBER= #,I2,5X,#CREATION NUMBER= # $ ,A4,//) 606 FORMAT(T10,#FIELD BETWEEN #,F7.4,# TESLA UND #,F7.4, $ # TESLA#,# DK = #,F7.4,# TEMPERATURE =#,F5.2, $ # ANGLE HR =#,F6.1//) 607 FORMAT(T10,#TORQUE: CALIBRATED IN #,F9.2, $ # DYNCM/VOLT, CAPACITANCE C =#,F8.3,# PF#//) 608 FORMAT(T10,#MAGNETOSTRICTION: CALIBRATED IN#,F9 $ .3,# ANGSTROEM/VOLT, CAPACITANCE C =#,F8.3,# PF#//) 609 FORMAT(T10,#MODULATION =#,F5.1,#GAUSS PAR SENS. =# $ ,F6.3,#MV. TIME C =#,F6.3,#SEC. T SETTING =#,F5.2, $ #KOHM TEMP. VAR. =#,F6.3//) 610 FORMAT(///,T10,A10,///) 614 FORMAT(T10,#NUMBER OF DATA POINTS= #,I4//) 625 FORMAT(//,T10,#INITIAL LEGENDRE COEFFS#,//, $ T11,F8.3,T30,F8.3,T50,F8.3,T70,F8.3,//) C ITORQ=.FALSE. IDILA=.FALSE. WRITE(3,600) IF (ADENT.NE.1HW) GO TO 135 WRITE (3,601) ITORQ=.TRUE. 135 IF (ADENT.EQ.1HM) WRITE (3,602) WRITE(3,603) GLOBAL WRITE(3,604) RUN,ICREAT WRITE(3,614) NP CALL DATE(YEAR) WRITE(3,610) YEAR WRITE(3,606)HUP,HDOWN,DK,TEMP,HANG IF (.NOT.ITORQ) GO TO 140 AMIST=AKV AKV=CHISQ CHISQ=AMIST CAP=AMI IF(SOLLT.EQ.0.) IDILA=.TRUE. IF(IDILA) GO TO 150 WRITE(3,607)ES,CAP EICH=ES/AKV GO TO 200 150 WRITE(3,608) ES,CAP EICH=ES/AKL*1.E-8 GO TO 200 140 IF (AMI.LT.1.) AMI=AMI*1.E4 WRITE(3,609) AMI,PS,PT,SOLLT,TV EICH=PS 200 WRITE(3,625) (Q(1,I),I=1,4) RETURN END SUBROUTINE SCOPE(LALL,LONE,ISTARP) 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 LOGICAL LALL,LONE C 100 FORMAT(1H1,T50,#INITIAL SPECTRUM#,1H ) 105 FORMAT(1H1,T50,#RESIDUAL SPECTRUM#,1H ) 110 FORMAT(1X,#FREQUENCY (T)#,T107,#AMPLITUDE#,7X,#PHASE#/) 120 FORMAT(1X,1PE11.4,T19,80A1,T105,1PE11.4,6X,0PF7.2) C IF (LONE) WRITE(3,100) IF (.NOT.LONE) WRITE(3,105) NN=((NP-1)/256+1)*256 ISTAR=ISTARP IST=ISTAR+1 IEND=ISTAR+NN IASCAL=N/NN SCAL1=1.E-20 ISTEP=1 IF(LALL) ISTEP=IASCAL/2 DO 10 I=IST,IEND J=I*ISTEP COMP=ABS(A(J))*IASCAL IF (COMP.GT.SCAL1) SCAL1=COMP 10 CONTINUE FAKTOR=79./SCAL1 DO 12 J=1,80 12 PLTBUF(J)=1H DO 15 I=IST,IEND J=I*ISTEP IF(LALL) PHA=B(J)*180./PI AMPL=A(J)*IASCAL IF(LALL) FNU=J/(IASCAL*DK*1.E-3*NN) LINDEX=1+INT(FAKTOR*AMPL+.5) AMPL=AMPL*EICH PLTBUF(LINDEX)=1H* WRITE(3,120) FNU,(PLTBUF(K),K=1,80),AMPL,PHA PLTBUF(LINDEX)=1H 15 CONTINUE RETURN END 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 REWIND 6 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