File: TFITLF.FT of Disk: Disks/MyPDP/m8-2-rka1-rkb1
(Source file text)
C PGM TIMAFI CP-NAEHERUNG : TFIT03.FT
C FIT FUER DATEN AUS MESSUNG DER SPEZ. WAERME UM THERMOMETER ZU EICHEN
C T=1/(S(3)+S(4)*......S(6)*LN(R)**3)
DIMENSION R1(25),R2(25),Q(25),S(6),DN(6)
DIMENSION A(25,6),B(25),X(6),AUX(12),IPIV(6)
DIMENSION FMATR(6,6),BETA(6)
INTEGER FRAGE
LOGICAL NEW
LPT=3
ITERM=4
IPARO=5
IPARN=6
COM. DATENEINGABE
READ(IPARO,3000) NP
DO 100 I=1,NP
READ(IPARO,3001) R1(I),R2(I),Q(I)
100 CONTINUE
GOTO 500
WRITE(ITERM,1002) I
READ(ITERM,2002) R1(I)
WRITE(ITERM,1003) I
READ(ITERM,2002) R2(I)
WRITE(ITERM,1004) I
READ(ITERM,2002) Q(I)
WRITE(IPARN,3001) R1(I),R2(I),Q(I)
300 CONTINUE
500 CONTINUE
WRITE(ITERM,1005)
WRITE(LPT,1005)
DO 400 I=1,NP
WRITE(ITERM,2003) I,R1(I),R2(I),Q(I)
WRITE(LPT,2003) I,R1(I),R2(I),Q(I)
400 CONTINUE
NUMIT=1
DO 600 I=1,NP
600 CONTINUE
COM. NAEHERUNGSWERTE
S(1)=0.3155
S(2)=0.0267
S(3)=-0.06286
S(4)=0.002248
S(5)=0.003892
S(6)=0.0000001
WRITE(ITERM,1006)
DO 900 I=1,6
WRITE(ITERM,1007) I,S(I)
900 CONTINUE
COM. BERECHNUNG DER TAYLORKOEFFIZIENTEN
WRITE(ITERM,1008) NUMIT
DO 700 I=1,NP
ALN1=ALOG(R1(I))
ALN2=ALOG(R2(I))
T1=1./(S(3)+S(4)*ALN1+S(5)*ALN1**2+S(6)*ALN1**3)
T2=1./(S(3)+S(4)*ALN2+S(5)*ALN2**2+S(6)*ALN2**3)
WRITE(ITERM,1009) T1,T2
B(I)=1.0-S(1)/(2.0*Q(I))*(T2**2-T1**2)-
$ S(2)/(4.0*Q(I))*(T2**4-T1**4)
A(I,1)=0.5/Q(I)*(T2**2-T1**2)
A(I,2)=0.25/Q(I)*(T2**4-T1**4)
A(I,3)=-S(1)/Q(I)*(T2**3-T1**3)-
$ S(2)/Q(I)*(T2**5-T1**5)
A(I,4)=-S(1)/Q(I)*(T2**3*ALN2-T1**3*ALN1)-
$ S(2)/Q(I)*(T2**5*ALN2-T1**5*ALN1)
A(I,5)=-S(1)/Q(I)*(T2**3*ALN2**2-T1**3*ALN1**2)-
$ S(2)/Q(I)*(T2**5*ALN2**2-T1**5*ALN1**2)
A(I,6)=-S(1)/Q(I)*(T2**3*ALN2**3-T1**3*ALN1**3)-
$ S(2)/Q(I)*(T2**5*ALN2**3-T1**5*ALN1**3)
WRITE(ITERM,2004) A(I,1),A(I,2),A(I,3),B(I)
WRITE(ITERM,2007) A(I,4),A(I,5),A(I,6),Q(I)
700 CONTINUE
COM BERECHNUNG DER FEHLERMATRIX
DO 10 K=1,6
DO 20 J=1,6
FMATR(J,K)=0.0
DO 30 I=1,NP
FMATR(J,K)=FMATR(J,K)+A(I,J)*A(I,K)
30 CONTINUE
20 CONTINUE
10 CONTINUE
DO 40 K=1,6
BETA(K)=0.0
DO 50 I=1,NP
BETA(K)=BETA(K)+B(I)*A(I,K)
50 CONTINUE
40 CONTINUE
GOTO 60
COM. AUSDRUCK FEHLERMATRIX TERMINAL
DO 60 K=1,6
WRITE(ITERM,2006) FMATR(K,1),FMATR(K,2),FMATR(K,3),FMATR(K,4)
WRITE(ITERM,2008) FMATR(K,5),FMATR(K,6),BETA(K)
60 CONTINUE
COM BERECHNUNG UNTERE DREIECKSMATRIX
DO 110 K=3,5
KK=K+1
DO 120 I=KK,6
FAK=FMATR(I,K)/FMATR(K,K)
BETA(I)=BETA(I)-FAK*BETA(K)
DO 130 J=K,6
FMATR(I,J)=FMATR(I,J)-FAK*FMATR(K,J)
130 CONTINUE
120 CONTINUE
110 CONTINUE
COM BERECHNUNG OBERE DREIECKSMATRIX
FAK=FMATR(2,1)/FMATR(1,1)
BETA(2)=BETA(2)-FAK*BETA(1)
FMATR(2,1)=0.0
FMATR(2,2)=FMATR(2,2)-FAK*FMATR(1,2)
GOTO 70
COM. AUSDRUCK DREIECKSMATRIX TERMINAL
DO 70 K=1,6
WRITE(ITERM,2006) FMATR(K,1),FMATR(K,2),FMATR(K,3),FMATR(K,4)
WRITE(ITERM,2008) FMATR(K,5),FMATR(K,6),BETA(K)
70 CONTINUE
COM BERECHNUNG DER KORREKTUREN X(I)
DO 140 I=1,4
II=7-I
SUM=0.0
X(II)=0.0
DO 150 J=II,6
SUM=SUM+FMATR(II,J)*X(J)
150 CONTINUE
X(II)=(BETA(II)-SUM)/FMATR(II,II)
140 CONTINUE
X(2)=BETA(2)/FMATR(2,2)
X(1)=(BETA(1)-FMATR(1,2)*X(2))/FMATR(1,1)
WRITE(ITERM,2009)
S(3)=S(3)+X(3)
S(4)=S(4)+X(4)
S(5)=S(5)+X(5)
S(6)=S(6)+X(6)
DO 800 I=1,6
DN(I)=100.0*X(I)/S(I)
WRITE(ITERM,2005) I,S(I),X(I),DN(I)
800 CONTINUE
ALN=ALOG(R)
TFAULT=1/(S(3)+S(4)*ALN+S(4)*ALN*ALN+S(5)*ALN**3)
CORFAC=4.2/TFAULT
C WRITE(ITERM,
S(1)=S(1)/CORFAC**2
S(2)=S(2)/CORFAC**4
SIGMA=0.0
DO 850 I=1,NP
SIGMA=SIGMA+B(I)*B(I)
850 CONTINUE
SIGMA=SQRT(SIGMA/NP)
WRITE(ITERM,1013) SIGMA
NUMIT=NUMIT+1
WRITE(ITERM,1012)
READ(ITERM,2000) NEW
IF (NEW) GOTO 900
WRITE(LPT,1011)
DO 990 I=1,6
WRITE(LPT,2011) I,S(I),DN(I)
990 CONTINUE
WRITE(LPT,1013) SIGMA
DO 995 I=1,NP
ALN1=ALOG(R1(I))
ALN2=ALOG(R2(I))
T1=1./(S(3)+S(4)*ALN1+S(5)*ALN1**2+S(6)*ALN1**3)
T2=1./(S(3)+S(4)*ALN2+S(5)*ALN2**2+S(6)*ALN2**3)
WRITE(LPT,1014) I,T1,T2,B(I)
TMIT=(T1+T2)/2.0
CP=Q(I)/(T2-T1)
WRITE(LPT,1015) TMIT,CP
995 CONTINUE
1000 FORMAT (1X,'NEW DATA SET (T/F)?',T30,$)
1001 FORMAT (1X,'NUMBER OF DATAPOINTS NP =',T30,$)
1002 FORMAT (/T5,'R1(',I2,') =',T15,$)
1003 FORMAT (T5,'R2(',I2,') =',T15,$)
1004 FORMAT (T5,'Q (',I2,') =',T15,$)
1005 FORMAT (1H0,'MEASURED VALUES USED FOR FIT:'/
$ 1X,29('-')//T10,'I',T25,'R1(I)',T45,'R2(I)',T66,'Q(I)'/)
1006 FORMAT (///,1X'APPROXIMATION VALUES:'/)
1007 FORMAT (1X,'X(',I1,')=',F20.8)
1008 FORMAT (///,1X,'NUMBER OF ITERATION: ',I2,//)
1009 FORMAT (//,1X,'T1=',F10.4,' T2=',F10.4,/)
1011 FORMAT (///,1X'CALCULATED VALUES AND ERRORS IN PERCENT',/)
1012 FORMAT (//,1X,'FIT WITH NEW PARAMETERS (T/F)?',T50,$)
1013 FORMAT (//,1X,'MEAN ERROR OF DATAPOINTS =',F10.3)
1014 FORMAT (/,1X,I3' T1=',F10.4,' T2=',F10.4,/
$ ' ERROR =',F10.3)
1015 FORMAT (/,' T := ',F10.4,' CP := ',F12.6)
2000 FORMAT (L1)
2001 FORMAT (I3)
2002 FORMAT (F20.3)
2003 FORMAT (1X,I9,3F20.3)
2004 FORMAT (1X,4E16.4)
2005 FORMAT (1X,I9,3G20.8)
2006 FORMAT (//,1X,4E16.4)
2007 FORMAT (1X,3E16.4,' ',F20.3)
2008 FORMAT (1X,2E16.4,' ',E16.4)
2009 FORMAT (//,1X)
2010 FORMAT (1X,I3,G16.8)
2011 FORMAT (1X,I3,G16.8,F8.2)
2012 FORMAT (F20.5)
3000 FORMAT (I3)
3001 FORMAT (3F20.3)
6001 FORMAT (' ',6G16.8,' ',G16.8)
111 CONTINUE
END