mirror of
https://git.planet-casio.com/Lephenixnoir/OpenLibm.git
synced 2025-01-01 06:23:39 +01:00
245 lines
7.9 KiB
Fortran
245 lines
7.9 KiB
Fortran
*DECK HQR
|
|
SUBROUTINE HQR (NM, N, LOW, IGH, H, WR, WI, IERR)
|
|
C***BEGIN PROLOGUE HQR
|
|
C***PURPOSE Compute the eigenvalues of a real upper Hessenberg matrix
|
|
C using the QR method.
|
|
C***LIBRARY SLATEC (EISPACK)
|
|
C***CATEGORY D4C2B
|
|
C***TYPE SINGLE PRECISION (HQR-S, COMQR-C)
|
|
C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK
|
|
C***AUTHOR Smith, B. T., et al.
|
|
C***DESCRIPTION
|
|
C
|
|
C This subroutine is a translation of the ALGOL procedure HQR,
|
|
C NUM. MATH. 14, 219-231(1970) by Martin, Peters, and Wilkinson.
|
|
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 359-371(1971).
|
|
C
|
|
C This subroutine finds the eigenvalues of a REAL
|
|
C UPPER Hessenberg matrix by the QR method.
|
|
C
|
|
C On INPUT
|
|
C
|
|
C NM must be set to the row dimension of the two-dimensional
|
|
C array parameter, H, as declared in the calling program
|
|
C dimension statement. NM is an INTEGER variable.
|
|
C
|
|
C N is the order of the matrix H. N is an INTEGER variable.
|
|
C N must be less than or equal to NM.
|
|
C
|
|
C LOW and IGH are two INTEGER variables determined by the
|
|
C balancing subroutine BALANC. If BALANC has not been
|
|
C used, set LOW=1 and IGH equal to the order of the matrix, N.
|
|
C
|
|
C H contains the upper Hessenberg matrix. Information about
|
|
C the transformations used in the reduction to Hessenberg
|
|
C form by ELMHES or ORTHES, if performed, is stored
|
|
C in the remaining triangle under the Hessenberg matrix.
|
|
C H is a two-dimensional REAL array, dimensioned H(NM,N).
|
|
C
|
|
C On OUTPUT
|
|
C
|
|
C H has been destroyed. Therefore, it must be saved before
|
|
C calling HQR if subsequent calculation and back
|
|
C transformation of eigenvectors is to be performed.
|
|
C
|
|
C WR and WI contain the real and imaginary parts, respectively,
|
|
C of the eigenvalues. The eigenvalues are unordered except
|
|
C that complex conjugate pairs of values appear consecutively
|
|
C with the eigenvalue having the positive imaginary part first.
|
|
C If an error exit is made, the eigenvalues should be correct
|
|
C for indices IERR+1, IERR+2, ..., N. WR and WI are one-
|
|
C dimensional REAL arrays, dimensioned WR(N) and WI(N).
|
|
C
|
|
C IERR is an INTEGER flag set to
|
|
C Zero for normal return,
|
|
C J if the J-th eigenvalue has not been
|
|
C determined after a total of 30*N iterations.
|
|
C The eigenvalues should be correct for indices
|
|
C IERR+1, IERR+2, ..., N.
|
|
C
|
|
C Questions and comments should be directed to B. S. Garbow,
|
|
C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
|
|
C ------------------------------------------------------------------
|
|
C
|
|
C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
|
|
C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
|
|
C system Routines - EISPACK Guide, Springer-Verlag,
|
|
C 1976.
|
|
C***ROUTINES CALLED (NONE)
|
|
C***REVISION HISTORY (YYMMDD)
|
|
C 760101 DATE WRITTEN
|
|
C 890531 Changed all specific intrinsics to generic. (WRB)
|
|
C 890831 Modified array declarations. (WRB)
|
|
C 890831 REVISION DATE from Version 3.2
|
|
C 891214 Prologue converted to Version 4.0 format. (BAB)
|
|
C 920501 Reformatted the REFERENCES section. (WRB)
|
|
C***END PROLOGUE HQR
|
|
C
|
|
INTEGER I,J,K,L,M,N,EN,LL,MM,NA,NM,IGH,ITN,ITS,LOW,MP2,ENM2,IERR
|
|
REAL H(NM,*),WR(*),WI(*)
|
|
REAL P,Q,R,S,T,W,X,Y,ZZ,NORM,S1,S2
|
|
LOGICAL NOTLAS
|
|
C
|
|
C***FIRST EXECUTABLE STATEMENT HQR
|
|
IERR = 0
|
|
NORM = 0.0E0
|
|
K = 1
|
|
C .......... STORE ROOTS ISOLATED BY BALANC
|
|
C AND COMPUTE MATRIX NORM ..........
|
|
DO 50 I = 1, N
|
|
C
|
|
DO 40 J = K, N
|
|
40 NORM = NORM + ABS(H(I,J))
|
|
C
|
|
K = I
|
|
IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50
|
|
WR(I) = H(I,I)
|
|
WI(I) = 0.0E0
|
|
50 CONTINUE
|
|
C
|
|
EN = IGH
|
|
T = 0.0E0
|
|
ITN = 30*N
|
|
C .......... SEARCH FOR NEXT EIGENVALUES ..........
|
|
60 IF (EN .LT. LOW) GO TO 1001
|
|
ITS = 0
|
|
NA = EN - 1
|
|
ENM2 = NA - 1
|
|
C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
|
|
C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
|
|
70 DO 80 LL = LOW, EN
|
|
L = EN + LOW - LL
|
|
IF (L .EQ. LOW) GO TO 100
|
|
S = ABS(H(L-1,L-1)) + ABS(H(L,L))
|
|
IF (S .EQ. 0.0E0) S = NORM
|
|
S2 = S + ABS(H(L,L-1))
|
|
IF (S2 .EQ. S) GO TO 100
|
|
80 CONTINUE
|
|
C .......... FORM SHIFT ..........
|
|
100 X = H(EN,EN)
|
|
IF (L .EQ. EN) GO TO 270
|
|
Y = H(NA,NA)
|
|
W = H(EN,NA) * H(NA,EN)
|
|
IF (L .EQ. NA) GO TO 280
|
|
IF (ITN .EQ. 0) GO TO 1000
|
|
IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130
|
|
C .......... FORM EXCEPTIONAL SHIFT ..........
|
|
T = T + X
|
|
C
|
|
DO 120 I = LOW, EN
|
|
120 H(I,I) = H(I,I) - X
|
|
C
|
|
S = ABS(H(EN,NA)) + ABS(H(NA,ENM2))
|
|
X = 0.75E0 * S
|
|
Y = X
|
|
W = -0.4375E0 * S * S
|
|
130 ITS = ITS + 1
|
|
ITN = ITN - 1
|
|
C .......... LOOK FOR TWO CONSECUTIVE SMALL
|
|
C SUB-DIAGONAL ELEMENTS.
|
|
C FOR M=EN-2 STEP -1 UNTIL L DO -- ..........
|
|
DO 140 MM = L, ENM2
|
|
M = ENM2 + L - MM
|
|
ZZ = H(M,M)
|
|
R = X - ZZ
|
|
S = Y - ZZ
|
|
P = (R * S - W) / H(M+1,M) + H(M,M+1)
|
|
Q = H(M+1,M+1) - ZZ - R - S
|
|
R = H(M+2,M+1)
|
|
S = ABS(P) + ABS(Q) + ABS(R)
|
|
P = P / S
|
|
Q = Q / S
|
|
R = R / S
|
|
IF (M .EQ. L) GO TO 150
|
|
S1 = ABS(P) * (ABS(H(M-1,M-1)) + ABS(ZZ) + ABS(H(M+1,M+1)))
|
|
S2 = S1 + ABS(H(M,M-1)) * (ABS(Q) + ABS(R))
|
|
IF (S2 .EQ. S1) GO TO 150
|
|
140 CONTINUE
|
|
C
|
|
150 MP2 = M + 2
|
|
C
|
|
DO 160 I = MP2, EN
|
|
H(I,I-2) = 0.0E0
|
|
IF (I .EQ. MP2) GO TO 160
|
|
H(I,I-3) = 0.0E0
|
|
160 CONTINUE
|
|
C .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND
|
|
C COLUMNS M TO EN ..........
|
|
DO 260 K = M, NA
|
|
NOTLAS = K .NE. NA
|
|
IF (K .EQ. M) GO TO 170
|
|
P = H(K,K-1)
|
|
Q = H(K+1,K-1)
|
|
R = 0.0E0
|
|
IF (NOTLAS) R = H(K+2,K-1)
|
|
X = ABS(P) + ABS(Q) + ABS(R)
|
|
IF (X .EQ. 0.0E0) GO TO 260
|
|
P = P / X
|
|
Q = Q / X
|
|
R = R / X
|
|
170 S = SIGN(SQRT(P*P+Q*Q+R*R),P)
|
|
IF (K .EQ. M) GO TO 180
|
|
H(K,K-1) = -S * X
|
|
GO TO 190
|
|
180 IF (L .NE. M) H(K,K-1) = -H(K,K-1)
|
|
190 P = P + S
|
|
X = P / S
|
|
Y = Q / S
|
|
ZZ = R / S
|
|
Q = Q / P
|
|
R = R / P
|
|
C .......... ROW MODIFICATION ..........
|
|
DO 210 J = K, EN
|
|
P = H(K,J) + Q * H(K+1,J)
|
|
IF (.NOT. NOTLAS) GO TO 200
|
|
P = P + R * H(K+2,J)
|
|
H(K+2,J) = H(K+2,J) - P * ZZ
|
|
200 H(K+1,J) = H(K+1,J) - P * Y
|
|
H(K,J) = H(K,J) - P * X
|
|
210 CONTINUE
|
|
C
|
|
J = MIN(EN,K+3)
|
|
C .......... COLUMN MODIFICATION ..........
|
|
DO 230 I = L, J
|
|
P = X * H(I,K) + Y * H(I,K+1)
|
|
IF (.NOT. NOTLAS) GO TO 220
|
|
P = P + ZZ * H(I,K+2)
|
|
H(I,K+2) = H(I,K+2) - P * R
|
|
220 H(I,K+1) = H(I,K+1) - P * Q
|
|
H(I,K) = H(I,K) - P
|
|
230 CONTINUE
|
|
C
|
|
260 CONTINUE
|
|
C
|
|
GO TO 70
|
|
C .......... ONE ROOT FOUND ..........
|
|
270 WR(EN) = X + T
|
|
WI(EN) = 0.0E0
|
|
EN = NA
|
|
GO TO 60
|
|
C .......... TWO ROOTS FOUND ..........
|
|
280 P = (Y - X) / 2.0E0
|
|
Q = P * P + W
|
|
ZZ = SQRT(ABS(Q))
|
|
X = X + T
|
|
IF (Q .LT. 0.0E0) GO TO 320
|
|
C .......... REAL PAIR ..........
|
|
ZZ = P + SIGN(ZZ,P)
|
|
WR(NA) = X + ZZ
|
|
WR(EN) = WR(NA)
|
|
IF (ZZ .NE. 0.0E0) WR(EN) = X - W / ZZ
|
|
WI(NA) = 0.0E0
|
|
WI(EN) = 0.0E0
|
|
GO TO 330
|
|
C .......... COMPLEX PAIR ..........
|
|
320 WR(NA) = X + P
|
|
WR(EN) = X + P
|
|
WI(NA) = ZZ
|
|
WI(EN) = -ZZ
|
|
330 EN = ENM2
|
|
GO TO 60
|
|
C .......... SET ERROR -- NO CONVERGENCE TO AN
|
|
C EIGENVALUE AFTER 30*N ITERATIONS ..........
|
|
1000 IERR = EN
|
|
1001 RETURN
|
|
END
|