F 7.8 Eigenvalues and Eigenvectors of a Matrix via the QR Algorithm
INTEGER FUNCTION EIGEN (VEC,ORTHO,EVNORM,BASIS,LD,N,MAT,
* SCAL,D,EIVEC,VALR,VALI,CNT,LOW,HIGH)
C
C*****************************************************************
C *
C PROGRAM OBJECTIVE: *
C ================== *
C This FUNCTION-subroutine of type INTEGER determines all *
C eigenvalues and eigenvectors of a real square matrix MAT. *
C The eigenvalues are stored in the vectors VALR(1:N) *
C (real parts) and VALI(1:N) (imaginary parts). *
C The eigenvectors are stored in the array EIVEC(1:N,1:N) *
C provided the flag VEC is set. *
C *
C INPUT PARAMETERS: *
C ================= *
C VEC: parameter designating eigenvector computation:*
C = .TRUE. : compute eigenvectors *
C = .FALSE.: compute eigenvalues only *
C ORTHO: flag indicating desired reduction of MAT to *
C Hessenberg form : if .TRUE. use orthogonal *
C transformations in ORTHES; if .FALSE. use *
C elementary Gauss eliminations via ELMHES which*
C is slightly faster. For symmetric matrices MAT*
C only ORTHES will preserve symmetry. *
C EVNORM: flag that governs potential normalizing of *
C eigenvectors if .TRUE. *
C N: order of the square matrix MAT *
C LD: leading dimension of the matrix MAT and the *
C vector EIVEC as defined in the calling program*
C MAT: 2-dimensional array MAT(1:N,1:N) of type *
C DOUBLE PRECISION, containing the real input *
C matrix *
C BASIS: basis of the floating-point representation *
C used by the machine (in most cases 2 or 16) *
C *
C OUTPUT PARAMETERS: *
C ================== *
C MAT: the upper triangle of this (N,N) matrix *
C contains the eigenvectors of the quasi-trian- *
C gular matrix, that is produced by the *
C QR-method. *
C D: N-vector with transform info from ORTHES *
C VALR,VALI: two N-vectors VALR(1:N), VALI(1:N) of type *
C DOUBLE PRECISION, that contain the real and *
C imaginary parts of the eigenvalues of MAT *
C EIVEC: 2-dimensional array EIVEC(1:N,1:N) of type *
C DOUBLE PRECISION, that contains the normalized*
C eigenvectors of the input matrix MAT as *
C columns in case VEC = .TRUE. . *
C If the I-th eigenvalue of MAT is real, the *
C I-th column of EIVEC contains the correspond- *
C ing real eigenvector. If the I-th and (I+1)-st*
C eigenvalues are a complex conjugate pair, *
C the I-th and (I+1)-st columns of EIVEC contain*
C the real and imaginary parts of the associated*
C eigenvector for the eigenvalue with positive *
C imaginary part. *
C CNT: N-vector CNT(1:N) of type INTEGER containing *
C the number of iteration steps for each eigen- *
C value. If two eigenvalues are found simul- *
C taneously as a complex conjugate pair, the *
C number of iteration steps used for both is *
C recorded with a positive sign for the first *
C and with a negative sign for the second *
C eigenvalue. *
C SCAL: N-vector SCAL(1:N) of type DOUBLE PRECISION *
C containing information about the permutations *
C and the scaling factors used. *
C LOW,HIGH: The rows numbered 1 to LOW-1 or HIGH+1 to N *
C contain isolated eigenvalues, i.e., eigen- *
C values for the eigenvectors e_i, the unit *
C vectors *
C *
C RETURN VALUES of FUNCTION EIGEN: *
C ================================ *
C 0: no error, eigenvalue-eigenvector problem solved. *
C 401: order N of the input matrix MAT is less than 1. *
C 402: MAT is the zero matrix. *
C 403: the maximum number of steps for the QR-method *
C has been reached. However, not all of the eigen- *
C values have be determined. *
C *
C LOCAL VARIABLES: *
C ================ *
C ONE,TWO,HALF: floating-point constants *
C EPS: machine constant *
C TEMP: auxiliary variable *
C *
C----------------------------------------------------------------*
C *
C subroutines required: BALAN, ELMHES, ELMTRA, HQR2, BALBAK *
C NORMAL, SWAP, COMDIV, COMABS, ORTHES, *
C ORTHTRA *
C *
C *
C sources : 1. Martin, R. S. and Wilkinson, J. H., *
C see [MART70]. *
C 2. Parlett, B. N. and Reinsch, C., see [PARL69]. *
C 3. Peters, G. and Wilkinson, J. H., see [PETE70]. *
C *
C*****************************************************************
C *
C author : Juergen Dietel *
C date : 7.15.1993 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
INTEGER BASIS,LD,N,CNT(1:N),LOW,HIGH
LOGICAL VEC,ORTHO,EVNORM
DOUBLE PRECISION MAT(1:LD,1:N),SCAL(1:N),EIVEC(1:LD,1:N)
DOUBLE PRECISION VALR(1:N),VALI(1:N),D(1:N)
DOUBLE PRECISION ONE,TWO,HALF
PARAMETER (ONE = 1.0D0,TWO = 2.0D0,HALF = 0.5D0)
INTEGER RES,BALAN,ELMHES,ORTHES,ELMTRA,ORTTRA,HQR2
INTEGER BALBAK, NORMAL
DOUBLE PRECISION EPS,TEMP
C
C determine the machine constant EPS, i.e., the smallest
C positive number for which the 1 + EPS > 1) is true
C
TEMP = TWO
EPS = ONE
10 IF (ONE .LT. TEMP) THEN
EPS = EPS * HALF
TEMP = ONE + EPS
GOTO 10
ENDIF
EPS = TWO * EPS
RES = BALAN(LD,N,MAT,SCAL,LOW,HIGH,BASIS)
IF (RES .NE. 0) THEN
EIGEN = RES + 100
RETURN
ENDIF
IF (ORTHO) THEN
RES = ORTHES(LD,N,LOW,HIGH,MAT,D,EPS)
ELSE
RES = ELMHES(LD,N,LOW,HIGH,MAT,CNT)
ENDIF
IF (RES .NE. 0) THEN
EIGEN = RES + 200
RETURN
ENDIF
IF (VEC) THEN
IF (ORTHO) THEN
RES = ORTTRA(LD,N,LOW,HIGH,MAT,D,EIVEC)
ELSE
RES = ELMTRA(LD,N,LOW,HIGH,MAT,CNT,EIVEC)
ENDIF
IF (RES .NE. 0) THEN
EIGEN = RES + 300
RETURN
ENDIF
ENDIF
RES = HQR2(VEC,LD,N,LOW,HIGH,MAT,VALR,VALI,EIVEC,CNT,EPS)
IF (RES .NE. 0) THEN
EIGEN = RES + 400
RETURN
ENDIF
IF (VEC) THEN
RES = BALBAK(LD,N,LOW,HIGH,SCAL,EIVEC)
IF (RES .NE. 0) THEN
EIGEN = RES + 500
RETURN
ENDIF
IF (EVNORM) THEN
RES = NORMAL(LD,N,EIVEC,VALI)
IF (RES .NE. 0) THEN
EIGEN = RES + 600
RETURN
ENDIF
ENDIF
ENDIF
EIGEN = 0
END
C
C
INTEGER FUNCTION BALAN (LD,N,MAT,SCAL,LOW,HIGH,BASIS)
C
C*****************************************************************
C *
C The procedure BALAN balances a given real matrix with *
C respect to the column sum norm. *
C *
C INPUT PARAMETERS: *
C ================= *
C LD: leading dimension of the matrix as defined in *
C the calling program *
C N: the order of the given square matrix *
C MAT: 2-dimensional array MAT(1:N,1:N) containing the *
C input matrix *
C BASIS: basis for the floating-point representation of *
C the machine *
C *
C OUTPUT PARAMETERS: *
C ================== *
C MAT: the balanced matrix *
C LOW,HIGH: two INTEGER numbers, for which MAT(I,J) = 0 *
C if the following holds: *
C 1. I > J, and *
C 2. J = 1, ..., LOW-1 or I = HIGH+1, ..., N *
C SCAL: N-vector SCAL(1:N) containing information about *
C permutations and scaling factors used. *
C *
C RETURN VALUE of SUBROUTINE BALAN: *
C ================================= *
C 0: no error *
C *
C LOCAL VARIABLES: *
C ============== = *
C ZERO,ONE,PT95: floating-point constants *
C I,J,K,L: counting variables *
C B2: square of the machine floating point basis *
C R,C,F,G,S: auxiliary variables for determining row *
C norms, reciprocals etc. *
C *
C----------------------------------------------------------------*
C *
C subroutines required: SWAP *
C *
C *
C sources : Parlett, B. N. and Reinsch, C., see [PARL69]. *
C *
C*****************************************************************
C *
C author : Juergen Dietel *
C date : 04.10.1987 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
INTEGER LD,N,LOW,HIGH,BASIS
DOUBLE PRECISION SCAL(1:N),MAT(1:LD,1:N)
DOUBLE PRECISION ZERO,ONE,PT95
PARAMETER (ZERO = 0.0D0,ONE = 1.0D0,PT95 = 0.95D0)
INTEGER I,J,K,L,B2
DOUBLE PRECISION R,C,F,G,S
C
C reduce the norm of MAT(1:N,1:N) by exact diagonal similarity
C transformations and store in SCAL(1:N)
C
B2 = BASIS*BASIS
L = 1
K = N
C
C search for rows isolating an eigenvalue and
C move them to the bottom
C
10 DO 50 J=K,1,-1
R = ZERO
DO 20 I=1,K
20 IF (I .NE. J) R = R+ABS(MAT(J,I))
IF (R .EQ. ZERO) THEN
SCAL(K) = J
IF (J .NE. K) THEN
DO 30 I=1,K
30 CALL SWAP(MAT(I,J),MAT(I,K))
DO 40 I=L,N
40 CALL SWAP(MAT(J,I),MAT(K,I))
ENDIF
K = K-1
GOTO 10
ENDIF
50 CONTINUE
C
C search for columns isolating an eigenvalue and
C move them to the left
C
60 DO 100 J=L,K
C = ZERO
DO 70 I=L,K
70 IF (I .NE. J) C = C+ABS(MAT(I,J))
IF (C .EQ. ZERO) THEN
SCAL(L) = J
IF (J .NE. L) THEN
DO 80 I=1,K
80 CALL SWAP(MAT(I,J),MAT(I,L))
DO 90 I=L,N
90 CALL SWAP(MAT(J,I),MAT(L,I))
ENDIF
L = L+1
GOTO 60
ENDIF
100 CONTINUE
C
C balance the matrix in rows L to K
C
LOW = L
HIGH = K
DO 110 I=L,K
110 SCAL(I) = ONE
120 DO 180 I=L,K
C = ZERO
R = ZERO
DO 130 J=L,K
IF (J .NE. I) THEN
C = C+ABS(MAT(J,I))
R = R+ABS(MAT(I,J))
ENDIF
130 CONTINUE
G = R/BASIS
F = ONE
S = C+R
140 IF (C .LT. G) THEN
F = F*BASIS
C = C*B2
GOTO 140
ENDIF
G = R*BASIS
150 IF (C .GE. G) THEN
F = F/BASIS
C = C/B2
GOTO 150
ENDIF
IF ((C+R)/F .LT. PT95*S) THEN
G = ONE/F
SCAL(I) = SCAL(I)*F
DO 160 J=L,N
160 MAT(I,J) = MAT(I,J)*G
DO 170 J=1,K
170 MAT(J,I) = MAT(J,I)*F
GOTO 120
ENDIF
180 CONTINUE
BALAN = 0
END
C
C
INTEGER FUNCTION BALBAK (LD,N,LOW,HIGH,SCAL,EIVEC)
C
C*****************************************************************
C *
C BALBAK transforms all right eigenvectors of a balanced *
C matrix back into the eigenvectors of the original matrix. *
C The balanced matrix was generated by calling the procedure *
C BALAN. *
C *
C INPUT PARAMETERS: *
C ================= *
C LD: leading dimension of the array EIVEC as defined *
C in the calling program *
C N: order of the eigenvectors (number of components) *
C LOW,HIGH: two INTEGER numbers that were created in the *
C procedure BALAN *
C SCAL: output vector of the procedure BALAN *
C EIVEC: 2-dimensional array EIVEC(1:N,1:N), each column *
C of EIVEC contains an eigenvector (or its real *
C or imaginary parts) for the balanced matrix *
C *
C OUTPUT PARAMETERS: *
C ================== *
C EIVEC: the eigenvectors (or their real or imaginary *
C parts) of the original matrix *
C *
C RETURN VALUE of SUBROUTINE BALBAK: *
C ================================== *
C 0: no error *
C *
C LOCAL VARIABLES: *
C ================ *
C I,J,K: auxiliary variables used for indexing *
C S: scaling constant *
C *
C----------------------------------------------------------------*
C *
C subroutines required: SWAP *
C *
C *
C sources : Parlett, B. N. and Reinsch, C., see [PARL69]. *
C *
C*****************************************************************
C *
C author : Juergen Dietel *
C date : 04.10.1987 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
INTEGER LD,N,LOW,HIGH
DOUBLE PRECISION SCAL(1:N),EIVEC(1:LD,1:N)
INTEGER I,J,K
DOUBLE PRECISION S
C
DO 20 I=LOW,HIGH
S = SCAL(I)
C
C left eigenvectors are back transformed, if the last
C statement is replaced by: S = 1.0D0/SCAL(I)
C
DO 10 J=1,N
10 EIVEC(I,J) = EIVEC(I,J)*S
20 CONTINUE
DO 40 I=LOW-1,1,-1
K=SCAL(I)
DO 30 J=1,N
30 CALL SWAP(EIVEC(I,J),EIVEC(K,J))
40 CONTINUE
DO 60 I=HIGH+1,N
K=SCAL(I)
DO 50 J=1,N
50 CALL SWAP(EIVEC(I,J),EIVEC(K,J))
60 CONTINUE
BALBAK = 0
END
C
C
INTEGER FUNCTION ELMHES (LD,N,LOW,HIGH,MAT,PERM)
C
C*****************************************************************
C Reduction of a general square matrix a(1:N,1:N) to *
C Hessenberg form by similarity with non-orthogonal Gaussian *
C elimination matrices. *
C*****************************************************************
C *
C PROGRAM OBJECTIVE: *
C ================== *
C For a general square matrix A(1:N,1:N) this program reduces*
C the principal submatrix of A of order HIGH-LOW+1, defined *
C to lie between the elements A(LOW,LOW) and A(HIGH,HIGH), *
C to Hessenberg form H by similarity with non-orthogonal *
C Gaussian elimination matrices. The principal submatrix is *
C overwriten with H. The transforming matrices are stored in *
C the triangle below H and in the vector PERM. *
C *
C INPUT PARAMETERS: *
C ================= *
C LD: leading dimension of the matrix as defined in *
C the calling program *
C N: order of the square matrix A *
C LOW,HIGH: output parameter of the balancing procedure *
C BALAN. If A has not been balanced, set LOW:=1, *
C and HIGH:=N. *
C MAT: 2-dimensional array MAT(1:N,1:N), the matrix in *
C balanced form *
C *
C OUTPUT PARAMETERS: *
C ================== *
C MAT: 2-dimensional array MAT(1:N,1:n), which consists *
C in part of the upper Hessenberg matrix and the *
C transforming matrices. *
C The number N(I,R+1), that is needed for the *
C reduction, is stored in the (I,R) position. *
C PERM: INTEGER vector that stores the row- and column *
C permutations performed during the reduction *
C *
C RETURN VALUE: *
C ============= *
C 0: no error *
C *
C LOCAL VARIABLES: *
C ================ *
C ZERO,ONE: floating-point constants *
C I,J,M: counters *
C X,Y: auxiliary variables used for storing matrix *
C elements and intermediate results *
C *
C----------------------------------------------------------------*
C *
C subroutines required: SWAP *
C *
C *
C sources : Martin, R. S. and Wilkinson, J. H., see [MART70]. *
C *
C*****************************************************************
C *
C author : Juergen Dietel *
C date : 04.10.1987 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
INTEGER N,LOW,HIGH,PERM(1:N)
DOUBLE PRECISION MAT(1:LD,1:N)
DOUBLE PRECISION ZERO,ONE
PARAMETER (ZERO = 0.0D0,ONE = 1.0D0)
INTEGER I,J,M
DOUBLE PRECISION X,Y
C
DO 70 M=LOW+1,HIGH-1
I = M
X = ZERO
DO 10 J=M,HIGH
IF (ABS(MAT(J,M-1)) .GT. ABS(X)) THEN
X = MAT(J,M-1)
I=J
ENDIF
10 CONTINUE
PERM(M) = I
IF (I .NE. M) THEN
C
C Swap rows and columns of MAT
C
DO 20 J=M-1,N
20 CALL SWAP(MAT(I,J),MAT(M,J))
DO 30 J=1,HIGH
30 CALL SWAP(MAT(J,I),MAT(J,M))
ENDIF
IF (X .NE. ZERO) THEN
DO 60 I=M+1,HIGH
Y = MAT(I,M-1)
IF (Y .NE. ZERO) THEN
Y = Y/X
MAT(I,M-1) = Y
DO 40 J=M,N
40 MAT(I,J) = MAT(I,J)-Y*MAT(M,J)
DO 50 J=1,HIGH
50 MAT(J,M) = MAT(J,M)+Y*MAT(J,I)
ENDIF
60 CONTINUE
ENDIF
70 CONTINUE
ELMHES = 0
END
C
C
INTEGER FUNCTION ELMTRA (LD,N,LOW,HIGH,MAT,PERM,H)
C
C*****************************************************************
C *
C Form the matrix of accumulated transformations from the *
C information left by procedure ELMHES in the lower triangle *
C of the Hessenberg matrix H - in MAT(1:N,1:N) and in the *
C INTEGER vector PERM(1:N). Store in the array H(1:N,1:N). *
C *
C INPUT PARAMETERS: *
C ================= *
C LD: leading dimension of the matrix as defined in *
C the calling program *
C N: order of the Hessenberg matrix H *
C LOW,HIGH: INTEGER numbers, that were produced by procedure *
C BALAN (if it was used; otherwise set LOW:=1, *
C HIGH:=N.) *
C PERM: INTEGER N-vector produced by ELMHES *
C MAT: (N,N)-matrix, that was produced by ELMHES and *
C contains the Hessenberg matrix H and the LR *
C multipliers used in order to create H from the *
C given matrix A *
C *
C OUTPUT PARAMETER: *
C ================= *
C H: (N,N)-matrix that describes the similarity *
C transformation of A to Hessenberg form H *
C *
C RETURN VALUE: *
C ============= *
C 0: no error *
C *
C LOCAL FACTORS: *
C ============== *
C ZERO,ONE: floating-point constants *
C I,J,K: index variables *
C *
C----------------------------------------------------------------*
C *
C subroutines required: none *
C *
C *
C sources : Peters, G. and Wilkinson, J. H., see [PETE70]. *
C *
C*****************************************************************
C *
C author : Juergen Dietel *
C date : 04.10.1987 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
INTEGER LD,N,LOW,HIGH,PERM(1:N)
DOUBLE PRECISION MAT(1:LD,1:N),H(1:LD,1:N)
DOUBLE PRECISION ZERO,ONE
PARAMETER (ZERO = 0.0D0,ONE = 1.0D0)
INTEGER I,J,K
C
DO 20 I=1,N
DO 10 J=1,N
10 H(I,J) = ZERO
H(I,I) = ONE
20 CONTINUE
C
DO 50 I=HIGH-1,LOW+1,-1
J=PERM(I)
DO 30 K=I+1,HIGH
30 H(K,I) = MAT(K,I-1)
IF (I .NE. J) THEN
DO 40 K=I,HIGH
H(I,K)=H(J,K)
H(J,K)=ZERO
40 CONTINUE
H(J,I) = ONE
ENDIF
50 CONTINUE
ELMTRA = 0
END
C
C
INTEGER FUNCTION ORTHES (LD,N,LOW,HIGH,MAT,D,EPSM)
C
C*****************************************************************
C *
C This function transform the matrix MAT to upper Hessenberg *
C using Householder transforms. *
C The essential transform information is stored in the otherwise*
C unused lower triangle of MAT and in the vector D. *
C *
C INPUT PARAMETERS: *
C ================= *
C LD leading dimension of the matrix MAT, as defined in the*
C calling program *
C N order of the matrix MAT *
C LOW \ the rows 1 to LOW-1 and HIGH+1 to N contain the *
C HIGH > isolated eigenvalues, i. e., those eigenvalues that *
C / have unit vectors e_i as eigenvectors. *
C MAT the original matrix MAT(1:N,1:N) *
C EPSM machine constant *
C *
C OUTPUT PARAMETERS: *
C ================== *
C MAT the desired Hessenberg matrix with part of the *
C transform information below the subdiagonal *
C D N-vector with the remainder of the transform info *
C *
C RETURN VALUE : *
C ============== *
C Error code. Only 0 (no error) is possible here. *
C *
C LOCAL VARIABLES: *
C ================ *
C I,J,M Loop variables *
C S Euclidean norm sigma of a column below the subdiagonal *
C v of MAT, which must be transformed into a multiple of *
C e1 = (1,0,...,0); (v = (v1,...,v(HIGH-M+1)) *
C X initially leading element of v, then summation value *
C inside the Householder transformation *
C Y initially sigma^2, then ||u||^2, where *
C u := v +- sigma * e1 *
C EPS accuracy bound to check transformation *
C ZERO double precision zero 0.0D0 *
C *
C*****************************************************************
C Reference: R.S. Martin and J.H. Wilkinson, Num. Math. 12 (1968)*
C pp. 359, 360, see [WILK71], contrib. II/13 *
C Author: Juergen Dietel, Computer Center, RWTH Aachen *
C Date: 7. 15. 1993 *
C*****************************************************************
C
INTEGER LD,N,LOW,HIGH
DOUBLE PRECISION MAT(1:LD,1:N),D(1:N),EPSM
C
INTEGER I,J,M
DOUBLE PRECISION S
DOUBLE PRECISION X
DOUBLE PRECISION Y
DOUBLE PRECISION EPS
C
DOUBLE PRECISION ZERO
PARAMETER (ZERO = 0.0D0)
C
EPS = 128 * EPSM
C
DO 80 M = LOW+1,HIGH-1
C
Y = ZERO
DO 10 I=HIGH,M,-1
X = MAT(I,M-1)
D(I) = X
Y = Y + X * X
10 CONTINUE
IF (Y .LE. EPS) THEN
S = ZERO
ELSE
C
IF (X .GE. ZERO) THEN
S = -SQRT(Y)
ELSE
S = SQRT(Y)
ENDIF
Y = Y - X * S
D(M) = X - S
C
C Multiply MAT on the left by (E-(u * uT)/y)
C
DO 40 J=M,N
X = ZERO
DO 20 I=HIGH,M,-1
X = X + D(I) * MAT(I,J)
20 CONTINUE
X = X / Y
DO 30 I=M,HIGH
MAT(I,J) = MAT(I,J) - X * D(I)
30 CONTINUE
40 CONTINUE
C
C Multiply MAT on the right by (E-(u * uT)/y)
C
DO 70 I=1,HIGH
X = ZERO
DO 50 J=HIGH,M,-1
X = X + D(J) * MAT(I,J)
50 CONTINUE
X = X / Y
DO 60 J=M,HIGH
MAT(I,J) = MAT(I,J) - X * D(J)
60 CONTINUE
70 CONTINUE
C
ENDIF
C
MAT(M,M-1) = S
80 CONTINUE
C
ORTHES = 0
C
END
C
C
INTEGER FUNCTION ORTTRA (LD,N,LOW,HIGH,MAT,D,V)
C
C*****************************************************************
C *
C Reconstruct the transformation matrix V of the Householder *
C reductions of MAT to Hessenberg form from the information *
C stored in the lower triangle of MAT and in D. *
C The contents of D is lost. *
C *
C INPUT PARAMETERS: *
C ================= *
C LD leading dimension of the matrices MAT and V, as *
C defined in the calling routine *
C N size of the matrix MAT *
C LOW \ the rows 1 to LOW-1 and the rows HIGH+1 to N *
C HIGH > contain the isolated eigenvalues, i.e. those with *
C / unit vectors e_i as eigenvectors. *
C MAT (1:N,1:N) matrix, that ORTHES has reduced to upper *
C Hessenberg form; partially filled with transformation *
C information *
C D N-vector with the remaining transform information *
C *
C OUTPUT PARAMETERS: *
C ================== *
C D modified input vector *
C V (1:N,1:N)-matrix, giving the similarity transform *
C from A to the upper Hessenberg matrix in MAT *
C *
C RETURN VALUE : *
C ============== *
C Error code. Only 0 possible here (no error). *
C *
C LOCAL VARIABLES: *
C ================ *
C I,J,M loop variables *
C X summation variable during Householder transformation *
C Y sigma or sigma * (v1 +- sigma) *
C ZERO double precision 0.0D0 *
C ONE double precision 1.0D0 *
C *
C*****************************************************************
C Reference: G. Peters and J.H. Wilkinson, Num. Math. 16 (1970) *
C p. 191, see [WILK71], contrib. II/15 *
C Author: Juergen Dietel, Computer Center, RWTH Aachen *
C Date: 7. 15. 1993 *
C*****************************************************************
C
INTEGER LD,N,LOW,HIGH
DOUBLE PRECISION MAT(1:LD,1:N),D(1:N),V(1:LD,1:N)
C
INTEGER I,J,M
DOUBLE PRECISION X
DOUBLE PRECISION Y
C
DOUBLE PRECISION ZERO,ONE
PARAMETER (ZERO = 0.0D0,ONE = 1.0D0)
C
C start with identity matrix in V
C
DO 20 I=1,N
DO 10 J=1,N
V(I,J) = ZERO
10 CONTINUE
V(I,I) = ONE
20 CONTINUE
C
C Perform the transformations that have reduced MAT to
C Hessenberg form on the unit matrix stored in V in order
C to generate the transformation matrix.
C
DO 70 M=HIGH-1,LOW+1,-1
Y = MAT(M,M-1)
C
IF (Y .NE. ZERO) THEN
Y = Y * D(M)
DO 30 I=M+1,HIGH
D(I) = MAT(I,M-1)
30 CONTINUE
DO 60 J=M,HIGH
X = ZERO
DO 40 I=M,HIGH
X = X + D(I) * V(I,J)
40 CONTINUE
X = X / Y
DO 50 I=M,HIGH
V(I,J) = V(I,J) + X * D(I)
50 CONTINUE
60 CONTINUE
ENDIF
70 CONTINUE
C
ORTTRA = 0
C
END
C
C
INTEGER FUNCTION HQR2 (VEC,LD,N,LOW,HIGH,H,VALR,VALI,
* EIVEC,CNT,EPS)
C
C*****************************************************************
C Finds the eigenvalues and eigenvectors of a real matrix, *
C which has been reduced to upper Hessenberg form. *
C*****************************************************************
C *
C Finds the eigenvalues and eigenvectors (if VEC = .TRUE.) of*
C a real matrix, which has been reduced to upper Hessenberg *
C form and is stored in the array H(1:N,1:N) with the accu- *
C mulated transformations stored in the array EIVEC(1:N,1:N).*
C The real and imaginary parts of the eigenvalues are placed *
C in the two vectors VALR(1:N), VALI(1:N) while the eigen- *
C vectors are stored in the array EIVEC(1:N,1:N), where only *
C one complex eigenvector corresponding to the eigenvalue *
C with positive imaginary part is stored for a complex con- *
C jugate eigenvalue pair. LOW and HIGH are two INTEGER *
C numbers produced during balancing MAT, so that eigenvalues *
C are isolated in positions 1 to LOW-1 and HIGH+1 to N. If *
C no initial balancing was performed, set LOW:=1, HIGH:=N. *
C The subroutine is aborted with an error message if any one *
C of the eigenvalues requires more than MAXSTP iterations. *
C *
C INPUT PARAMETERS: *
C ================= *
C VEC: parameter indicating eigenvector computation: *
C = .TRUE. : compute eigenvectors *
C = .FALSE. : compute eigenvalues only *
C LD: leading dimension of H and EIVEC, as defined in *
C the calling program *
C N: order of the Hessenberg matrix H *
C LOW,HIGH: INTEGER numbers produced by BALAN, if it was *
C used. Otherwise set LOW:=1, HIGH:=N. *
C EPS: machine constant *
C H: (N,N) matrix containing H with its relevant *
C components *
C EIVEC: (N,N) matrix containing the array that describes *
C the similarity transformation of A to H.. *
C (This was procuded by ELMTRA or ORTTRA.) *
C If H is the original matrix, define EIVEC := I, *
C the identity matrix. *
C *
C OUTPUT PARAMETERS: *
C ================== *
C H: the upper triangle of this (N,N) matrix *
C contains the eigenvectors of the quasi-trian- *
C gular matrix, that is produced by the QR steps*
C VALR,VALI: two N-vectors, with the real and imaginary *
C parts of the eigenvalues *
C CNT: INTEGER N-vector, with the count of iterations*
C for each eigenvalue. If two eigenvalues are *
C found as a complex conjugate pair, the number *
C of iterations is entered with a positive sign *
C for the first and with a negative sign for the*
C second eigenvalue. *
C EIVEC: (N,N) matrix, where (for VEC = .TRUE.) the *
C non-normalized eigenvectors of the original *
C matrix are stored in case H is not the *
C original matrix. *
C If the I-th eigenvalue is real, the I-th *
C column of EIVEC contains the corresponding *
C real eigenvector. If the eigenvalues numbered *
C I and I+1 form a complex conjugate eigenvalue *
C pair for MAT, then the I-th and (I+1)-st *
C columns of EIVEC contain the real and *
C imaginary parts of the eigenvector for the *
C corresponding eigenvalue with positive real *
C part. *
C *
C *
C RETURN VALUES: *
C ============== *
C 0: no error *
C 1: parameters N, LOW or HIGH are unacceptable *
C 2: all eigenvectors are the zero vector. *
C 3: the maximum number of QR-steps has been *
C exceeded. *
C *
C LOCAL VARIABLES: *
C ================ *
C ZERO,ONE,TWO,PT75,PT4375: floating-point constants *
C MAXSTP: maximum number of allowed steps *
C I,J,K,L,M,N,NA,EN: index variables *
C ITER: step counter *
C P,Q,R,S,T,W,X,Y,Z,NORM, *
C RA,SA,VR,VI: auxiliary variables *
C *
C----------------------------------------------------------------*
C *
C subroutines required: COMDIV *
C *
C *
C sources : Peters, G. and Wilkinson, J. H., see [PETE70]. *
C *
C*****************************************************************
C *
C author : Juergen Dietel *
C date : 07.14.1993 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
LOGICAL VEC
INTEGER LD,N,LOW,HIGH,CNT(1:N)
DOUBLE PRECISION H(1:LD,1:N),EIVEC(1:LD,1:N),VALR(1:N)
DOUBLE PRECISION VALI(1:N),EPS
DOUBLE PRECISION ZERO,ONE,TWO,PT75,PT4375
INTEGER MAXSTP
PARAMETER (ZERO = 0.0D0,ONE = 1.0D0,TWO = 2.0D0,
* PT75 = 0.75D0,PT4375 = 0.4375D0,
* MAXSTP = 100)
INTEGER I,J,K,L,M,NA,EN,ITER
DOUBLE PRECISION P,Q,R,S,T,W,X,Y,Z,NORM,RA,SA,VR,VI
C
C error 1: one of the parameters N, LOW or HIGH has an
C unacceptable value
C
IF (N .LT. 1 .OR. LOW .LT. 1 .OR. HIGH .GT. N) THEN
HQR2 = 1
RETURN
ENDIF
C
C initialize the isolated eigenvalues found during balancing:
C
DO 10 I=1,N
IF (I .LT. LOW .OR. I .GT. HIGH) THEN
VALR(I) = H(I,I)
VALI(I) = ZERO
CNT(I) = 0
ELSE
CNT(I) = -1
ENDIF
10 CONTINUE
C
EN = HIGH
T = ZERO
15 IF (EN .LT. LOW) GOTO 333
ITER = 0
NA = EN-1
C
C search for a single small subdiagonal element:
C
20 DO 30 L=EN,LOW+1,-1
30 IF (ABS(H(L,L-1)) .LE. EPS*
* (ABS(H(L-1,L-1))+ABS(H(L,L)))) GOTO 40
40 X = H(EN,EN)
IF (L .EQ. EN) THEN
C
C found one root:
C
VALR(EN) = X + T
H(EN,EN) = VALR(EN)
VALI(EN) = ZERO
CNT(EN) = ITER
EN = NA
GOTO 15
ENDIF
C
Y = H(NA,NA)
W = H(EN,NA)*H(NA,EN)
IF (L .EQ. NA) THEN
C
C found two roots:
C
P = (Y-X)/TWO
Q = P*P+W
Z = SQRT(ABS(Q))
H(EN,EN) = X+T
X = H(EN,EN)
H(NA,NA) = Y+T
CNT(EN) = -ITER
CNT(NA) = ITER
IF (Q .GE. ZERO) THEN
C
C found a real pair:
C
IF (P .LT. ZERO) Z = -Z
Z = P+Z
VALR(NA) = X+Z
VALR(EN) = X-W/Z
VALI(NA) = ZERO
VALI(EN) = ZERO
X = H(EN,NA)
R = SQRT(X*X+Z*Z)
\hbox{\JDhspace\verb`
IF (VEC) THEN
P = X/R
Q = Z/R
C
C row modification:
C
DO 50 J=NA,N
Z = H(NA,J)
H(NA,J) = Q*Z+P*H(EN,J)
H(EN,J) = Q*H(EN,J)-P*Z
50 CONTINUE
C
C column modification:
C
DO 60 I=1,EN
Z = H(I,NA)
H(I,NA) = Q*Z+P*H(I,EN)
H(I,EN) = Q*H(I,EN)-P*Z
60 CONTINUE
C
C accumulate transformations:
C
DO 70 I=LOW,HIGH
Z = EIVEC(I,NA)
EIVEC(I,NA) = Q*Z+P*EIVEC(I,EN)
EIVEC(I,EN) = Q*EIVEC(I,EN)-P*Z
70 CONTINUE
ENDIF
ELSE
C
C complex conjugate pair:
C
VALR(NA) = X+P
VALR(EN) = VALR(NA)
VALI(NA) = Z
VALI(EN) = -Z
ENDIF
EN = EN-2
GOTO 15
ENDIF
C
IF (ITER .EQ. MAXSTP) THEN
C
C error 3: maximal number of iterations exceeded:
C
CNT(EN) = MAXSTP+1
HQR2 = 3
RETURN
ENDIF
IF (MOD(ITER,10) .EQ. 0 .AND. ITER .NE. 0) THEN
C
C use exceptional shift:
C
T = T+X
DO 80 I=LOW,EN
80 H(I,I) = H(I,I)-X
S = ABS(H(EN,NA))+ABS(H(NA,EN-2))
X = PT75*S
Y = X
W = -PT4375*S*S
ENDIF
ITER = ITER+1
C
C search for two consecutive small subdiagonal elements:
C
DO 90 M=EN-2,L,-1
Z = H(M,M)
R = X-Z
S = Y-Z
P = (R*S-W)/H(M+1,M)+H(M,M+1)
Q = H(M+1,M+1)-Z-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) GOTO 100
IF (ABS(H(M,M-1))*(ABS(Q)+ABS(R)) .LE. EPS*ABS(P)*
* (ABS(H(M-1,M-1))+ABS(Z)+ABS(H(M+1,M+1))))
* GOTO 100
90 CONTINUE
100 DO 110 I=M+2,EN
110 H(I,I-2) = ZERO
DO 120 I=M+3,EN
120 H(I,I-3) = ZERO
C
C double QR-step involving rows L to EN and
C columns M to EN of the complete array:
C
DO 200 K=M,NA
IF (K .NE. M) THEN
P = H(K,K-1)
Q = H(K+1,K-1)
IF (K .NE. NA) THEN
R = H(K+2,K-1)
ELSE
R = ZERO
ENDIF
X = ABS(P)+ABS(Q)+ABS(R)
IF (X .EQ. ZERO) GOTO 200
P = P/X
Q = Q/X
R = R/X
ENDIF
S = SQRT(P*P+Q*Q+R*R)
IF (P .LT. ZERO) S = -S
IF (K .NE. M) THEN
H(K,K-1) = -S*X
ELSEIF (L .NE. M) THEN
H(K,K-1) = -H(K,K-1)
ENDIF
P = P+S
X = P/S
Y = Q/S
Z = R/S
Q = Q/P
R = R/P
C
C row modification:
C
DO 130 J=K,N
P = H(K,J)+Q*H(K+1,J)
IF (K .NE. NA) THEN
P = P+R*H(K+2,J)
H(K+2,J) = H(K+2,J)-P*Z
ENDIF
H(K+1,J) = H(K+1,J)-P*Y
H(K,J) = H(K,J)-P*X
130 CONTINUE
J = MIN(K+3,EN)
C
C column modification:
C
DO 140 I=1,J
P = X*H(I,K)+Y*H(I,K+1)
IF (K .NE. NA) THEN
P = P+Z*H(I,K+2)
H(I,K+2) = H(I,K+2)-P*R
ENDIF
H(I,K+1) = H(I,K+1)-P*Q
H(I,K) = H(I,K)-P
140 CONTINUE
C
IF (VEC) THEN
C
C accumulate transformations:
C
DO 150 I=LOW,HIGH
P = X*EIVEC(I,K)+Y*EIVEC(I,K+1)
IF (K .NE. NA) THEN
P = P+Z*EIVEC(I,K+2)
EIVEC(I,K+2) = EIVEC(I,K+2)-P*R
ENDIF
EIVEC(I,K+1) = EIVEC(I,K+1)-P*Q
EIVEC(I,K) = EIVEC(I,K)-P
150 CONTINUE
ENDIF
200 CONTINUE
GOTO 20
C
C
333 IF (.NOT. VEC) THEN
HQR2 = 0
RETURN
ENDIF
C
C
C all eigenvalues have been found; now transform back:
C
C find the 1-norm of H :
C
NORM = ZERO
K=1
DO 201 I=1,N
DO 101 J=K,N
101 NORM = NORM+ABS(H(I,J))
201 K = I
IF (NORM .EQ. ZERO) THEN
C Fehler 2: 1-Norm von H ist gleich 0:
HQR2 = 2
RETURN
ENDIF
C
C back transformation:
C
DO 207 EN=N,1,-1
P = VALR(EN)
Q = VALI(EN)
NA = EN - 1
IF (Q .EQ. ZERO) THEN
C
C real vector:
C
M = EN
H(EN,EN) = ONE
DO 63 I=NA,1,-1
W = H(I,I)-P
R = H(I,EN)
DO 38 J=M,NA
38 R = R+H(I,J)*H(J,EN)
IF (VALI(I) .LT. ZERO) THEN
Z = W
S = R
ELSE
M = I
IF (VALI(I) .EQ. ZERO) THEN
IF (W .NE. ZERO) THEN
H(I,EN) = -R/W
ELSE
H(I,EN) = -R/(EPS*NORM)
ENDIF
ELSE
C
C solve the linear system:
C [ W X ] [ H(I,EN) ] [ -R ]
C [ ] [ ] = [ ]
C [ Y Z ] [ H(I+1,EN) ] [ -S ]
C
X = H(I,I+1)
Y = H(I+1,I)
Q = (VALR(I)-P)*(VALR(I) - P)+
* VALI(I)*VALI(I)
T = (X*S-Z*R)/Q
H(I,EN) = T
IF (ABS(X) .GT. ABS(Z)) THEN
H(I+1,EN) = (-R-W*T)/X
ELSE
H(I+1,EN) = (-S-Y*T)/Z
ENDIF
ENDIF
ENDIF
63 CONTINUE
ELSEIF (Q .LT. ZERO) THEN
C
C complexer eigenvector for LAMBDA = P - I * Q :
C
M = NA
IF (ABS(H(EN,NA)) .GT. ABS(H(NA,EN))) THEN
H(NA,NA) = -(H(EN,EN)-P)/H(EN,NA)
H(NA,EN) = -Q/H(EN,NA)
ELSE
CALL COMDIV(-H(NA,EN),ZERO,H(NA,NA)-P,Q,
* H(NA,NA),H(NA,EN))
ENDIF
H(EN,NA) = ONE
H(EN,EN) = ZERO
DO 190 I=NA-1,1,-1
W = H(I,I)-P
RA = H(I,EN)
SA = ZERO
DO 75 J=M,NA
RA = RA+H(I,J)*H(J,NA)
SA = SA+H(I,J)*H(J,EN)
75 CONTINUE
IF (VALI(I) .LT. ZERO) THEN
Z = W
R = RA
S = SA
ELSE
M = I
IF (VALI(I) .EQ. ZERO) THEN
CALL COMDIV(-RA,-SA,W,Q,H(I,NA),H(I,EN))
ELSE
C
C solve the complex linear system:
C [ W+Q*I X ] [H(I,NA)+H(I,EN)*I ] [-RA-SA*I]
C [ ] [ ] = [ ]
C [ Y Z+Q*I ] [H(I+1,NA)+H(I+1,EN)*I] [-R-S*I ]
C
X = H(I,I+1)
Y = H(I+1,I)
VR = (VALR(I)-P)*(VALR(I)-P)+
* VALI(I)*VALI(I)-Q*Q
VI = TWO*Q*(VALR(I)-P)
IF (VR .EQ. ZERO .AND. VI .EQ. ZERO) VR =
* EPS*NORM*
* (ABS(W)+ABS(Q)+ABS(X)+ABS(Y)+ABS(Z))
CALL COMDIV(X*R-Z*RA+Q*SA,X*S-Z*SA-Q*RA,
* VR,VI,H(I,NA),H(I,EN))
IF (ABS(X) .GT. ABS(Z)+ABS(Q)) THEN
H(I+1,NA) = (-RA-W*H(I,NA)+Q*H(I,EN))/X
H(I+1,EN) = (-SA-W*H(I,EN)-Q*H(I,NA))/X
ELSE
CALL COMDIV(-R-Y*H(I,NA),-S-Y*H(I,EN),Z,Q,
* H(I+1,NA),H(I+1,EN))
ENDIF
ENDIF
ENDIF
190 CONTINUE
ENDIF
207 CONTINUE
C
C find eigenvectors for isolated eigenvalues:
C
DO 230 I=1,N
IF (I .LT. LOW .OR. I .GT. HIGH) THEN
DO 220 J=I+1,N
220 EIVEC(I,J) = H(I,J)
ENDIF
230 CONTINUE
C
C multiply by transformation matrix in order to
C obtain eigenvectors of the original matrix MAT:
C
DO 300 J=N,LOW,-1
IF (J .LE. HIGH) THEN
M = J
ELSE
M = HIGH
ENDIF
L = J-1
IF (VALI(J) .LT. ZERO) THEN
DO 330 I=LOW,HIGH
Y = ZERO
Z = ZERO
DO 320 K=LOW,M
Y = Y+EIVEC(I,K)*H(K,L)
Z = Z+EIVEC(I,K)*H(K,J)
320 CONTINUE
EIVEC(I,L) = Y
EIVEC(I,J) = Z
330 CONTINUE
ELSE
IF (VALI(J) .EQ. ZERO) THEN
DO 350 I=LOW,HIGH
Z = ZERO
DO 340 K=LOW,M
340 Z =Z+EIVEC(I,K)*H(K,J)
350 EIVEC(I,J) = Z
ENDIF
ENDIF
300 CONTINUE
C
C Return 0: no error
C
HQR2 = 0
END
C
C
SUBROUTINE COMDIV (AR,AI,BR,BI,RESR,RESI)
C
C*****************************************************************
C *
C complex division: RESR+I*RESI := (AR+I*AI)/(BR+I*BI). *
C (this procedure should not be called if BR=BI=0.) *
C *
C INPUT PARAMETERS: *
C ================= *
C AR,AI: real and imaginary parts of the numerator *
C BR,BI: real and imaginary parts of the denominator *
C *
C OUTPUT PARAMETERS: *
C ================== *
C RESR,RESI: real and imaginary parts of the quotient *
C *
C LOCAL VARIABLES: *
C ================ *
C ZERO: floating-point constant 0 *
C TEMP1,TEMP2,TEMP3: auxiliary variables for intermediate *
C values *
C *
C----------------------------------------------------------------*
C *
C subroutines required: none *
C *
C *
C sources : Martin, R. S. and Wilkinson, J. H., see [MART68]. *
C *
C*****************************************************************
C *
C author : Juergen Dietel *
C date : 04.10.1987 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
DOUBLE PRECISION AR,AI,BR,BI,RESR,RESI
DOUBLE PRECISION ZERO
PARAMETER (ZERO = 0.0D0)
DOUBLE PRECISION TEMP1,TEMP2,TEMP3
C
IF (BR .EQ. ZERO .AND. BI .EQ. ZERO) THEN
RESR = ZERO
RESI = ZERO
RETURN
ENDIF
IF (ABS(BR) .GT. ABS(BI)) THEN
TEMP1 = BI/BR
TEMP2 = TEMP1*BI+BR
TEMP3 = (AR+TEMP1*AI)/TEMP2
RESI = (AI-TEMP1*AR)/TEMP2
RESR = TEMP3
ELSE
TEMP1 = BR/BI
TEMP2 = TEMP1*BR+BI
TEMP3 = (TEMP1*AR+AI)/TEMP2
RESI = (TEMP1*AI-AR)/TEMP2
RESR = TEMP3
ENDIF
END
C
C
DOUBLE PRECISION FUNCTION COMABS (AR,AI)
C
C*****************************************************************
C *
C Determine the absolute value of the complex number AR+I*AI:*
C COMABS:=SQRT(AR*AR+AI*AI) *
C *
C INPUT PARAMETERS: *
C ================= *
C AR,AI: the real and imaginary parts of the complex number *
C whose absolute value is to be determined *
C *
C OUTPUT PARAMETER: *
C ================= *
C none *
C *
C RETURN VALUE: *
C ============= *
C value of the complex parameter *
C *
C LOCAL VARIABLES: *
C ================ *
C ZERO,ONE: constants *
C TEMP1,TEMP2: auxiliary variables *
C *
C----------------------------------------------------------------*
C *
C subroutines required: SWAP *
C *
C *
C sources : Martin, R. S. and Wilkinson, J. H., see [MART68]. *
C *
C*****************************************************************
C *
C author : Juergen Dietel *
C date : 04.10.1987 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
DOUBLE PRECISION AR,AI
DOUBLE PRECISION ZERO,ONE
PARAMETER (ZERO = 0.0D0,ONE = 1.0D0)
DOUBLE PRECISION TEMP1,TEMP2
C
TEMP1 = ABS(AR)
TEMP2 = ABS(AI)
IF (AR .EQ. ZERO .AND. AI .EQ. ZERO) THEN
COMABS = ZERO
RETURN
ENDIF
IF (TEMP2 .GT. TEMP1) CALL SWAP(TEMP1,TEMP2)
IF (TEMP2 .EQ. ZERO) THEN
COMABS = TEMP1
ELSE
COMABS = TEMP1*SQRT(ONE+(TEMP2/TEMP1)**2)
ENDIF
END
C
C
INTEGER FUNCTION NORMAL (LD,N,V,WI)
C
C*****************************************************************
C *
C NORMAL normalizes a set of eigenvectors in the maximum norm*
C *
C INPUT PARAMETERS: *
C ================= *
C LD: leading dimension of array V as defined in the *
C calling program *
C N: the order of the square array V *
C V: (N,N) matrix of type DOUBLE PRECISION that contains*
C the eigenvectors column-wise (see its description *
C in EIGEN under EIVEC) *
C WI: N-vector WI(1:N) of type DOUBLE PRECISION. Its *
C components are the imaginary parts of the *
C corresponding eigenvalues *
C *
C OUTPUT PARAMETER: *
C ================= *
C V: array containing the normalized eigenvectors *
C *
C LOCAL VARIABLES: *
C ================ *
C ZERO,ONE: floating-point constants 0 and 1 *
C I,J: indexing variables *
C MAXI: auxiliary variable for determining the norm of *
C a real vector *
C TR,TI: auxiliary variables for determining the norm of *
C a complex vector *
C *
C----------------------------------------------------------------*
C *
C subroutines required: COMABS, COMDIV *
C *
C*****************************************************************
C *
C author : Juergen Dietel *
C date : 04.10.1987 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
INTEGER LD,N
DOUBLE PRECISION V(1:LD,1:N),WI(1:N)
DOUBLE PRECISION ZERO,ONE
PARAMETER (ZERO = 0.0D0,ONE = 1.0D0)
INTEGER I,J
DOUBLE PRECISION MAXI,TR,TI,COMABS
C
J = 1
10 IF (J .GT. N) GOTO 80
IF (WI(J) .EQ. ZERO) THEN
MAXI = V(1,J)
DO 15 I=2,N
15 IF (ABS(V(I,J)) .GT. ABS(MAXI)) MAXI = V(I,J)
IF (MAXI .NE. ZERO) THEN
MAXI = ONE/MAXI
DO 20 I=1,N
20 V(I,J) = V(I,J)*MAXI
ENDIF
J = J+1
ELSE
TR = V(1,J)
TI = V(1,J+1)
DO 30 I=2,N
IF (COMABS(V(I,J),V(I,J+1)) .GT. COMABS(TR,TI))
* THEN
TR = V(I,J)
TI = V(I,J+1)
ENDIF
30 CONTINUE
IF (TR .NE. ZERO .OR. TI .NE. ZERO) THEN
DO 40 I=1,N
40 CALL COMDIV(V(I,J),V(I,J+1),TR,TI,
* V(I,J),V(I,J+1))
ENDIF
J = J+2
ENDIF
GOTO 10
80 NORMAL = 0
END
C
C
SUBROUTINE SWAP (X,Y)
C
C*****************************************************************
C *
C PROGRAM OBJECTIVE: *
C ================== *
C SWAP interchanges the values of the two DOUBLE PRECISION *
C variables X and Y. *
C *
C*****************************************************************
C
DOUBLE PRECISION X,Y
DOUBLE PRECISION TEMP
TEMP = X
X = Y
Y = TEMP
END