Дж. С. Дэвис. Статистический анализ данных в геологии. Книга 2
Подождите немного. Документ загружается.
Дж. С. Дэвис. Статистический анализ данных в геологии. Книга 2
261
C
CSLE SLE PROGRAM 4 9
C
C SUBROUTINE FOR SOLUTION OF N SIMULTANEOUS EQUATIONS
C MATRIX A IS N X N AND B IS A COLUMN VECTOR OF N ELEMENTS
C A IS CONVERTED TO THE IDENTITY MATRIX
C B CONTAINS SOLUTION
C
SUBROUTINE SLE(A,B,N,N1,ZERO)
COMMON /TLC/ SV(20),LZ,LU,Z11,Z22,D11,D22,NZZ,NSP,DPC,DFT,UPA
COMMON /IOLUN/ I5,I6,J5,JP,J4
DIMENSION A(N1,N1),B(N1)
DO 100 I = 1,N
DIV = A(I,I)
IF(ABS(DIV) - ZERO) 99,99,1
1 DO 101 J=1,N
A(I,J) = A(l,J) / DIV
101 CONTINUE
B(I) = B(I) / DIV
D0 102 J = 1,N
IF(I-J) 2,102,2
2 RATIO=A(J,I)
DO 103 K = 1,N
A(J,K) = A(J,K) – RATIO * A(I,K)
103 CONTINUE
B(J) = B(J) – RATIO * B(I)
102 CONTINUE
100 CONTINUE
RETURN
99 WRITE(l6,200)
200 FORMAT(/' Matrix Cannot Be Inverted. System of,
1/' Simultaneous Linear Equations Cannot Be Solved.')
LZ = -9
RETURN
END
C
CEIGENJ EIQTNJ - PROGRAM 4-10
C
C SUBROUTINE TO CALCULATE. THE EIGENVALUES AND EIGENVECTORS
C OF AN NXN SYMMETRIC MATRIX.
C
C UPON COMPLETION THE EIGENVALUES ARE STORED IN THE DIAGONAL
C ELEMENTS OF MATRIX A (IN DESCENDING ORDER). THE EIGENVECTORS
C ARE STORED BY COLUMNS IN MATRIX B.
C
C EIGENVALUE A(l,l) CORRESPONDS TO EIGENVECTOR (B(J,I),J=1,N)
C
SUBROUTINE EIGENJ(A,B,N,N1)
DIMENSION A(N1,N1),B(N1,N1)
COMMON /TLC/ SV(20),LZ,LU,Z11,Z22,D1I,D22,NZZ,NSP,DPC,DFT,UPA
C
C.. CALCULATE INITIAL AND FINAL NORMS
C SET B TO IDENTITY MATRIX
C
IF(N.LE.0) GOTO 502
ANORM = 0.0
DO 100 I = 1,N
DO 101 J = 1,N
IF(I-J) 2,1,2
1 B(I,J) = 1.0
GOTO 101
2 B(I,J) = 0.0
ANORM = ANORM + A(I,J) * A(I,J)
101 CONTINUE
100 CONTINUE
Дж. С. Дэвис. Статистический анализ данных в геологии. Книга 2
262
ANORM = SQRT(ANORM)
FNORM = ANORM * 1.0E-09 / FLOAT(N)
C
C... INITIALIZE INDICATORS AND COMPUTE THRESOLD
C
THR = ANORM
23 THR = THR / FLOAT(N)
3 IND = 0
C
C... SCAN DOWN COLUMNS FOR OFF-DIAGONAL ELEMENTS
C GREATER THAN OR EQUAL TO THRESOLD
C
DO 102 I = 2,N
I1 = I-1
DO 103 J = 1,I1
IF(ABS(A(J,I))-THR) 103,4,4
C
C... COMPUTE SIN AND COS
C
4 IND = 1
AL = -A(J,I)
AM = (A(J,J) - A(I,I)) / 2.0
DBY0 = SQRT(AL * AL + AM * AM)
IF(DBY0.EQ.0.0) GOTO 502
AO = AL / SQRT(AL * AL + AM * AM)
IF(AM) 5,6,6
5 AO = -AO
6 SINX = AO / SORT(2.0(1.0 + SQRT(1.0 – AO * AO)))
SINX2 = SINX * SINX
COSX = SQRT(1.0 - SINX2)
COSX2 = COSX * COSX
C
C... ROTATE COLUMNS I AND J
C
DO 104 K = 1,N
IF (K-J) 7,10,7
7 IF (K-l) 8,10,8
8 AT = A(K,J)
A(K,J) = AT * COSX - A(K,I) * SINX
A(K,I) = AT * SINX + A(K,1) * COSX
10 BT = B(K,J)
B(K,J) = BT * COSX - B(K,I) * SINX
B(K,I) = BT * SINX + B(K,I) * COSX
104 CONTINUE
XT = 2.0 * A(J,I) * SINX * COSX
AT = A(J,J)
BT = A(I,I)
A(J,J) = AT * COSX2 + BT * SINX2 - XT
A(I,I) = AT * SINX2 + BT * COSX2 + XT
A(J,I) = (AT - BT) * SINX * COSX + A(J,I) * (COSX2 - SINX2)
A(I,J) = A(J,I)
D0 105 K = 1,N
A(J,K) = A(K,J)
A(I,K) = A(K,I)
105 CONTINUE
103 CONTINUE
102 CONTINUE
IF(IND) 20,20,3
20 IF(THR-FNORM) 25,25,23
C
C... SORT EIGENVALUES AND EIGENVECTORS
C
25 DO 110 I = 2,N
29 IF (A(J-1,J-1)-A(J,J)) 30,110,110
30 AT = A(J-1,J-1)
A(J-1,J-1) = A(J,J)
A(J,J) = AT
DO 111 K = 1,N
AT = B(K,J-1)
B(K,J-1) = B(K,J)
Дж. С. Дэвис. Статистический анализ данных в геологии. Книга 2
263
B(K,J) = AT
111 CONTINUE
J = J - 1
IF(J-1) 110,110,29
110 CONTINUE
RETURN
C
C... DIVIDE BY ZERO
C
502 LZ = -9
CALL CLSALL
CALL INVLID(5)
CALL PAUSE(2)
RETURN
END
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C SUBROUTINE MTRANS COMPUTES THE TRANSPOSE MATRIX C OF MATRiX A
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
SUBROUTINE MTRANS(A,C,NRA,NCA,MAXR,MAXC)
DIMENSION A(MAXR,MAXC),C(MAXR,MAXC)
DO 100 I = 1,NRA
DO 101 J = 1,NCA
C(J,I) = A(I,J)
101 CONTINUE
100 CONTINUE
RETURN
END
FUNCTION IJEOF(I)
,JEOP=0
RETURN
END
C./ ADD NAME=RREAD
C
C TO READ N REAL.NUMBERSFROMKEYBOARD,CHECKING FOR
C "QUIT", "UP" OP, "HELP"
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
SUBROUTINE RREAD(N,A,B,C,D)
COMMON /TLC/ SAVE(20),LZ,LU,Z1,Z2,D1,D2,NZ,NSTEP,DEPlNC,DFLT,UPA
COMMON /FLS/ I5,I6,I7,I8,I9,I10,I11,I12,I13,lPCH,lLP,IPLOT,NCHAN
COMMON /CHAR/ MN(720),LPT
COMMON /ASC/ IALPHA(96)
CHARACTER*1 IALPHA,MN
A = 0.0
B = 0.0
C = 0.0
D = 0.0
NUM = 0.0
C WRITE(I6,9)
9 FORMAT(1X)
1 READ(I5,10) (MN(M),M=1,50)
10 FORMAT(50A1)
DUM = IJEOF(I5)
IF(112.EQ.-99) WRITE(113,10) (MN(M),M=1,50)
C IF(l6.EQ.I13) WRITE(I6,11) (MN(M),M=1,50)
11 FORMAT(1X,50A1)
I1 = 1
Дж. С. Дэвис. Статистический анализ данных в геологии. Книга 2
264
DO 20 I = 1,50
I2 = 51 - I
IF(MN(12).EQ.1ALPHA(1)) GOTO 20
GOTO 30
20 CONTINUE
Z = 0.0
GOTO 40
30 CALLNUMB(I1,I2,IERR,Z)
IF(LZ.LT.0) GOT0 90
IF(IERR.EQ.0) GOTO 40
C
C... TONE FOR IBM PC ONLY
C
CALL TONE
C
WRITE(I6,110)
GOTO 1
40 NUM=NUM+1
IF(NUM.EQ.1) A = Z
IF(NUM.EQ.2) B = Z
IF(NUM.EQ.3) C = Z
IF(NUM.EQ.4) D = Z
IF(I1.LE.I2)GOTO 30
IF(NUM.LT.N) GOTO 1
90 RETURN
110 FORMAT(1X,13HInvalid entry,12H, Try again ')
END
C./ADDNAME=IREAD
C
C TO READ N INTEGERS FROM KEYBOARD
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
SUBROUTINE IREAD(N,I,J,K,L)
COMMON /TLC/ SAVE(20),LZ,LU,Z1,22,D1,D2,NZ,NSTEP,DEPINC,DFLT,UPA
CALL RREAD(N,A,B,C,D)
IF(LZ.LT.0) RETURN
I = A
J = B
K = C
L = D
RETURN
END
C
C./ADD NAME=AREAD
C
C TO READ N A1 CHARACTERS FROM KEYBOARD AS INTEGER VARIABLES
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
SUBROUTINE AREAD(N,I,J,K,L)
COMMON /TLC/ SAVE(20),LZ,LU,Z1,Z2,D1,D2,NZ,NSTEP,DEPINC,DFLT,UPA
COMMON /FLS/ I5,I6,I7,I8,I9,I10,I11,I12,I13,IPCH,ILP,IPLOT,NCHAN
COMMON /ASC/ IALPHA(96)
CHARACTER*1 IALPHA,IBL,M1,M2,M3,M4
C
C DATA IBL/' '/
C
IBL = IALPHA(1)
IF(LZ.EQ.-5.AND.N.EQ.1) RETURN
M1 = IBL
M2 = IBL
M3 = IBL
M4 = IBL
C
C WRITE(I6,9)
C
9 FORMAT(1X)
READ(I5,10) M1,M2,M3,M4
10 FORMAT(4A1)
DUM = IJEOF(I5)
Дж. С. Дэвис. Статистический анализ данных в геологии. Книга 2
265
IF(112.EQ.-99) WRITE(I13,10) M1,M2,M3,M4
C IF(I6.EQ.I13) WRITE(I6,110) M1,M2,M3,M4
110 FORMAT(1X,4A1)
LZ = 0
CALL CHKALL(M1,M2,M3,M4)
IF(LZ.LT.0) RETURN
I = 1
J = 1
K = 1
L = 1
DO 120 KK = 1,96
IF(I.EQ.1.AND.M1.EQ.IALPHA(KK)) I = KK
IF(J.EQ.1.AND.M2.EQ.IALPHA(KK)) J = KK
IF(K.EQ.1.AND.M3.EQ.IALPHA(KK)) K = KK
IF(L.EQ.1.AND.M4.EQ.IALPHA(KK)) L = KK
120 CONTINUE
RETURN
END
C
C./ ADD NAME=NUMB
C
C CONVERTS AN M STRING OF CHARACTERS FROM MN(I1) TO MN(I2
C TO A REAL NUMBER
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
SUBROUTINE NUMB(I1,I2,IERR,A)
COMMON /TLC/ SAVE(20),LZ,LU,Z1,Z2,D1,D2,NZ,NSTEP,DEPINC,DFLT,UPA
COMMON /FLS/ E5,I6,I7,I8,I9,I10,I11,I12,I13, IPCH,ILP,IPLOT,NCHAN
COMMON /ASC/ IALPHA(96)
COMMON /CHAR/ MN(720),LPT
DIMENSION NM(132)
CHARACTERS IALPHA,MN,M1,M2,M3,M4
A = DFLT
LZ = 0
M1 = MN(I1)
M2 = MN(I1+1)
M3 = MN(I1+2)
M4 = MN(I1+3)
CALL CHKALL(M1,M2,M3,M4)
IF(LZ.LT.0) RETURN
NDIG = 0
NEG = 0
IDEC = 999
DO 100 I = 11,12
IE=I
IF(MN(I).NE.IALPHA(1)) GOTO 10
IF(NEG.EQ.0) GOTO 100
GOTO 200
10 DO 20 K = 10,26
IF(MN(1).NE.IALPHA(K)) GOTO 20
IF(K.EQ.13.OR.K.EQ.16) GOTO 200
IF(NEG.NE.0) GOTO 30
IB = I
IF(K.EQ.12) NEG = 1
IF(K.EQ.14) NEG = -1
IF(NEG.NE.0) GOTO 40
NEG = 1
IB = I - 1
GOTO 30
20 CONTINUE
GOTO 900
C
C AFTER FIRST DIGIT
C
30 IF(K.LE.14.0R.K.EQ.1S)GOT0200
NDIG = NDIG + 1
40 IF(K.E0.15) IDEC = NDIG
NM(I) = K - 17
Дж. С. Дэвис. Статистический анализ данных в геологии. Книга 2
266
100 CONTINUE
C
C END OF NUMBER
C
200 A = 0.0
IF(NDIG.GT.0) GOTO 210
I1 = I1 + 1
RETURN
210 IF(NDIG*IDEC.EQ.1) GOTO 900
DO 300 J = 1,NDIG
IF(J.LT.IDEC) A=10.0 * A + FLOAT(NM(IB + J)
IF(J.EQ.IDEC) GOTO 300
IF(J.GT.IDEC) A = A + FLOAT(NM(IB + J)) * 10.0 * FLOAT(IDEC - J)
300 CONTINUE
A = A * FLOAT(NEG)
IERR = 0
I1 = IE + 1
RETURN
C
C ERFCR
C
900 WRITE(I6,910)
910 FORMAT(1X,2iHError in number field)
IERR = -1
RETURN
END
C
C./ ADD NAME=CHKALL
C
C CHECKS FOR CHARACTERS SPELLING "QUIT", "UP", "HELP" ETC
C
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
SUBROUTINE CHKALL(M1,M2,M3,M4)
CHARACTER*1 M1,M2,M3,M4
C
CALL CHECK(M1,M2,M3,M4,52,53,48,49,-9)
CALL CHECK(M1,M2,M3,M4,38,57,42,53.-9)
CALL CHECK(M1,M2,M3,M4,34,35,48,51,-9)
CALL CHECK(M1,M2,M1,M1.54,49,54.54,-1)
CALL CHECK(M1,M1,M1,M1,50,5Q,50,50,-9)
CALL CHECK(M1,M2,M1,M1,54,1,54,54,-1)
CALL CHECK(M1,M2,M3,M4,41,38,45,49,-10)
CALL CHECK(M1,M1,M1,M1,32,32,32,32,-10)
CALL CHECK(M1,M2,M3,M4,36,48,49,58,-5)
CALL CHECK(M1,M1,M1,M1,54,54,54,54,-1)
CALL CHECK(M1,M1,M1,M1,41,41,41,41,-10)
CALL CHECK(M1,M1,M1,M1,82,82,82,82,-9)
CALL CHECK(M1,M1,M1,M1,85,86,86,86,-1)
CALL CHECK(M1,M1,M1,M1,73,73,73,73,-10)
RETURN
END
C
C./ ADD NAME=CHECK
C
C COMPARES STRING M1,M2,M3,M4 TO ASCIl CHARACTERS K1,K2,K3,K4
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
SUBROUTINE CHECK(M1,M2,M3,M4,K1,K2,K3,K4,L)
COMMON /TLC/ SAVE(20),LZ,LU,Z1,Z2,D1.D2,NZ,NSTEP,DEPINC,DFLT,UPA
COMMON /ASC/ IALPHA(96)
CHARACTER*1 IALPHA,M1,M2,M3,M4
IF(M1.NE.IALPHA(K1)) RETURN
IF(M2.NE.IALPHA(K2)) RETURN
IF(M3.NE.IALPHA(K3)) RETURN
IF(M4.NE.IALPHA(K4)) RETURN
LZ = L
RETURN
END
Дж. С. Дэвис. Статистический анализ данных в геологии. Книга 2
267
This routine will create the audio tone (subroutine TONE)
assume cs:codes
codes segment 'code'
public tone
tone proc far
pusn bp ;save frame pointer
mov bp,sp ;address parameters
mov ax,0 ;numerator (low word)
mov dx,12h (high word)
mov bx,1250 divisor
div bx ;divide
mov bx.ax ;save quotient in BX
set 1/pitch into timer than turn on tone
mov а1,10110110b ;put the number
out 43h,al ;into timer
mov ax,bx 1/pitch into AX
out 42h,a! ;LSB into timer2
mov al,ah ;MSB into timer2
out 42h,al
in al,61h ;read port В into AL
or al,3 ;turn on bits 0,1
out 61h,al lo turn on speaker
sound the tone for a while, then turn it off
mov cx,02FFFh ;set up for delay
wait loop wait ;delay
in al,61h ;read portB into AL
and al,1111100b ;mask lower two bits
out 61h,al to turn off speaker
pop bp restore frame pointer
ret return
tone endp
codes ends
end