File: KUNG6F.BK of Tape: Various/ETH/fc-files
(Source file text)
KUNGFU,9621,CM60000,CT31.
PERMF,LGO.
FTN(BL,OPT,R).
CATALOG,LGO,FITBIN.
.EOR.
PROGRAM KUNGFU(OUTPUT=240B,TAPE3=OUTPUT,TAPE4=240B,
$ TAPE5=240B,TAPE6=240B,TAPE7=240B)
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
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=2H6F
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,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 ADENT,GLOBAL,DITOMO,RUN,ICREAT /#X#,#XX#,#X#,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,DK,DL,HANG
$ ,HUP,HDOWN,CAPMO,AMI,PS,PT,SOLLT,TEMP,TV,ES,AKL,AKV,EICH
$ /0.,11*0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
$ 0.,0.,0.,0.,0./
DATA FRE1,FRE2,PERMAS /11*0.,11*0.,11*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,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
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)
507 FORMAT(I2)
508 FORMAT(3F10.5)
C
615 FORMAT(1H0,T10,#--------------BAD FILE---------------#,
$ A1,A2,A1,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 (DITOMO.NE.1HM.AND.DITOMO.NE.1HD.AND.
$ DITOMO.NE.1HT.AND.DITOMO.NE.1HX) GO TO 90
BACKSPACE 5
READ(5,501) ADENT,GLOBAL,DITOMO,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 (DITOMO.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,CAPMO,PS,PT,SOLLT,TEMP
$ ,TV,SHIFT,PERMAS(1),ES,AKL,AKV,(AMIST,K=1,5)
CHISQ=0.
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
DO 107 I=2,11
FRE1(I)=0.
FRE2(I)=0.
107 PERMAS(I)=.0
IF (PERMAS(1).NE.0.) GO TO 109
PERMAS(1)=1.
REWIND 4
READ(4,507) IMIST
IMIST=IMIST+1
DO 108 I=2,IMIST
108 READ(4,508) FRE1(I),FRE2(I),PERMAS(I)
109 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,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
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,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
REAL NF,MU
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-MU =#,5(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
SHFACT(L+1)=SHFACT(L)
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)
NF=FNU/DL
DO 61 J=2,11
JJ=J
IF (NF.GE.FRE1(J).AND.NF.LE.FRE2(J)) GO TO 62
JJ=1
61 CONTINUE
62 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
SHFACT(I)=14.69*PERMAS(JJ)*TEMP/(DK*HUP*PI)
58 CONTINUE
PH=PHI*180./PI
AM=AF*EICH
TA=-TAU/DL
MU=PERMAS(JJ)*NF*1.E-3
WRITE(3,160) NF,PH,AM,TA,MU
60 CONTINUE
IF (IPASS.EQ.0) K1=KEEP
RETURN
END
SUBROUTINE FITFOU
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
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,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
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,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
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,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
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,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
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 (DITOMO.EQ.1HD.OR.DITOMO.EQ.1HT) 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(L)*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,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
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 (DITOMO.EQ.1HD.OR.DITOMO.EQ.1HT) SQTFLD=1./SQTFLD
DO 40 L=2,K1
LX=L-1
QL1=Q(L,1)
QL2=Q(L,2)
QL3=Q(L,3)
QL4=Q(L,4)
CO=COS(I*QL1-QL2)
SI=SIN(I*QL1-QL2)
AM=QL3*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)=(AM/QL3)*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*(AM/QL3)*EX*D1(L,1)*D1(L,3)
C DER2(LX,5)=SI*(AM/QL3)*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)=(AM/QL3)*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,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
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
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,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),PM(11)
EQUIVALENCE (A,AR),(B,Z)
INTEGER RUN
REAL K3
LOGICAL ITEST,TASWI
C
C LOOKOUT WITH DIM!!
DIMENSION QN(11,4),DN(11,4)
EQUIVALENCE (QN,D),(DN,E)
C
599 FORMAT(1H1,T10,#ADENT =#,A2,# DITOMO =#,A1,# 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)
607 FORMAT(/T10,#NF#,T30,#PH#,T50,#AF#,T70,#TF#,T90,#MU#/)
608 FORMAT(T10,F9.3,T30,F8.3,T50,1PE12.3,T70,0PF8.3,T90,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
PM(K)=SHFACT(K)*HUP*Q(K,1)/(2.*14.69*TEMP)
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,607)
WRITE(ICHAN,608) ((QN(I,J),J=1,4,PM(I),I=2,K1)
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,DITOMO,RUN
IMIST=8+K1-1
WRITE(ICHAN,630) IMIST
FNP=FLOAT(NP)
WRITE(ICHAN,640) DK,HANG,HUP,PS,TEMP,TV,EICH,FNP
DO 201 K=2,K1
201 PM(K)=PM(K)*1.E3/QN(K,1)
WRITE(ICHAN,640) (PM(K),K=2,K1)
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,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
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,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
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,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
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,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
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