SUBROUTINE CDIV(AR,AI,BR,BI,CR,CI) REAL AR,AI,BR,BI,CR,CI C C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI) C REAL S,ARS,AIS,BRS,BIS S = ABS(BR) + ABS(BI) ARS = AR/S AIS = AI/S BRS = BR/S BIS = BI/S S = BRS**2 + BIS**2 CR = (ARS*BRS + AIS*BIS)/S CI = (AIS*BRS - ARS*BIS)/S RETURN END SUBROUTINE CSROOT(XR,XI,YR,YI) REAL XR,XI,YR,YI C C (YR,YI) = COMPLEX SQRT(XR,XI) C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI) C REAL S,TR,TI,PYTHAG TR = XR TI = XI S = SQRT(0.5E0*(PYTHAG(TR,TI) + ABS(TR))) IF (TR .GE. 0.0E0) YR = S IF (TI .LT. 0.0E0) S = -S IF (TR .LE. 0.0E0) YI = S IF (TR .LT. 0.0E0) YR = 0.5E0*(TI/YI) IF (TR .GT. 0.0E0) YI = 0.5E0*(TI/YR) RETURN END REAL FUNCTION EPSLON (X) REAL X C C ESTIMATE UNIT ROUNDOFF IN QUANTITIES OF SIZE X. C REAL A,B,C,EPS C C THIS PROGRAM SHOULD FUNCTION PROPERLY ON ALL SYSTEMS C SATISFYING THE FOLLOWING TWO ASSUMPTIONS, C 1. THE BASE USED IN REPRESENTING FLOATING POINT C NUMBERS IS NOT A POWER OF THREE. C 2. THE QUANTITY A IN STATEMENT 10 IS REPRESENTED TO C THE ACCURACY USED IN FLOATING POINT VARIABLES C THAT ARE STORED IN MEMORY. C THE STATEMENT NUMBER 10 AND THE GO TO 10 ARE INTENDED TO C FORCE OPTIMIZING COMPILERS TO GENERATE CODE SATISFYING C ASSUMPTION 2. C UNDER THESE ASSUMPTIONS, IT SHOULD BE TRUE THAT, C A IS NOT EXACTLY EQUAL TO FOUR-THIRDS, C B HAS A ZERO FOR ITS LAST BIT OR DIGIT, C C IS NOT EXACTLY EQUAL TO ONE, C EPS MEASURES THE SEPARATION OF 1.0 FROM C THE NEXT LARGER FLOATING POINT NUMBER. C THE DEVELOPERS OF EISPACK WOULD APPRECIATE BEING INFORMED C ABOUT ANY SYSTEMS WHERE THESE ASSUMPTIONS DO NOT HOLD. C C THIS VERSION DATED 4/6/83. C A = 4.0E0/3.0E0 10 B = A - 1.0E0 C = B + B + B EPS = ABS(C-1.0E0) IF (EPS .EQ. 0.0E0) GO TO 10 EPSLON = EPS*ABS(X) RETURN END REAL FUNCTION PYTHAG(A,B) REAL A,B C C FINDS SQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW C REAL P,R,S,T,U P = AMAX1(ABS(A),ABS(B)) IF (P .EQ. 0.0E0) GO TO 20 R = (AMIN1(ABS(A),ABS(B))/P)**2 10 CONTINUE T = 4.0E0 + R IF (T .EQ. 4.0E0) GO TO 20 S = R/T U = 1.0E0 + 2.0E0*S P = U*P R = (S/U)**2 * R GO TO 10 20 PYTHAG = P RETURN END SUBROUTINE BAKVEC(NM,N,T,E,M,Z,IERR) C INTEGER I,J,M,N,NM,IERR REAL T(NM,3),E(N),Z(NM,M) C C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A NONSYMMETRIC C TRIDIAGONAL MATRIX BY BACK TRANSFORMING THOSE OF THE C CORRESPONDING SYMMETRIC MATRIX DETERMINED BY FIGI. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C T CONTAINS THE NONSYMMETRIC MATRIX. ITS SUBDIAGONAL IS C STORED IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN, C ITS DIAGONAL IN THE N POSITIONS OF THE SECOND COLUMN, C AND ITS SUPERDIAGONAL IN THE FIRST N-1 POSITIONS OF C THE THIRD COLUMN. T(1,1) AND T(N,3) ARE ARBITRARY. C C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE SYMMETRIC C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. C C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. C C Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED C IN ITS FIRST M COLUMNS. C C ON OUTPUT C C T IS UNALTERED. C C E IS DESTROYED. C C Z CONTAINS THE TRANSFORMED EIGENVECTORS C IN ITS FIRST M COLUMNS. C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C 2*N+I IF E(I) IS ZERO WITH T(I,1) OR T(I-1,3) NON-ZERO. C IN THIS CASE, THE SYMMETRIC MATRIX IS NOT SIMILAR C TO THE ORIGINAL MATRIX, AND THE EIGENVECTORS C CANNOT BE FOUND BY THIS PROGRAM. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C IERR = 0 IF (M .EQ. 0) GO TO 1001 E(1) = 1.0E0 IF (N .EQ. 1) GO TO 1001 C DO 100 I = 2, N IF (E(I) .NE. 0.0E0) GO TO 80 IF (T(I,1) .NE. 0.0E0 .OR. T(I-1,3) .NE. 0.0E0) GO TO 1000 E(I) = 1.0E0 GO TO 100 80 E(I) = E(I-1) * E(I) / T(I-1,3) 100 CONTINUE C DO 120 J = 1, M C DO 120 I = 2, N Z(I,J) = Z(I,J) * E(I) 120 CONTINUE C GO TO 1001 C .......... SET ERROR -- EIGENVECTORS CANNOT BE C FOUND BY THIS PROGRAM .......... 1000 IERR = 2 * N + I 1001 RETURN END SUBROUTINE BALANC(NM,N,A,LOW,IGH,SCALE) C INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC REAL A(NM,N),SCALE(N) REAL C,F,G,R,S,B2,RADIX LOGICAL NOCONV C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALANCE, C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). C C THIS SUBROUTINE BALANCES A REAL MATRIX AND ISOLATES C EIGENVALUES WHENEVER POSSIBLE. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C A CONTAINS THE INPUT MATRIX TO BE BALANCED. C C ON OUTPUT C C A CONTAINS THE BALANCED MATRIX. C C LOW AND IGH ARE TWO INTEGERS SUCH THAT A(I,J) C IS EQUAL TO ZERO IF C (1) I IS GREATER THAN J AND C (2) J=1,...,LOW-1 OR I=IGH+1,...,N. C C SCALE CONTAINS INFORMATION DETERMINING THE C PERMUTATIONS AND SCALING FACTORS USED. C C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN C SCALE(J) = P(J), FOR J = 1,...,LOW-1 C = D(J,J), J = LOW,...,IGH C = P(J) J = IGH+1,...,N. C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1, C THEN 1 TO LOW-1. C C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY. C C THE ALGOL PROCEDURE EXC CONTAINED IN BALANCE APPEARS IN C BALANC IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS C K,L HAVE BEEN REVERSED.) C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C RADIX = 16.0E0 C B2 = RADIX * RADIX K = 1 L = N GO TO 100 C .......... IN-LINE PROCEDURE FOR ROW AND C COLUMN EXCHANGE .......... 20 SCALE(M) = J IF (J .EQ. M) GO TO 50 C DO 30 I = 1, L F = A(I,J) A(I,J) = A(I,M) A(I,M) = F 30 CONTINUE C DO 40 I = K, N F = A(J,I) A(J,I) = A(M,I) A(M,I) = F 40 CONTINUE C 50 GO TO (80,130), IEXC C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE C AND PUSH THEM DOWN .......... 80 IF (L .EQ. 1) GO TO 280 L = L - 1 C .......... FOR J=L STEP -1 UNTIL 1 DO -- .......... 100 DO 120 JJ = 1, L J = L + 1 - JJ C DO 110 I = 1, L IF (I .EQ. J) GO TO 110 IF (A(J,I) .NE. 0.0E0) GO TO 120 110 CONTINUE C M = L IEXC = 1 GO TO 20 120 CONTINUE C GO TO 140 C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE C AND PUSH THEM LEFT .......... 130 K = K + 1 C 140 DO 170 J = K, L C DO 150 I = K, L IF (I .EQ. J) GO TO 150 IF (A(I,J) .NE. 0.0E0) GO TO 170 150 CONTINUE C M = K IEXC = 2 GO TO 20 170 CONTINUE C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L .......... DO 180 I = K, L 180 SCALE(I) = 1.0E0 C .......... ITERATIVE LOOP FOR NORM REDUCTION .......... 190 NOCONV = .FALSE. C DO 270 I = K, L C = 0.0E0 R = 0.0E0 C DO 200 J = K, L IF (J .EQ. I) GO TO 200 C = C + ABS(A(J,I)) R = R + ABS(A(I,J)) 200 CONTINUE C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW .......... IF (C .EQ. 0.0E0 .OR. R .EQ. 0.0E0) GO TO 270 G = R / RADIX F = 1.0E0 S = C + R 210 IF (C .GE. G) GO TO 220 F = F * RADIX C = C * B2 GO TO 210 220 G = R * RADIX 230 IF (C .LT. G) GO TO 240 F = F / RADIX C = C / B2 GO TO 230 C .......... NOW BALANCE .......... 240 IF ((C + R) / F .GE. 0.95E0 * S) GO TO 270 G = 1.0E0 / F SCALE(I) = SCALE(I) * F NOCONV = .TRUE. C DO 250 J = K, N 250 A(I,J) = A(I,J) * G C DO 260 J = 1, L 260 A(J,I) = A(J,I) * F C 270 CONTINUE C IF (NOCONV) GO TO 190 C 280 LOW = K IGH = L RETURN END SUBROUTINE BALBAK(NM,N,LOW,IGH,SCALE,M,Z) C INTEGER I,J,K,M,N,II,NM,IGH,LOW REAL SCALE(N),Z(NM,M) REAL S C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALBAK, C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). C C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL GENERAL C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING C BALANCED MATRIX DETERMINED BY BALANC. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C LOW AND IGH ARE INTEGERS DETERMINED BY BALANC. C C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS C AND SCALING FACTORS USED BY BALANC. C C M IS THE NUMBER OF COLUMNS OF Z TO BE BACK TRANSFORMED. C C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGEN- C VECTORS TO BE BACK TRANSFORMED IN ITS FIRST M COLUMNS. C C ON OUTPUT C C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE C TRANSFORMED EIGENVECTORS IN ITS FIRST M COLUMNS. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C IF (M .EQ. 0) GO TO 200 IF (IGH .EQ. LOW) GO TO 120 C DO 110 I = LOW, IGH S = SCALE(I) C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED C IF THE FOREGOING STATEMENT IS REPLACED BY C S=1.0E0/SCALE(I). .......... DO 100 J = 1, M 100 Z(I,J) = Z(I,J) * S C 110 CONTINUE C ......... FOR I=LOW-1 STEP -1 UNTIL 1, C IGH+1 STEP 1 UNTIL N DO -- .......... 120 DO 140 II = 1, N I = II IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140 IF (I .LT. LOW) I = LOW - II K = SCALE(I) IF (K .EQ. I) GO TO 140 C DO 130 J = 1, M S = Z(I,J) Z(I,J) = Z(K,J) Z(K,J) = S 130 CONTINUE C 140 CONTINUE C 200 RETURN END SUBROUTINE BANDR(NM,N,MB,A,D,E,E2,MATZ,Z) C INTEGER J,K,L,N,R,I1,I2,J1,J2,KR,MB,MR,M1,NM,N2,R1,UGL,MAXL,MAXR REAL A(NM,MB),D(N),E(N),E2(N),Z(NM,N) REAL G,U,B1,B2,C2,F1,F2,S2,DMIN,DMINRT LOGICAL MATZ C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BANDRD, C NUM. MATH. 12, 231-241(1968) BY SCHWARZ. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 273-283(1971). C C THIS SUBROUTINE REDUCES A REAL SYMMETRIC BAND MATRIX C TO A SYMMETRIC TRIDIAGONAL MATRIX USING AND OPTIONALLY C ACCUMULATING ORTHOGONAL SIMILARITY TRANSFORMATIONS. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C MB IS THE (HALF) BAND WIDTH OF THE MATRIX, DEFINED AS THE C NUMBER OF ADJACENT DIAGONALS, INCLUDING THE PRINCIPAL C DIAGONAL, REQUIRED TO SPECIFY THE NON-ZERO PORTION OF THE C LOWER TRIANGLE OF THE MATRIX. C C A CONTAINS THE LOWER TRIANGLE OF THE SYMMETRIC BAND INPUT C MATRIX STORED AS AN N BY MB ARRAY. ITS LOWEST SUBDIAGONAL C IS STORED IN THE LAST N+1-MB POSITIONS OF THE FIRST COLUMN, C ITS NEXT SUBDIAGONAL IN THE LAST N+2-MB POSITIONS OF THE C SECOND COLUMN, FURTHER SUBDIAGONALS SIMILARLY, AND FINALLY C ITS PRINCIPAL DIAGONAL IN THE N POSITIONS OF THE LAST COLUMN. C CONTENTS OF STORAGES NOT PART OF THE MATRIX ARE ARBITRARY. C C MATZ SHOULD BE SET TO .TRUE. IF THE TRANSFORMATION MATRIX IS C TO BE ACCUMULATED, AND TO .FALSE. OTHERWISE. C C ON OUTPUT C C A HAS BEEN DESTROYED, EXCEPT FOR ITS LAST TWO COLUMNS WHICH C CONTAIN A COPY OF THE TRIDIAGONAL MATRIX. C C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. C C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. C C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. C C Z CONTAINS THE ORTHOGONAL TRANSFORMATION MATRIX PRODUCED IN C THE REDUCTION IF MATZ HAS BEEN SET TO .TRUE. OTHERWISE, Z C IS NOT REFERENCED. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C DMIN = 2.0E0**(-64) DMINRT = 2.0E0**(-32) C .......... INITIALIZE DIAGONAL SCALING MATRIX .......... DO 30 J = 1, N 30 D(J) = 1.0E0 C IF (.NOT. MATZ) GO TO 60 C DO 50 J = 1, N C DO 40 K = 1, N 40 Z(J,K) = 0.0E0 C Z(J,J) = 1.0E0 50 CONTINUE C 60 M1 = MB - 1 IF (M1 - 1) 900, 800, 70 70 N2 = N - 2 C DO 700 K = 1, N2 MAXR = MIN0(M1,N-K) C .......... FOR R=MAXR STEP -1 UNTIL 2 DO -- .......... DO 600 R1 = 2, MAXR R = MAXR + 2 - R1 KR = K + R MR = MB - R G = A(KR,MR) A(KR-1,1) = A(KR-1,MR+1) UGL = K C DO 500 J = KR, N, M1 J1 = J - 1 J2 = J1 - 1 IF (G .EQ. 0.0E0) GO TO 600 B1 = A(J1,1) / G B2 = B1 * D(J1) / D(J) S2 = 1.0E0 / (1.0E0 + B1 * B2) IF (S2 .GE. 0.5E0 ) GO TO 450 B1 = G / A(J1,1) B2 = B1 * D(J) / D(J1) C2 = 1.0E0 - S2 D(J1) = C2 * D(J1) D(J) = C2 * D(J) F1 = 2.0E0 * A(J,M1) F2 = B1 * A(J1,MB) A(J,M1) = -B2 * (B1 * A(J,M1) - A(J,MB)) - F2 + A(J,M1) A(J1,MB) = B2 * (B2 * A(J,MB) + F1) + A(J1,MB) A(J,MB) = B1 * (F2 - F1) + A(J,MB) C DO 200 L = UGL, J2 I2 = MB - J + L U = A(J1,I2+1) + B2 * A(J,I2) A(J,I2) = -B1 * A(J1,I2+1) + A(J,I2) A(J1,I2+1) = U 200 CONTINUE C UGL = J A(J1,1) = A(J1,1) + B2 * G IF (J .EQ. N) GO TO 350 MAXL = MIN0(M1,N-J1) C DO 300 L = 2, MAXL I1 = J1 + L I2 = MB - L U = A(I1,I2) + B2 * A(I1,I2+1) A(I1,I2+1) = -B1 * A(I1,I2) + A(I1,I2+1) A(I1,I2) = U 300 CONTINUE C I1 = J + M1 IF (I1 .GT. N) GO TO 350 G = B2 * A(I1,1) 350 IF (.NOT. MATZ) GO TO 500 C DO 400 L = 1, N U = Z(L,J1) + B2 * Z(L,J) Z(L,J) = -B1 * Z(L,J1) + Z(L,J) Z(L,J1) = U 400 CONTINUE C GO TO 500 C 450 U = D(J1) D(J1) = S2 * D(J) D(J) = S2 * U F1 = 2.0E0 * A(J,M1) F2 = B1 * A(J,MB) U = B1 * (F2 - F1) + A(J1,MB) A(J,M1) = B2 * (B1 * A(J,M1) - A(J1,MB)) + F2 - A(J,M1) A(J1,MB) = B2 * (B2 * A(J1,MB) + F1) + A(J,MB) A(J,MB) = U C DO 460 L = UGL, J2 I2 = MB - J + L U = B2 * A(J1,I2+1) + A(J,I2) A(J,I2) = -A(J1,I2+1) + B1 * A(J,I2) A(J1,I2+1) = U 460 CONTINUE C UGL = J A(J1,1) = B2 * A(J1,1) + G IF (J .EQ. N) GO TO 480 MAXL = MIN0(M1,N-J1) C DO 470 L = 2, MAXL I1 = J1 + L I2 = MB - L U = B2 * A(I1,I2) + A(I1,I2+1) A(I1,I2+1) = -A(I1,I2) + B1 * A(I1,I2+1) A(I1,I2) = U 470 CONTINUE C I1 = J + M1 IF (I1 .GT. N) GO TO 480 G = A(I1,1) A(I1,1) = B1 * A(I1,1) 480 IF (.NOT. MATZ) GO TO 500 C DO 490 L = 1, N U = B2 * Z(L,J1) + Z(L,J) Z(L,J) = -Z(L,J1) + B1 * Z(L,J) Z(L,J1) = U 490 CONTINUE C 500 CONTINUE C 600 CONTINUE C IF (MOD(K,64) .NE. 0) GO TO 700 C .......... RESCALE TO AVOID UNDERFLOW OR OVERFLOW .......... DO 650 J = K, N IF (D(J) .GE. DMIN) GO TO 650 MAXL = MAX0(1,MB+1-J) C DO 610 L = MAXL, M1 610 A(J,L) = DMINRT * A(J,L) C IF (J .EQ. N) GO TO 630 MAXL = MIN0(M1,N-J) C DO 620 L = 1, MAXL I1 = J + L I2 = MB - L A(I1,I2) = DMINRT * A(I1,I2) 620 CONTINUE C 630 IF (.NOT. MATZ) GO TO 645 C DO 640 L = 1, N 640 Z(L,J) = DMINRT * Z(L,J) C 645 A(J,MB) = DMIN * A(J,MB) D(J) = D(J) / DMIN 650 CONTINUE C 700 CONTINUE C .......... FORM SQUARE ROOT OF SCALING MATRIX .......... 800 DO 810 J = 2, N 810 E(J) = SQRT(D(J)) C IF (.NOT. MATZ) GO TO 840 C DO 830 J = 1, N C DO 820 K = 2, N 820 Z(J,K) = E(K) * Z(J,K) C 830 CONTINUE C 840 U = 1.0E0 C DO 850 J = 2, N A(J,M1) = U * E(J) * A(J,M1) U = E(J) E2(J) = A(J,M1) ** 2 A(J,MB) = D(J) * A(J,MB) D(J) = A(J,MB) E(J) = A(J,M1) 850 CONTINUE C D(1) = A(1,MB) E(1) = 0.0E0 E2(1) = 0.0E0 GO TO 1001 C 900 DO 950 J = 1, N D(J) = A(J,MB) E(J) = 0.0E0 E2(J) = 0.0E0 950 CONTINUE C 1001 RETURN END SUBROUTINE BANDV(NM,N,MBW,A,E21,M,W,Z,IERR,NV,RV,RV6) C INTEGER I,J,K,M,N,R,II,IJ,JJ,KJ,MB,M1,NM,NV,IJ1,ITS,KJ1,MBW,M21, X IERR,MAXJ,MAXK,GROUP REAL A(NM,MBW),W(M),Z(NM,M),RV(NV),RV6(N) REAL U,V,UK,XU,X0,X1,E21,EPS2,EPS3,EPS4,NORM,ORDER, X EPSLON,PYTHAG C C THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A REAL SYMMETRIC C BAND MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES, USING INVERSE C ITERATION. THE SUBROUTINE MAY ALSO BE USED TO SOLVE SYSTEMS C OF LINEAR EQUATIONS WITH A SYMMETRIC OR NON-SYMMETRIC BAND C COEFFICIENT MATRIX. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C MBW IS THE NUMBER OF COLUMNS OF THE ARRAY A USED TO STORE THE C BAND MATRIX. IF THE MATRIX IS SYMMETRIC, MBW IS ITS (HALF) C BAND WIDTH, DENOTED MB AND DEFINED AS THE NUMBER OF ADJACENT C DIAGONALS, INCLUDING THE PRINCIPAL DIAGONAL, REQUIRED TO C SPECIFY THE NON-ZERO PORTION OF THE LOWER TRIANGLE OF THE C MATRIX. IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS C OF LINEAR EQUATIONS AND THE COEFFICIENT MATRIX IS NOT C SYMMETRIC, IT MUST HOWEVER HAVE THE SAME NUMBER OF ADJACENT C DIAGONALS ABOVE THE MAIN DIAGONAL AS BELOW, AND IN THIS C CASE, MBW=2*MB-1. C C A CONTAINS THE LOWER TRIANGLE OF THE SYMMETRIC BAND INPUT C MATRIX STORED AS AN N BY MB ARRAY. ITS LOWEST SUBDIAGONAL C IS STORED IN THE LAST N+1-MB POSITIONS OF THE FIRST COLUMN, C ITS NEXT SUBDIAGONAL IN THE LAST N+2-MB POSITIONS OF THE C SECOND COLUMN, FURTHER SUBDIAGONALS SIMILARLY, AND FINALLY C ITS PRINCIPAL DIAGONAL IN THE N POSITIONS OF COLUMN MB. C IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS OF LINEAR C EQUATIONS AND THE COEFFICIENT MATRIX IS NOT SYMMETRIC, A IS C N BY 2*MB-1 INSTEAD WITH LOWER TRIANGLE AS ABOVE AND WITH C ITS FIRST SUPERDIAGONAL STORED IN THE FIRST N-1 POSITIONS OF C COLUMN MB+1, ITS SECOND SUPERDIAGONAL IN THE FIRST N-2 C POSITIONS OF COLUMN MB+2, FURTHER SUPERDIAGONALS SIMILARLY, C AND FINALLY ITS HIGHEST SUPERDIAGONAL IN THE FIRST N+1-MB C POSITIONS OF THE LAST COLUMN. C CONTENTS OF STORAGES NOT PART OF THE MATRIX ARE ARBITRARY. C C E21 SPECIFIES THE ORDERING OF THE EIGENVALUES AND CONTAINS C 0.0E0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, OR C 2.0E0 IF THE EIGENVALUES ARE IN DESCENDING ORDER. C IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS OF LINEAR C EQUATIONS, E21 SHOULD BE SET TO 1.0E0 IF THE COEFFICIENT C MATRIX IS SYMMETRIC AND TO -1.0E0 IF NOT. C C M IS THE NUMBER OF SPECIFIED EIGENVALUES OR THE NUMBER OF C SYSTEMS OF LINEAR EQUATIONS. C C W CONTAINS THE M EIGENVALUES IN ASCENDING OR DESCENDING ORDER. C IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS OF LINEAR C EQUATIONS (A-W(R)*I)*X(R)=B(R), WHERE I IS THE IDENTITY C MATRIX, W(R) SHOULD BE SET ACCORDINGLY, FOR R=1,2,...,M. C C Z CONTAINS THE CONSTANT MATRIX COLUMNS (B(R),R=1,2,...,M), IF C THE SUBROUTINE IS USED TO SOLVE SYSTEMS OF LINEAR EQUATIONS. C C NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER RV C AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT. C C ON OUTPUT C C A AND W ARE UNALTERED. C C Z CONTAINS THE ASSOCIATED SET OF ORTHOGONAL EIGENVECTORS. C ANY VECTOR WHICH FAILS TO CONVERGE IS SET TO ZERO. IF THE C SUBROUTINE IS USED TO SOLVE SYSTEMS OF LINEAR EQUATIONS, C Z CONTAINS THE SOLUTION MATRIX COLUMNS (X(R),R=1,2,...,M). C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C -R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH C EIGENVALUE FAILS TO CONVERGE, OR IF THE R-TH C SYSTEM OF LINEAR EQUATIONS IS NEARLY SINGULAR. C C RV AND RV6 ARE TEMPORARY STORAGE ARRAYS. NOTE THAT RV IS C OF DIMENSION AT LEAST N*(2*MB-1). IF THE SUBROUTINE C IS BEING USED TO SOLVE SYSTEMS OF LINEAR EQUATIONS, THE C DETERMINANT (UP TO SIGN) OF A-W(M)*I IS AVAILABLE, UPON C RETURN, AS THE PRODUCT OF THE FIRST N ELEMENTS OF RV. C C CALLS PYTHAG FOR SQRT(A*A + B*B) . C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C IERR = 0 IF (M .EQ. 0) GO TO 1001 MB = MBW IF (E21 .LT. 0.0E0) MB = (MBW + 1) / 2 M1 = MB - 1 M21 = M1 + MB ORDER = 1.0E0 - ABS(E21) C .......... FIND VECTORS BY INVERSE ITERATION .......... DO 920 R = 1, M ITS = 1 X1 = W(R) IF (R .NE. 1) GO TO 100 C .......... COMPUTE NORM OF MATRIX .......... NORM = 0.0E0 C DO 60 J = 1, MB JJ = MB + 1 - J KJ = JJ + M1 IJ = 1 V = 0.0E0 C DO 40 I = JJ, N V = V + ABS(A(I,J)) IF (E21 .GE. 0.0E0) GO TO 40 V = V + ABS(A(IJ,KJ)) IJ = IJ + 1 40 CONTINUE C NORM = AMAX1(NORM,V) 60 CONTINUE C IF (E21 .LT. 0.0E0) NORM = 0.5E0 * NORM C .......... EPS2 IS THE CRITERION FOR GROUPING, C EPS3 REPLACES ZERO PIVOTS AND EQUAL C ROOTS ARE MODIFIED BY EPS3, C EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW .......... IF (NORM .EQ. 0.0E0) NORM = 1.0E0 EPS2 = 1.0E-3 * NORM * ABS(ORDER) EPS3 = EPSLON(NORM) UK = N UK = SQRT(UK) EPS4 = UK * EPS3 80 GROUP = 0 GO TO 120 C .......... LOOK FOR CLOSE OR COINCIDENT ROOTS .......... 100 IF (ABS(X1-X0) .GE. EPS2) GO TO 80 GROUP = GROUP + 1 IF (ORDER * (X1 - X0) .LE. 0.0E0) X1 = X0 + ORDER * EPS3 C .......... EXPAND MATRIX, SUBTRACT EIGENVALUE, C AND INITIALIZE VECTOR .......... 120 DO 200 I = 1, N IJ = I + MIN0(0,I-M1) * N KJ = IJ + MB * N IJ1 = KJ + M1 * N IF (M1 .EQ. 0) GO TO 180 C DO 150 J = 1, M1 IF (IJ .GT. M1) GO TO 125 IF (IJ .GT. 0) GO TO 130 RV(IJ1) = 0.0E0 IJ1 = IJ1 + N GO TO 130 125 RV(IJ) = A(I,J) 130 IJ = IJ + N II = I + J IF (II .GT. N) GO TO 150 JJ = MB - J IF (E21 .GE. 0.0E0) GO TO 140 II = I JJ = MB + J 140 RV(KJ) = A(II,JJ) KJ = KJ + N 150 CONTINUE C 180 RV(IJ) = A(I,MB) - X1 RV6(I) = EPS4 IF (ORDER .EQ. 0.0E0) RV6(I) = Z(I,R) 200 CONTINUE C IF (M1 .EQ. 0) GO TO 600 C .......... ELIMINATION WITH INTERCHANGES .......... DO 580 I = 1, N II = I + 1 MAXK = MIN0(I+M1-1,N) MAXJ = MIN0(N-I,M21-2) * N C DO 360 K = I, MAXK KJ1 = K J = KJ1 + N JJ = J + MAXJ C DO 340 KJ = J, JJ, N RV(KJ1) = RV(KJ) KJ1 = KJ 340 CONTINUE C RV(KJ1) = 0.0E0 360 CONTINUE C IF (I .EQ. N) GO TO 580 U = 0.0E0 MAXK = MIN0(I+M1,N) MAXJ = MIN0(N-II,M21-2) * N C DO 450 J = I, MAXK IF (ABS(RV(J)) .LT. ABS(U)) GO TO 450 U = RV(J) K = J 450 CONTINUE C J = I + N JJ = J + MAXJ IF (K .EQ. I) GO TO 520 KJ = K C DO 500 IJ = I, JJ, N V = RV(IJ) RV(IJ) = RV(KJ) RV(KJ) = V KJ = KJ + N 500 CONTINUE C IF (ORDER .NE. 0.0E0) GO TO 520 V = RV6(I) RV6(I) = RV6(K) RV6(K) = V 520 IF (U .EQ. 0.0E0) GO TO 580 C DO 560 K = II, MAXK V = RV(K) / U KJ = K C DO 540 IJ = J, JJ, N KJ = KJ + N RV(KJ) = RV(KJ) - V * RV(IJ) 540 CONTINUE C IF (ORDER .EQ. 0.0E0) RV6(K) = RV6(K) - V * RV6(I) 560 CONTINUE C 580 CONTINUE C .......... BACK SUBSTITUTION C FOR I=N STEP -1 UNTIL 1 DO -- .......... 600 DO 630 II = 1, N I = N + 1 - II MAXJ = MIN0(II,M21) IF (MAXJ .EQ. 1) GO TO 620 IJ1 = I J = IJ1 + N JJ = J + (MAXJ - 2) * N C DO 610 IJ = J, JJ, N IJ1 = IJ1 + 1 RV6(I) = RV6(I) - RV(IJ) * RV6(IJ1) 610 CONTINUE C 620 V = RV(I) IF (ABS(V) .GE. EPS3) GO TO 625 C .......... SET ERROR -- NEARLY SINGULAR LINEAR SYSTEM .......... IF (ORDER .EQ. 0.0E0) IERR = -R V = SIGN(EPS3,V) 625 RV6(I) = RV6(I) / V 630 CONTINUE C XU = 1.0E0 IF (ORDER .EQ. 0.0E0) GO TO 870 C .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS C MEMBERS OF GROUP .......... IF (GROUP .EQ. 0) GO TO 700 C DO 680 JJ = 1, GROUP J = R - GROUP - 1 + JJ XU = 0.0E0 C DO 640 I = 1, N 640 XU = XU + RV6(I) * Z(I,J) C DO 660 I = 1, N 660 RV6(I) = RV6(I) - XU * Z(I,J) C 680 CONTINUE C 700 NORM = 0.0E0 C DO 720 I = 1, N 720 NORM = NORM + ABS(RV6(I)) C IF (NORM .GE. 0.1E0) GO TO 840 C .......... IN-LINE PROCEDURE FOR CHOOSING C A NEW STARTING VECTOR .......... IF (ITS .GE. N) GO TO 830 ITS = ITS + 1 XU = EPS4 / (UK + 1.0E0) RV6(1) = EPS4 C DO 760 I = 2, N 760 RV6(I) = XU C RV6(ITS) = RV6(ITS) - EPS4 * UK GO TO 600 C .......... SET ERROR -- NON-CONVERGED EIGENVECTOR .......... 830 IERR = -R XU = 0.0E0 GO TO 870 C .......... NORMALIZE SO THAT SUM OF SQUARES IS C 1 AND EXPAND TO FULL ORDER .......... 840 U = 0.0E0 C DO 860 I = 1, N 860 U = PYTHAG(U,RV6(I)) C XU = 1.0E0 / U C 870 DO 900 I = 1, N 900 Z(I,R) = RV6(I) * XU C X0 = X1 920 CONTINUE C 1001 RETURN END SUBROUTINE BISECT(N,EPS1,D,E,E2,LB,UB,MM,M,W,IND,IERR,RV4,RV5) C INTEGER I,J,K,L,M,N,P,Q,R,S,II,MM,M1,M2,TAG,IERR,ISTURM REAL D(N),E(N),E2(N),W(MM),RV4(N),RV5(N) REAL U,V,LB,T1,T2,UB,XU,X0,X1,EPS1,TST1,TST2,EPSLON INTEGER IND(MM) C C THIS SUBROUTINE IS A TRANSLATION OF THE BISECTION TECHNIQUE C IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). C C THIS SUBROUTINE FINDS THOSE EIGENVALUES OF A TRIDIAGONAL C SYMMETRIC MATRIX WHICH LIE IN A SPECIFIED INTERVAL, C USING BISECTION. C C ON INPUT C C N IS THE ORDER OF THE MATRIX. C C EPS1 IS AN ABSOLUTE ERROR TOLERANCE FOR THE COMPUTED C EIGENVALUES. IF THE INPUT EPS1 IS NON-POSITIVE, C IT IS RESET FOR EACH SUBMATRIX TO A DEFAULT VALUE, C NAMELY, MINUS THE PRODUCT OF THE RELATIVE MACHINE C PRECISION AND THE 1-NORM OF THE SUBMATRIX. C C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. C C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. C C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. C E2(1) IS ARBITRARY. C C LB AND UB DEFINE THE INTERVAL TO BE SEARCHED FOR EIGENVALUES. C IF LB IS NOT LESS THAN UB, NO EIGENVALUES WILL BE FOUND. C C MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF C EIGENVALUES IN THE INTERVAL. WARNING. IF MORE THAN C MM EIGENVALUES ARE DETERMINED TO LIE IN THE INTERVAL, C AN ERROR RETURN IS MADE WITH NO EIGENVALUES FOUND. C C ON OUTPUT C C EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS C (LAST) DEFAULT VALUE. C C D AND E ARE UNALTERED. C C ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED C AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE C MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES. C E2(1) IS ALSO SET TO ZERO. C C M IS THE NUMBER OF EIGENVALUES DETERMINED TO LIE IN (LB,UB). C C W CONTAINS THE M EIGENVALUES IN ASCENDING ORDER. C C IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES C ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W -- C 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM C THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC.. C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C 3*N+1 IF M EXCEEDS MM. C C RV4 AND RV5 ARE TEMPORARY STORAGE ARRAYS. C C THE ALGOL PROCEDURE STURMCNT CONTAINED IN TRISTURM C APPEARS IN BISECT IN-LINE. C C NOTE THAT SUBROUTINE TQL1 OR IMTQL1 IS GENERALLY FASTER THAN C BISECT, IF MORE THAN N/4 EIGENVALUES ARE TO BE FOUND. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C IERR = 0 TAG = 0 T1 = LB T2 = UB C .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES .......... DO 40 I = 1, N IF (I .EQ. 1) GO TO 20 TST1 = ABS(D(I)) + ABS(D(I-1)) TST2 = TST1 + ABS(E(I)) IF (TST2 .GT. TST1) GO TO 40 20 E2(I) = 0.0E0 40 CONTINUE C .......... DETERMINE THE NUMBER OF EIGENVALUES C IN THE INTERVAL .......... P = 1 Q = N X1 = UB ISTURM = 1 GO TO 320 60 M = S X1 = LB ISTURM = 2 GO TO 320 80 M = M - S IF (M .GT. MM) GO TO 980 Q = 0 R = 0 C .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING C INTERVAL BY THE GERSCHGORIN BOUNDS .......... 100 IF (R .EQ. M) GO TO 1001 TAG = TAG + 1 P = Q + 1 XU = D(P) X0 = D(P) U = 0.0E0 C DO 120 Q = P, N X1 = U U = 0.0E0 V = 0.0E0 IF (Q .EQ. N) GO TO 110 U = ABS(E(Q+1)) V = E2(Q+1) 110 XU = AMIN1(D(Q)-(X1+U),XU) X0 = AMAX1(D(Q)+(X1+U),X0) IF (V .EQ. 0.0E0) GO TO 140 120 CONTINUE C 140 X1 = EPSLON(AMAX1(ABS(XU),ABS(X0))) IF (EPS1 .LE. 0.0E0) EPS1 = -X1 IF (P .NE. Q) GO TO 180 C .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL .......... IF (T1 .GT. D(P) .OR. D(P) .GE. T2) GO TO 940 M1 = P M2 = P RV5(P) = D(P) GO TO 900 180 X1 = X1 * (Q - P + 1) LB = AMAX1(T1,XU-X1) UB = AMIN1(T2,X0+X1) X1 = LB ISTURM = 3 GO TO 320 200 M1 = S + 1 X1 = UB ISTURM = 4 GO TO 320 220 M2 = S IF (M1 .GT. M2) GO TO 940 C .......... FIND ROOTS BY BISECTION .......... X0 = UB ISTURM = 5 C DO 240 I = M1, M2 RV5(I) = UB RV4(I) = LB 240 CONTINUE C .......... LOOP FOR K-TH EIGENVALUE C FOR K=M2 STEP -1 UNTIL M1 DO -- C (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) .......... K = M2 250 XU = LB C .......... FOR I=K STEP -1 UNTIL M1 DO -- .......... DO 260 II = M1, K I = M1 + K - II IF (XU .GE. RV4(I)) GO TO 260 XU = RV4(I) GO TO 280 260 CONTINUE C 280 IF (X0 .GT. RV5(K)) X0 = RV5(K) C .......... NEXT BISECTION STEP .......... 300 X1 = (XU + X0) * 0.5E0 IF ((X0 - XU) .LE. ABS(EPS1)) GO TO 420 TST1 = 2.0E0 * (ABS(XU) + ABS(X0)) TST2 = TST1 + (X0 - XU) IF (TST2 .EQ. TST1) GO TO 420 C .......... IN-LINE PROCEDURE FOR STURM SEQUENCE .......... 320 S = P - 1 U = 1.0E0 C DO 340 I = P, Q IF (U .NE. 0.0E0) GO TO 325 V = ABS(E(I)) / EPSLON(1.0E0) IF (E2(I) .EQ. 0.0E0) V = 0.0E0 GO TO 330 325 V = E2(I) / U 330 U = D(I) - X1 - V IF (U .LT. 0.0E0) S = S + 1 340 CONTINUE C GO TO (60,80,200,220,360), ISTURM C .......... REFINE INTERVALS .......... 360 IF (S .GE. K) GO TO 400 XU = X1 IF (S .GE. M1) GO TO 380 RV4(M1) = X1 GO TO 300 380 RV4(S+1) = X1 IF (RV5(S) .GT. X1) RV5(S) = X1 GO TO 300 400 X0 = X1 GO TO 300 C .......... K-TH EIGENVALUE FOUND .......... 420 RV5(K) = X1 K = K - 1 IF (K .GE. M1) GO TO 250 C .......... ORDER EIGENVALUES TAGGED WITH THEIR C SUBMATRIX ASSOCIATIONS .......... 900 S = R R = R + M2 - M1 + 1 J = 1 K = M1 C DO 920 L = 1, R IF (J .GT. S) GO TO 910 IF (K .GT. M2) GO TO 940 IF (RV5(K) .GE. W(L)) GO TO 915 C DO 905 II = J, S I = L + S - II W(I+1) = W(I) IND(I+1) = IND(I) 905 CONTINUE C 910 W(L) = RV5(K) IND(L) = TAG K = K + 1 GO TO 920 915 J = J + 1 920 CONTINUE C 940 IF (Q .LT. N) GO TO 100 GO TO 1001 C .......... SET ERROR -- UNDERESTIMATE OF NUMBER OF C EIGENVALUES IN INTERVAL .......... 980 IERR = 3 * N + 1 1001 LB = T1 UB = T2 RETURN END SUBROUTINE BQR(NM,N,MB,A,T,R,IERR,NV,RV) C INTEGER I,J,K,L,M,N,II,IK,JK,JM,KJ,KK,KM,LL,MB,MK,MN,MZ, X M1,M2,M3,M4,NI,NM,NV,ITS,KJ1,M21,M31,IERR,IMULT REAL A(NM,MB),RV(NV) REAL F,G,Q,R,S,T,TST1,TST2,SCALE,PYTHAG C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BQR, C NUM. MATH. 16, 85-92(1970) BY MARTIN, REINSCH, AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 266-272(1971). C C THIS SUBROUTINE FINDS THE EIGENVALUE OF SMALLEST (USUALLY) C MAGNITUDE OF A REAL SYMMETRIC BAND MATRIX USING THE C QR ALGORITHM WITH SHIFTS OF ORIGIN. CONSECUTIVE CALLS C CAN BE MADE TO FIND FURTHER EIGENVALUES. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C MB IS THE (HALF) BAND WIDTH OF THE MATRIX, DEFINED AS THE C NUMBER OF ADJACENT DIAGONALS, INCLUDING THE PRINCIPAL C DIAGONAL, REQUIRED TO SPECIFY THE NON-ZERO PORTION OF THE C LOWER TRIANGLE OF THE MATRIX. C C A CONTAINS THE LOWER TRIANGLE OF THE SYMMETRIC BAND INPUT C MATRIX STORED AS AN N BY MB ARRAY. ITS LOWEST SUBDIAGONAL C IS STORED IN THE LAST N+1-MB POSITIONS OF THE FIRST COLUMN, C ITS NEXT SUBDIAGONAL IN THE LAST N+2-MB POSITIONS OF THE C SECOND COLUMN, FURTHER SUBDIAGONALS SIMILARLY, AND FINALLY C ITS PRINCIPAL DIAGONAL IN THE N POSITIONS OF THE LAST COLUMN. C CONTENTS OF STORAGES NOT PART OF THE MATRIX ARE ARBITRARY. C ON A SUBSEQUENT CALL, ITS OUTPUT CONTENTS FROM THE PREVIOUS C CALL SHOULD BE PASSED. C C T SPECIFIES THE SHIFT (OF EIGENVALUES) APPLIED TO THE DIAGONAL C OF A IN FORMING THE INPUT MATRIX. WHAT IS ACTUALLY DETERMINED C IS THE EIGENVALUE OF A+TI (I IS THE IDENTITY MATRIX) NEAREST C TO T. ON A SUBSEQUENT CALL, THE OUTPUT VALUE OF T FROM THE C PREVIOUS CALL SHOULD BE PASSED IF THE NEXT NEAREST EIGENVALUE C IS SOUGHT. C C R SHOULD BE SPECIFIED AS ZERO ON THE FIRST CALL, AND AS ITS C OUTPUT VALUE FROM THE PREVIOUS CALL ON A SUBSEQUENT CALL. C IT IS USED TO DETERMINE WHEN THE LAST ROW AND COLUMN OF C THE TRANSFORMED BAND MATRIX CAN BE REGARDED AS NEGLIGIBLE. C C NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER RV C AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT. C C ON OUTPUT C C A CONTAINS THE TRANSFORMED BAND MATRIX. THE MATRIX A+TI C DERIVED FROM THE OUTPUT PARAMETERS IS SIMILAR TO THE C INPUT A+TI TO WITHIN ROUNDING ERRORS. ITS LAST ROW AND C COLUMN ARE NULL (IF IERR IS ZERO). C C T CONTAINS THE COMPUTED EIGENVALUE OF A+TI (IF IERR IS ZERO). C C R CONTAINS THE MAXIMUM OF ITS INPUT VALUE AND THE NORM OF THE C LAST COLUMN OF THE INPUT MATRIX A. C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C N IF THE EIGENVALUE HAS NOT BEEN C DETERMINED AFTER 30 ITERATIONS. C C RV IS A TEMPORARY STORAGE ARRAY OF DIMENSION AT LEAST C (2*MB**2+4*MB-3). THE FIRST (3*MB-2) LOCATIONS CORRESPOND C TO THE ALGOL ARRAY B, THE NEXT (2*MB-1) LOCATIONS CORRESPOND C TO THE ALGOL ARRAY H, AND THE FINAL (2*MB**2-MB) LOCATIONS C CORRESPOND TO THE MB BY (2*MB-1) ALGOL ARRAY U. C C NOTE. FOR A SUBSEQUENT CALL, N SHOULD BE REPLACED BY N-1, BUT C MB SHOULD NOT BE ALTERED EVEN WHEN IT EXCEEDS THE CURRENT N. C C CALLS PYTHAG FOR SQRT(A*A + B*B) . C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C IERR = 0 M1 = MIN0(MB,N) M = M1 - 1 M2 = M + M M21 = M2 + 1 M3 = M21 + M M31 = M3 + 1 M4 = M31 + M2 MN = M + N MZ = MB - M1 ITS = 0 C .......... TEST FOR CONVERGENCE .......... 40 G = A(N,MB) IF (M .EQ. 0) GO TO 360 F = 0.0E0 C DO 50 K = 1, M MK = K + MZ F = F + ABS(A(N,MK)) 50 CONTINUE C IF (ITS .EQ. 0 .AND. F .GT. R) R = F TST1 = R TST2 = TST1 + F IF (TST2 .LE. TST1) GO TO 360 IF (ITS .EQ. 30) GO TO 1000 ITS = ITS + 1 C .......... FORM SHIFT FROM BOTTOM 2 BY 2 MINOR .......... IF (F .GT. 0.25E0 * R .AND. ITS .LT. 5) GO TO 90 F = A(N,MB-1) IF (F .EQ. 0.0E0) GO TO 70 Q = (A(N-1,MB) - G) / (2.0E0 * F) S = PYTHAG(Q,1.0E0) G = G - F / (Q + SIGN(S,Q)) 70 T = T + G C DO 80 I = 1, N 80 A(I,MB) = A(I,MB) - G C 90 DO 100 K = M31, M4 100 RV(K) = 0.0E0 C DO 350 II = 1, MN I = II - M NI = N - II IF (NI .LT. 0) GO TO 230 C .......... FORM COLUMN OF SHIFTED MATRIX A-G*I .......... L = MAX0(1,2-I) C DO 110 K = 1, M3 110 RV(K) = 0.0E0 C DO 120 K = L, M1 KM = K + M MK = K + MZ RV(KM) = A(II,MK) 120 CONTINUE C LL = MIN0(M,NI) IF (LL .EQ. 0) GO TO 135 C DO 130 K = 1, LL KM = K + M21 IK = II + K MK = MB - K RV(KM) = A(IK,MK) 130 CONTINUE C .......... PRE-MULTIPLY WITH HOUSEHOLDER REFLECTIONS .......... 135 LL = M2 IMULT = 0 C .......... MULTIPLICATION PROCEDURE .......... 140 KJ = M4 - M1 C DO 170 J = 1, LL KJ = KJ + M1 JM = J + M3 IF (RV(JM) .EQ. 0.0E0) GO TO 170 F = 0.0E0 C DO 150 K = 1, M1 KJ = KJ + 1 JK = J + K - 1 F = F + RV(KJ) * RV(JK) 150 CONTINUE C F = F / RV(JM) KJ = KJ - M1 C DO 160 K = 1, M1 KJ = KJ + 1 JK = J + K - 1 RV(JK) = RV(JK) - RV(KJ) * F 160 CONTINUE C KJ = KJ - M1 170 CONTINUE C IF (IMULT .NE. 0) GO TO 280 C .......... HOUSEHOLDER REFLECTION .......... F = RV(M21) S = 0.0E0 RV(M4) = 0.0E0 SCALE = 0.0E0 C DO 180 K = M21, M3 180 SCALE = SCALE + ABS(RV(K)) C IF (SCALE .EQ. 0.0E0) GO TO 210 C DO 190 K = M21, M3 190 S = S + (RV(K)/SCALE)**2 C S = SCALE * SCALE * S G = -SIGN(SQRT(S),F) RV(M21) = G RV(M4) = S - F * G KJ = M4 + M2 * M1 + 1 RV(KJ) = F - G C DO 200 K = 2, M1 KJ = KJ + 1 KM = K + M2 RV(KJ) = RV(KM) 200 CONTINUE C .......... SAVE COLUMN OF TRIANGULAR FACTOR R .......... 210 DO 220 K = L, M1 KM = K + M MK = K + MZ A(II,MK) = RV(KM) 220 CONTINUE C 230 L = MAX0(1,M1+1-I) IF (I .LE. 0) GO TO 300 C .......... PERFORM ADDITIONAL STEPS .......... DO 240 K = 1, M21 240 RV(K) = 0.0E0 C LL = MIN0(M1,NI+M1) C .......... GET ROW OF TRIANGULAR FACTOR R .......... DO 250 KK = 1, LL K = KK - 1 KM = K + M1 IK = I + K MK = MB - K RV(KM) = A(IK,MK) 250 CONTINUE C .......... POST-MULTIPLY WITH HOUSEHOLDER REFLECTIONS .......... LL = M1 IMULT = 1 GO TO 140 C .......... STORE COLUMN OF NEW A MATRIX .......... 280 DO 290 K = L, M1 MK = K + MZ A(I,MK) = RV(K) 290 CONTINUE C .......... UPDATE HOUSEHOLDER REFLECTIONS .......... 300 IF (L .GT. 1) L = L - 1 KJ1 = M4 + L * M1 C DO 320 J = L, M2 JM = J + M3 RV(JM) = RV(JM+1) C DO 320 K = 1, M1 KJ1 = KJ1 + 1 KJ = KJ1 - M1 RV(KJ) = RV(KJ1) 320 CONTINUE C 350 CONTINUE C GO TO 40 C .......... CONVERGENCE .......... 360 T = T + G C DO 380 I = 1, N 380 A(I,MB) = A(I,MB) - G C DO 400 K = 1, M1 MK = K + MZ A(N,MK) = 0.0E0 400 CONTINUE C GO TO 1001 C .......... SET ERROR -- NO CONVERGENCE TO C EIGENVALUE AFTER 30 ITERATIONS .......... 1000 IERR = N 1001 RETURN END SUBROUTINE CBABK2(NM,N,LOW,IGH,SCALE,M,ZR,ZI) C INTEGER I,J,K,M,N,II,NM,IGH,LOW REAL SCALE(N),ZR(NM,M),ZI(NM,M) REAL S C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK, C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). C C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING C BALANCED MATRIX DETERMINED BY CBAL. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL. C C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS C AND SCALING FACTORS USED BY CBAL. C C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. C C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVECTORS TO BE C BACK TRANSFORMED IN THEIR FIRST M COLUMNS. C C ON OUTPUT C C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS C IN THEIR FIRST M COLUMNS. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C IF (M .EQ. 0) GO TO 200 IF (IGH .EQ. LOW) GO TO 120 C DO 110 I = LOW, IGH S = SCALE(I) C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED C IF THE FOREGOING STATEMENT IS REPLACED BY C S=1.0E0/SCALE(I). .......... DO 100 J = 1, M ZR(I,J) = ZR(I,J) * S ZI(I,J) = ZI(I,J) * S 100 CONTINUE C 110 CONTINUE C .......... FOR I=LOW-1 STEP -1 UNTIL 1, C IGH+1 STEP 1 UNTIL N DO -- .......... 120 DO 140 II = 1, N I = II IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140 IF (I .LT. LOW) I = LOW - II K = SCALE(I) IF (K .EQ. I) GO TO 140 C DO 130 J = 1, M S = ZR(I,J) ZR(I,J) = ZR(K,J) ZR(K,J) = S S = ZI(I,J) ZI(I,J) = ZI(K,J) ZI(K,J) = S 130 CONTINUE C 140 CONTINUE C 200 RETURN END SUBROUTINE CBAL(NM,N,AR,AI,LOW,IGH,SCALE) C INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC REAL AR(NM,N),AI(NM,N),SCALE(N) REAL C,F,G,R,S,B2,RADIX LOGICAL NOCONV C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE, C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). C C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES C EIGENVALUES WHENEVER POSSIBLE. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED. C C ON OUTPUT C C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE BALANCED MATRIX. C C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J) C ARE EQUAL TO ZERO IF C (1) I IS GREATER THAN J AND C (2) J=1,...,LOW-1 OR I=IGH+1,...,N. C C SCALE CONTAINS INFORMATION DETERMINING THE C PERMUTATIONS AND SCALING FACTORS USED. C C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN C SCALE(J) = P(J), FOR J = 1,...,LOW-1 C = D(J,J) J = LOW,...,IGH C = P(J) J = IGH+1,...,N. C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1, C THEN 1 TO LOW-1. C C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY. C C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS C K,L HAVE BEEN REVERSED.) C C ARITHMETIC IS REAL THROUGHOUT. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C RADIX = 16.0E0 C B2 = RADIX * RADIX K = 1 L = N GO TO 100 C .......... IN-LINE PROCEDURE FOR ROW AND C COLUMN EXCHANGE .......... 20 SCALE(M) = J IF (J .EQ. M) GO TO 50 C DO 30 I = 1, L F = AR(I,J) AR(I,J) = AR(I,M) AR(I,M) = F F = AI(I,J) AI(I,J) = AI(I,M) AI(I,M) = F 30 CONTINUE C DO 40 I = K, N F = AR(J,I) AR(J,I) = AR(M,I) AR(M,I) = F F = AI(J,I) AI(J,I) = AI(M,I) AI(M,I) = F 40 CONTINUE C 50 GO TO (80,130), IEXC C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE C AND PUSH THEM DOWN .......... 80 IF (L .EQ. 1) GO TO 280 L = L - 1 C .......... FOR J=L STEP -1 UNTIL 1 DO -- .......... 100 DO 120 JJ = 1, L J = L + 1 - JJ C DO 110 I = 1, L IF (I .EQ. J) GO TO 110 IF (AR(J,I) .NE. 0.0E0 .OR. AI(J,I) .NE. 0.0E0) GO TO 120 110 CONTINUE C M = L IEXC = 1 GO TO 20 120 CONTINUE C GO TO 140 C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE C AND PUSH THEM LEFT .......... 130 K = K + 1 C 140 DO 170 J = K, L C DO 150 I = K, L IF (I .EQ. J) GO TO 150 IF (AR(I,J) .NE. 0.0E0 .OR. AI(I,J) .NE. 0.0E0) GO TO 170 150 CONTINUE C M = K IEXC = 2 GO TO 20 170 CONTINUE C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L .......... DO 180 I = K, L 180 SCALE(I) = 1.0E0 C .......... ITERATIVE LOOP FOR NORM REDUCTION .......... 190 NOCONV = .FALSE. C DO 270 I = K, L C = 0.0E0 R = 0.0E0 C DO 200 J = K, L IF (J .EQ. I) GO TO 200 C = C + ABS(AR(J,I)) + ABS(AI(J,I)) R = R + ABS(AR(I,J)) + ABS(AI(I,J)) 200 CONTINUE C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW .......... IF (C .EQ. 0.0E0 .OR. R .EQ. 0.0E0) GO TO 270 G = R / RADIX F = 1.0E0 S = C + R 210 IF (C .GE. G) GO TO 220 F = F * RADIX C = C * B2 GO TO 210 220 G = R * RADIX 230 IF (C .LT. G) GO TO 240 F = F / RADIX C = C / B2 GO TO 230 C .......... NOW BALANCE .......... 240 IF ((C + R) / F .GE. 0.95E0 * S) GO TO 270 G = 1.0E0 / F SCALE(I) = SCALE(I) * F NOCONV = .TRUE. C DO 250 J = K, N AR(I,J) = AR(I,J) * G AI(I,J) = AI(I,J) * G 250 CONTINUE C DO 260 J = 1, L AR(J,I) = AR(J,I) * F AI(J,I) = AI(J,I) * F 260 CONTINUE C 270 CONTINUE C IF (NOCONV) GO TO 190 C 280 LOW = K IGH = L RETURN END SUBROUTINE CG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR) C INTEGER N,NM,IS1,IS2,IERR,MATZ REAL AR(NM,N),AI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N), X FV1(N),FV2(N),FV3(N) C C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) C OF A COMPLEX GENERAL MATRIX. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX A=(AR,AI). C C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX. C C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. C C ON OUTPUT C C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVALUES. C C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO. C C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO. C C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C IF (N .LE. NM) GO TO 10 IERR = 10 * N GO TO 50 C 10 CALL CBAL(NM,N,AR,AI,IS1,IS2,FV1) CALL CORTH(NM,N,IS1,IS2,AR,AI,FV2,FV3) IF (MATZ .NE. 0) GO TO 20 C .......... FIND EIGENVALUES ONLY .......... CALL COMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR) GO TO 50 C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 20 CALL COMQR2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR) IF (IERR .NE. 0) GO TO 50 CALL CBABK2(NM,N,IS1,IS2,FV1,N,ZR,ZI) 50 RETURN END SUBROUTINE CH(NM,N,AR,AI,W,MATZ,ZR,ZI,FV1,FV2,FM1,IERR) C INTEGER I,J,N,NM,IERR,MATZ REAL AR(NM,N),AI(NM,N),W(N),ZR(NM,N),ZI(NM,N), X FV1(N),FV2(N),FM1(2,N) C C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) C OF A COMPLEX HERMITIAN MATRIX. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX A=(AR,AI). C C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE COMPLEX HERMITIAN MATRIX. C C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. C C ON OUTPUT C C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. C C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO. C C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT C AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. C C FV1, FV2, AND FM1 ARE TEMPORARY STORAGE ARRAYS. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C IF (N .LE. NM) GO TO 10 IERR = 10 * N GO TO 50 C 10 CALL HTRIDI(NM,N,AR,AI,W,FV1,FV2,FM1) IF (MATZ .NE. 0) GO TO 20 C .......... FIND EIGENVALUES ONLY .......... CALL TQLRAT(N,W,FV2,IERR) GO TO 50 C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 20 DO 40 I = 1, N C DO 30 J = 1, N ZR(J,I) = 0.0E0 30 CONTINUE C ZR(I,I) = 1.0E0 40 CONTINUE C CALL TQL2(NM,N,W,FV1,ZR,IERR) IF (IERR .NE. 0) GO TO 50 CALL HTRIBK(NM,N,AR,AI,FM1,N,ZR,ZI) 50 RETURN END SUBROUTINE CINVIT(NM,N,AR,AI,WR,WI,SELECT,MM,M,ZR,ZI, X IERR,RM1,RM2,RV1,RV2) C INTEGER I,J,K,M,N,S,II,MM,MP,NM,UK,IP1,ITS,KM1,IERR REAL AR(NM,N),AI(NM,N),WR(N),WI(N),ZR(NM,MM), X ZI(NM,MM),RM1(N,N),RM2(N,N),RV1(N),RV2(N) REAL X,Y,EPS3,NORM,NORMV,EPSLON,GROWTO,ILAMBD,PYTHAG, X RLAMBD,UKROOT LOGICAL SELECT(N) C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE CX INVIT C BY PETERS AND WILKINSON. C HANDBOOK FOR AUTO. COMP. VOL.II-LINEAR ALGEBRA, 418-439(1971). C C THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A COMPLEX UPPER C HESSENBERG MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES, C USING INVERSE ITERATION. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE HESSENBERG MATRIX. C C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, RESPECTIVELY, C OF THE EIGENVALUES OF THE MATRIX. THE EIGENVALUES MUST BE C STORED IN A MANNER IDENTICAL TO THAT OF SUBROUTINE COMLR, C WHICH RECOGNIZES POSSIBLE SPLITTING OF THE MATRIX. C C SELECT SPECIFIES THE EIGENVECTORS TO BE FOUND. THE C EIGENVECTOR CORRESPONDING TO THE J-TH EIGENVALUE IS C SPECIFIED BY SETTING SELECT(J) TO .TRUE.. C C MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF C EIGENVECTORS TO BE FOUND. C C ON OUTPUT C C AR, AI, WI, AND SELECT ARE UNALTERED. C C WR MAY HAVE BEEN ALTERED SINCE CLOSE EIGENVALUES ARE PERTURBED C SLIGHTLY IN SEARCHING FOR INDEPENDENT EIGENVECTORS. C C M IS THE NUMBER OF EIGENVECTORS ACTUALLY FOUND. C C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, RESPECTIVELY, C OF THE EIGENVECTORS. THE EIGENVECTORS ARE NORMALIZED C SO THAT THE COMPONENT OF LARGEST MAGNITUDE IS 1. C ANY VECTOR WHICH FAILS THE ACCEPTANCE TEST IS SET TO ZERO. C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C -(2*N+1) IF MORE THAN MM EIGENVECTORS HAVE BEEN SPECIFIED, C -K IF THE ITERATION CORRESPONDING TO THE K-TH C VALUE FAILS, C -(N+K) IF BOTH ERROR SITUATIONS OCCUR. C C RM1, RM2, RV1, AND RV2 ARE TEMPORARY STORAGE ARRAYS. C C THE ALGOL PROCEDURE GUESSVEC APPEARS IN CINVIT IN LINE. C C CALLS CDIV FOR COMPLEX DIVISION. C CALLS PYTHAG FOR SQRT(A*A + B*B) . C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C IERR = 0 UK = 0 S = 1 C DO 980 K = 1, N IF (.NOT. SELECT(K)) GO TO 980 IF (S .GT. MM) GO TO 1000 IF (UK .GE. K) GO TO 200 C .......... CHECK FOR POSSIBLE SPLITTING .......... DO 120 UK = K, N IF (UK .EQ. N) GO TO 140 IF (AR(UK+1,UK) .EQ. 0.0E0 .AND. AI(UK+1,UK) .EQ. 0.0E0) X GO TO 140 120 CONTINUE C .......... COMPUTE INFINITY NORM OF LEADING UK BY UK C (HESSENBERG) MATRIX .......... 140 NORM = 0.0E0 MP = 1 C DO 180 I = 1, UK X = 0.0E0 C DO 160 J = MP, UK 160 X = X + PYTHAG(AR(I,J),AI(I,J)) C IF (X .GT. NORM) NORM = X MP = I 180 CONTINUE C .......... EPS3 REPLACES ZERO PIVOT IN DECOMPOSITION C AND CLOSE ROOTS ARE MODIFIED BY EPS3 .......... IF (NORM .EQ. 0.0E0) NORM = 1.0E0 EPS3 = EPSLON(NORM) C .......... GROWTO IS THE CRITERION FOR GROWTH .......... UKROOT = UK UKROOT = SQRT(UKROOT) GROWTO = 0.1E0 / UKROOT 200 RLAMBD = WR(K) ILAMBD = WI(K) IF (K .EQ. 1) GO TO 280 KM1 = K - 1 GO TO 240 C .......... PERTURB EIGENVALUE IF IT IS CLOSE C TO ANY PREVIOUS EIGENVALUE .......... 220 RLAMBD = RLAMBD + EPS3 C .......... FOR I=K-1 STEP -1 UNTIL 1 DO -- .......... 240 DO 260 II = 1, KM1 I = K - II IF (SELECT(I) .AND. ABS(WR(I)-RLAMBD) .LT. EPS3 .AND. X ABS(WI(I)-ILAMBD) .LT. EPS3) GO TO 220 260 CONTINUE C WR(K) = RLAMBD C .......... FORM UPPER HESSENBERG (AR,AI)-(RLAMBD,ILAMBD)*I C AND INITIAL COMPLEX VECTOR .......... 280 MP = 1 C DO 320 I = 1, UK C DO 300 J = MP, UK RM1(I,J) = AR(I,J) RM2(I,J) = AI(I,J) 300 CONTINUE C RM1(I,I) = RM1(I,I) - RLAMBD RM2(I,I) = RM2(I,I) - ILAMBD MP = I RV1(I) = EPS3 320 CONTINUE C .......... TRIANGULAR DECOMPOSITION WITH INTERCHANGES, C REPLACING ZERO PIVOTS BY EPS3 .......... IF (UK .EQ. 1) GO TO 420 C DO 400 I = 2, UK MP = I - 1 IF (PYTHAG(RM1(I,MP),RM2(I,MP)) .LE. X PYTHAG(RM1(MP,MP),RM2(MP,MP))) GO TO 360 C DO 340 J = MP, UK Y = RM1(I,J) RM1(I,J) = RM1(MP,J) RM1(MP,J) = Y Y = RM2(I,J) RM2(I,J) = RM2(MP,J) RM2(MP,J) = Y 340 CONTINUE C 360 IF (RM1(MP,MP) .EQ. 0.0E0 .AND. RM2(MP,MP) .EQ. 0.0E0) X RM1(MP,MP) = EPS3 CALL CDIV(RM1(I,MP),RM2(I,MP),RM1(MP,MP),RM2(MP,MP),X,Y) IF (X .EQ. 0.0E0 .AND. Y .EQ. 0.0E0) GO TO 400 C DO 380 J = I, UK RM1(I,J) = RM1(I,J) - X * RM1(MP,J) + Y * RM2(MP,J) RM2(I,J) = RM2(I,J) - X * RM2(MP,J) - Y * RM1(MP,J) 380 CONTINUE C 400 CONTINUE C 420 IF (RM1(UK,UK) .EQ. 0.0E0 .AND. RM2(UK,UK) .EQ. 0.0E0) X RM1(UK,UK) = EPS3 ITS = 0 C .......... BACK SUBSTITUTION C FOR I=UK STEP -1 UNTIL 1 DO -- .......... 660 DO 720 II = 1, UK I = UK + 1 - II X = RV1(I) Y = 0.0E0 IF (I .EQ. UK) GO TO 700 IP1 = I + 1 C DO 680 J = IP1, UK X = X - RM1(I,J) * RV1(J) + RM2(I,J) * RV2(J) Y = Y - RM1(I,J) * RV2(J) - RM2(I,J) * RV1(J) 680 CONTINUE C 700 CALL CDIV(X,Y,RM1(I,I),RM2(I,I),RV1(I),RV2(I)) 720 CONTINUE C .......... ACCEPTANCE TEST FOR EIGENVECTOR C AND NORMALIZATION .......... ITS = ITS + 1 NORM = 0.0E0 NORMV = 0.0E0 C DO 780 I = 1, UK X = PYTHAG(RV1(I),RV2(I)) IF (NORMV .GE. X) GO TO 760 NORMV = X J = I 760 NORM = NORM + X 780 CONTINUE C IF (NORM .LT. GROWTO) GO TO 840 C .......... ACCEPT VECTOR .......... X = RV1(J) Y = RV2(J) C DO 820 I = 1, UK CALL CDIV(RV1(I),RV2(I),X,Y,ZR(I,S),ZI(I,S)) 820 CONTINUE C IF (UK .EQ. N) GO TO 940 J = UK + 1 GO TO 900 C .......... IN-LINE PROCEDURE FOR CHOOSING C A NEW STARTING VECTOR .......... 840 IF (ITS .GE. UK) GO TO 880 X = UKROOT Y = EPS3 / (X + 1.0E0) RV1(1) = EPS3 C DO 860 I = 2, UK 860 RV1(I) = Y C J = UK - ITS + 1 RV1(J) = RV1(J) - EPS3 * X GO TO 660 C .......... SET ERROR -- UNACCEPTED EIGENVECTOR .......... 880 J = 1 IERR = -K C .......... SET REMAINING VECTOR COMPONENTS TO ZERO .......... 900 DO 920 I = J, N ZR(I,S) = 0.0E0 ZI(I,S) = 0.0E0 920 CONTINUE C 940 S = S + 1 980 CONTINUE C GO TO 1001 C .......... SET ERROR -- UNDERESTIMATE OF EIGENVECTOR C SPACE REQUIRED .......... 1000 IF (IERR .NE. 0) IERR = IERR - N IF (IERR .EQ. 0) IERR = -(2 * N + 1) 1001 M = S - 1 RETURN END SUBROUTINE COMBAK(NM,LOW,IGH,AR,AI,INT,M,ZR,ZI) C INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1 REAL AR(NM,IGH),AI(NM,IGH),ZR(NM,M),ZI(NM,M) REAL XR,XI INTEGER INT(IGH) C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMBAK, C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). C C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING C UPPER HESSENBERG MATRIX DETERMINED BY COMHES. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, C SET LOW=1 AND IGH EQUAL TO THE ORDER OF THE MATRIX. C C AR AND AI CONTAIN THE MULTIPLIERS WHICH WERE USED IN THE C REDUCTION BY COMHES IN THEIR LOWER TRIANGLES C BELOW THE SUBDIAGONAL. C C INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS C INTERCHANGED IN THE REDUCTION BY COMHES. C ONLY ELEMENTS LOW THROUGH IGH ARE USED. C C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. C C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVECTORS TO BE C BACK TRANSFORMED IN THEIR FIRST M COLUMNS. C C ON OUTPUT C C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS C IN THEIR FIRST M COLUMNS. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C IF (M .EQ. 0) GO TO 200 LA = IGH - 1 KP1 = LOW + 1 IF (LA .LT. KP1) GO TO 200 C .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... DO 140 MM = KP1, LA MP = LOW + IGH - MM MP1 = MP + 1 C DO 110 I = MP1, IGH XR = AR(I,MP-1) XI = AI(I,MP-1) IF (XR .EQ. 0.0E0 .AND. XI .EQ. 0.0E0) GO TO 110 C DO 100 J = 1, M ZR(I,J) = ZR(I,J) + XR * ZR(MP,J) - XI * ZI(MP,J) ZI(I,J) = ZI(I,J) + XR * ZI(MP,J) + XI * ZR(MP,J) 100 CONTINUE C 110 CONTINUE C I = INT(MP) IF (I .EQ. MP) GO TO 140 C DO 130 J = 1, M XR = ZR(I,J) ZR(I,J) = ZR(MP,J) ZR(MP,J) = XR XI = ZI(I,J) ZI(I,J) = ZI(MP,J) ZI(MP,J) = XI 130 CONTINUE C 140 CONTINUE C 200 RETURN END SUBROUTINE COMHES(NM,N,LOW,IGH,AR,AI,INT) C INTEGER I,J,M,N,LA,NM,IGH,KP1,LOW,MM1,MP1 REAL AR(NM,N),AI(NM,N) REAL XR,XI,YR,YI INTEGER INT(IGH) C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMHES, C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). C C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY C STABILIZED ELEMENTARY SIMILARITY TRANSFORMATIONS. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, C SET LOW=1, IGH=N. C C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX. C C ON OUTPUT C C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE HESSENBERG MATRIX. THE C MULTIPLIERS WHICH WERE USED IN THE REDUCTION C ARE STORED IN THE REMAINING TRIANGLES UNDER THE C HESSENBERG MATRIX. C C INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS C INTERCHANGED IN THE REDUCTION. C ONLY ELEMENTS LOW THROUGH IGH ARE USED. C C CALLS CDIV FOR COMPLEX DIVISION. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C LA = IGH - 1 KP1 = LOW + 1 IF (LA .LT. KP1) GO TO 200 C DO 180 M = KP1, LA MM1 = M - 1 XR = 0.0E0 XI = 0.0E0 I = M C DO 100 J = M, IGH IF (ABS(AR(J,MM1)) + ABS(AI(J,MM1)) X .LE. ABS(XR) + ABS(XI)) GO TO 100 XR = AR(J,MM1) XI = AI(J,MM1) I = J 100 CONTINUE C INT(M) = I IF (I .EQ. M) GO TO 130 C .......... INTERCHANGE ROWS AND COLUMNS OF AR AND AI .......... DO 110 J = MM1, N YR = AR(I,J) AR(I,J) = AR(M,J) AR(M,J) = YR YI = AI(I,J) AI(I,J) = AI(M,J) AI(M,J) = YI 110 CONTINUE C DO 120 J = 1, IGH YR = AR(J,I) AR(J,I) = AR(J,M) AR(J,M) = YR YI = AI(J,I) AI(J,I) = AI(J,M) AI(J,M) = YI 120 CONTINUE C .......... END INTERCHANGE .......... 130 IF (XR .EQ. 0.0E0 .AND. XI .EQ. 0.0E0) GO TO 180 MP1 = M + 1 C DO 160 I = MP1, IGH YR = AR(I,MM1) YI = AI(I,MM1) IF (YR .EQ. 0.0E0 .AND. YI .EQ. 0.0E0) GO TO 160 CALL CDIV(YR,YI,XR,XI,YR,YI) AR(I,MM1) = YR AI(I,MM1) = YI C DO 140 J = M, N AR(I,J) = AR(I,J) - YR * AR(M,J) + YI * AI(M,J) AI(I,J) = AI(I,J) - YR * AI(M,J) - YI * AR(M,J) 140 CONTINUE C DO 150 J = 1, IGH AR(J,M) = AR(J,M) + YR * AR(J,I) - YI * AI(J,I) AI(J,M) = AI(J,M) + YR * AI(J,I) + YI * AR(J,I) 150 CONTINUE C 160 CONTINUE C 180 CONTINUE C 200 RETURN END SUBROUTINE COMLR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR) C INTEGER I,J,L,M,N,EN,LL,MM,NM,IGH,IM1,ITN,ITS,LOW,MP1,ENM1,IERR REAL HR(NM,N),HI(NM,N),WR(N),WI(N) REAL SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,TST1,TST2 C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMLR, C NUM. MATH. 12, 369-376(1968) BY MARTIN AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971). C C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX C UPPER HESSENBERG MATRIX BY THE MODIFIED LR METHOD. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, C SET LOW=1, IGH=N. C C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN THE C MULTIPLIERS WHICH WERE USED IN THE REDUCTION BY COMHES, C IF PERFORMED. C C ON OUTPUT C C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE C CALLING COMLR IF SUBSEQUENT CALCULATION OF C EIGENVECTORS IS TO BE PERFORMED. C C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT C FOR INDICES IERR+1,...,N. C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. C C CALLS CDIV FOR COMPLEX DIVISION. C CALLS CSROOT FOR COMPLEX SQUARE ROOT. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C IERR = 0 C .......... STORE ROOTS ISOLATED BY CBAL .......... DO 200 I = 1, N IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200 WR(I) = HR(I,I) WI(I) = HI(I,I) 200 CONTINUE C EN = IGH TR = 0.0E0 TI = 0.0E0 ITN = 30*N C .......... SEARCH FOR NEXT EIGENVALUE .......... 220 IF (EN .LT. LOW) GO TO 1001 ITS = 0 ENM1 = EN - 1 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT C FOR L=EN STEP -1 UNTIL LOW E0 -- .......... 240 DO 260 LL = LOW, EN L = EN + LOW - LL IF (L .EQ. LOW) GO TO 300 TST1 = ABS(HR(L-1,L-1)) + ABS(HI(L-1,L-1)) X + ABS(HR(L,L)) + ABS(HI(L,L)) TST2 = TST1 + ABS(HR(L,L-1)) + ABS(HI(L,L-1)) IF (TST2 .EQ. TST1) GO TO 300 260 CONTINUE C .......... FORM SHIFT .......... 300 IF (L .EQ. EN) GO TO 660 IF (ITN .EQ. 0) GO TO 1000 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320 SR = HR(EN,EN) SI = HI(EN,EN) XR = HR(ENM1,EN) * HR(EN,ENM1) - HI(ENM1,EN) * HI(EN,ENM1) XI = HR(ENM1,EN) * HI(EN,ENM1) + HI(ENM1,EN) * HR(EN,ENM1) IF (XR .EQ. 0.0E0 .AND. XI .EQ. 0.0E0) GO TO 340 YR = (HR(ENM1,ENM1) - SR) / 2.0E0 YI = (HI(ENM1,ENM1) - SI) / 2.0E0 CALL CSROOT(YR**2-YI**2+XR,2.0E0*YR*YI+XI,ZZR,ZZI) IF (YR * ZZR + YI * ZZI .GE. 0.0E0) GO TO 310 ZZR = -ZZR ZZI = -ZZI 310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI) SR = SR - XR SI = SI - XI GO TO 340 C .......... FORM EXCEPTIONAL SHIFT .......... 320 SR = ABS(HR(EN,ENM1)) + ABS(HR(ENM1,EN-2)) SI = ABS(HI(EN,ENM1)) + ABS(HI(ENM1,EN-2)) C 340 DO 360 I = LOW, EN HR(I,I) = HR(I,I) - SR HI(I,I) = HI(I,I) - SI 360 CONTINUE C TR = TR + SR TI = TI + SI ITS = ITS + 1 ITN = ITN - 1 C .......... LOOK FOR TWO CONSECUTIVE SMALL C SUB-DIAGONAL ELEMENTS .......... XR = ABS(HR(ENM1,ENM1)) + ABS(HI(ENM1,ENM1)) YR = ABS(HR(EN,ENM1)) + ABS(HI(EN,ENM1)) ZZR = ABS(HR(EN,EN)) + ABS(HI(EN,EN)) C .......... FOR M=EN-1 STEP -1 UNTIL L DO -- .......... DO 380 MM = L, ENM1 M = ENM1 + L - MM IF (M .EQ. L) GO TO 420 YI = YR YR = ABS(HR(M,M-1)) + ABS(HI(M,M-1)) XI = ZZR ZZR = XR XR = ABS(HR(M-1,M-1)) + ABS(HI(M-1,M-1)) TST1 = ZZR / YI * (ZZR + XR + XI) TST2 = TST1 + YR IF (TST2 .EQ. TST1) GO TO 420 380 CONTINUE C .......... TRIANGULAR DECOMPOSITION H=L*R .......... 420 MP1 = M + 1 C DO 520 I = MP1, EN IM1 = I - 1 XR = HR(IM1,IM1) XI = HI(IM1,IM1) YR = HR(I,IM1) YI = HI(I,IM1) IF (ABS(XR) + ABS(XI) .GE. ABS(YR) + ABS(YI)) GO TO 460 C .......... INTERCHANGE ROWS OF HR AND HI .......... DO 440 J = IM1, EN ZZR = HR(IM1,J) HR(IM1,J) = HR(I,J) HR(I,J) = ZZR ZZI = HI(IM1,J) HI(IM1,J) = HI(I,J) HI(I,J) = ZZI 440 CONTINUE C CALL CDIV(XR,XI,YR,YI,ZZR,ZZI) WR(I) = 1.0E0 GO TO 480 460 CALL CDIV(YR,YI,XR,XI,ZZR,ZZI) WR(I) = -1.0E0 480 HR(I,IM1) = ZZR HI(I,IM1) = ZZI C DO 500 J = I, EN HR(I,J) = HR(I,J) - ZZR * HR(IM1,J) + ZZI * HI(IM1,J) HI(I,J) = HI(I,J) - ZZR * HI(IM1,J) - ZZI * HR(IM1,J) 500 CONTINUE C 520 CONTINUE C .......... COMPOSITION R*L=H .......... DO 640 J = MP1, EN XR = HR(J,J-1) XI = HI(J,J-1) HR(J,J-1) = 0.0E0 HI(J,J-1) = 0.0E0 C .......... INTERCHANGE COLUMNS OF HR AND HI, C IF NECESSARY .......... IF (WR(J) .LE. 0.0E0) GO TO 580 C DO 540 I = L, J ZZR = HR(I,J-1) HR(I,J-1) = HR(I,J) HR(I,J) = ZZR ZZI = HI(I,J-1) HI(I,J-1) = HI(I,J) HI(I,J) = ZZI 540 CONTINUE C 580 DO 600 I = L, J HR(I,J-1) = HR(I,J-1) + XR * HR(I,J) - XI * HI(I,J) HI(I,J-1) = HI(I,J-1) + XR * HI(I,J) + XI * HR(I,J) 600 CONTINUE C 640 CONTINUE C GO TO 240 C .......... A ROOT FOUND .......... 660 WR(EN) = HR(EN,EN) + TR WI(EN) = HI(EN,EN) + TI EN = ENM1 GO TO 220 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT C CONVERGED AFTER 30*N ITERATIONS .......... 1000 IERR = EN 1001 RETURN END SUBROUTINE COMLR2(NM,N,LOW,IGH,INT,HR,HI,WR,WI,ZR,ZI,IERR) C INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NM,NN,IGH,IM1,IP1, X ITN,ITS,LOW,MP1,ENM1,IEND,IERR REAL HR(NM,N),HI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N) REAL SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2 INTEGER INT(IGH) C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMLR2, C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). C C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE MODIFIED LR C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX C CAN ALSO BE FOUND IF COMHES HAS BEEN USED TO REDUCE C THIS GENERAL MATRIX TO HESSENBERG FORM. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, C SET LOW=1, IGH=N. C C INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS INTERCHANGED C IN THE REDUCTION BY COMHES, IF PERFORMED. ONLY ELEMENTS C LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS OF THE HESSEN- C BERG MATRIX ARE DESIRED, SET INT(J)=J FOR THESE ELEMENTS. C C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN THE C MULTIPLIERS WHICH WERE USED IN THE REDUCTION BY COMHES, C IF PERFORMED. IF THE EIGENVECTORS OF THE HESSENBERG C MATRIX ARE DESIRED, THESE ELEMENTS MUST BE SET TO ZERO. C C ON OUTPUT C C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN C DESTROYED, BUT THE LOCATION HR(1,1) CONTAINS THE NORM C OF THE TRIANGULARIZED MATRIX. C C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT C FOR INDICES IERR+1,...,N. C C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF C THE EIGENVECTORS HAS BEEN FOUND. C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. C C C CALLS CDIV FOR COMPLEX DIVISION. C CALLS CSROOT FOR COMPLEX SQUARE ROOT. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C IERR = 0 C .......... INITIALIZE EIGENVECTOR MATRIX .......... DO 100 I = 1, N C DO 100 J = 1, N ZR(I,J) = 0.0E0 ZI(I,J) = 0.0E0 IF (I .EQ. J) ZR(I,J) = 1.0E0 100 CONTINUE C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS C FROM THE INFORMATION LEFT BY COMHES .......... IEND = IGH - LOW - 1 IF (IEND .LE. 0) GO TO 180 C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... DO 160 II = 1, IEND I = IGH - II IP1 = I + 1 C DO 120 K = IP1, IGH ZR(K,I) = HR(K,I-1) ZI(K,I) = HI(K,I-1) 120 CONTINUE C J = INT(I) IF (I .EQ. J) GO TO 160 C DO 140 K = I, IGH ZR(I,K) = ZR(J,K) ZI(I,K) = ZI(J,K) ZR(J,K) = 0.0E0 ZI(J,K) = 0.0E0 140 CONTINUE C ZR(J,I) = 1.0E0 160 CONTINUE C .......... STORE ROOTS ISOLATED BY CBAL .......... 180 DO 200 I = 1, N IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200 WR(I) = HR(I,I) WI(I) = HI(I,I) 200 CONTINUE C EN = IGH TR = 0.0E0 TI = 0.0E0 ITN = 30*N C .......... SEARCH FOR NEXT EIGENVALUE .......... 220 IF (EN .LT. LOW) GO TO 680 ITS = 0 ENM1 = EN - 1 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT C FOR L=EN STEP -1 UNTIL LOW DO -- .......... 240 DO 260 LL = LOW, EN L = EN + LOW - LL IF (L .EQ. LOW) GO TO 300 TST1 = ABS(HR(L-1,L-1)) + ABS(HI(L-1,L-1)) X + ABS(HR(L,L)) + ABS(HI(L,L)) TST2 = TST1 + ABS(HR(L,L-1)) + ABS(HI(L,L-1)) IF (TST2 .EQ. TST1) GO TO 300 260 CONTINUE C .......... FORM SHIFT .......... 300 IF (L .EQ. EN) GO TO 660 IF (ITN .EQ. 0) GO TO 1000 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320 SR = HR(EN,EN) SI = HI(EN,EN) XR = HR(ENM1,EN) * HR(EN,ENM1) - HI(ENM1,EN) * HI(EN,ENM1) XI = HR(ENM1,EN) * HI(EN,ENM1) + HI(ENM1,EN) * HR(EN,ENM1) IF (XR .EQ. 0.0E0 .AND. XI .EQ. 0.0E0) GO TO 340 YR = (HR(ENM1,ENM1) - SR) / 2.0E0 YI = (HI(ENM1,ENM1) - SI) / 2.0E0 CALL CSROOT(YR**2-YI**2+XR,2.0E0*YR*YI+XI,ZZR,ZZI) IF (YR * ZZR + YI * ZZI .GE. 0.0E0) GO TO 310 ZZR = -ZZR ZZI = -ZZI 310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI) SR = SR - XR SI = SI - XI GO TO 340 C .......... FORM EXCEPTIONAL SHIFT .......... 320 SR = ABS(HR(EN,ENM1)) + ABS(HR(ENM1,EN-2)) SI = ABS(HI(EN,ENM1)) + ABS(HI(ENM1,EN-2)) C 340 DO 360 I = LOW, EN HR(I,I) = HR(I,I) - SR HI(I,I) = HI(I,I) - SI 360 CONTINUE C TR = TR + SR TI = TI + SI ITS = ITS + 1 ITN = ITN - 1 C .......... LOOK FOR TWO CONSECUTIVE SMALL C SUB-DIAGONAL ELEMENTS .......... XR = ABS(HR(ENM1,ENM1)) + ABS(HI(ENM1,ENM1)) YR = ABS(HR(EN,ENM1)) + ABS(HI(EN,ENM1)) ZZR = ABS(HR(EN,EN)) + ABS(HI(EN,EN)) C .......... FOR M=EN-1 STEP -1 UNTIL L DO -- .......... DO 380 MM = L, ENM1 M = ENM1 + L - MM IF (M .EQ. L) GO TO 420 YI = YR YR = ABS(HR(M,M-1)) + ABS(HI(M,M-1)) XI = ZZR ZZR = XR XR = ABS(HR(M-1,M-1)) + ABS(HI(M-1,M-1)) TST1 = ZZR / YI * (ZZR + XR + XI) TST2 = TST1 + YR IF (TST2 .EQ. TST1) GO TO 420 380 CONTINUE C .......... TRIANGULAR DECOMPOSITION H=L*R .......... 420 MP1 = M + 1 C DO 520 I = MP1, EN IM1 = I - 1 XR = HR(IM1,IM1) XI = HI(IM1,IM1) YR = HR(I,IM1) YI = HI(I,IM1) IF (ABS(XR) + ABS(XI) .GE. ABS(YR) + ABS(YI)) GO TO 460 C .......... INTERCHANGE ROWS OF HR AND HI .......... DO 440 J = IM1, N ZZR = HR(IM1,J) HR(IM1,J) = HR(I,J) HR(I,J) = ZZR ZZI = HI(IM1,J) HI(IM1,J) = HI(I,J) HI(I,J) = ZZI 440 CONTINUE C CALL CDIV(XR,XI,YR,YI,ZZR,ZZI) WR(I) = 1.0E0 GO TO 480 460 CALL CDIV(YR,YI,XR,XI,ZZR,ZZI) WR(I) = -1.0E0 480 HR(I,IM1) = ZZR HI(I,IM1) = ZZI C DO 500 J = I, N HR(I,J) = HR(I,J) - ZZR * HR(IM1,J) + ZZI * HI(IM1,J) HI(I,J) = HI(I,J) - ZZR * HI(IM1,J) - ZZI * HR(IM1,J) 500 CONTINUE C 520 CONTINUE C .......... COMPOSITION R*L=H .......... DO 640 J = MP1, EN XR = HR(J,J-1) XI = HI(J,J-1) HR(J,J-1) = 0.0E0 HI(J,J-1) = 0.0E0 C .......... INTERCHANGE COLUMNS OF HR, HI, ZR, AND ZI, C IF NECESSARY .......... IF (WR(J) .LE. 0.0E0) GO TO 580 C DO 540 I = 1, J ZZR = HR(I,J-1) HR(I,J-1) = HR(I,J) HR(I,J) = ZZR ZZI = HI(I,J-1) HI(I,J-1) = HI(I,J) HI(I,J) = ZZI 540 CONTINUE C DO 560 I = LOW, IGH ZZR = ZR(I,J-1) ZR(I,J-1) = ZR(I,J) ZR(I,J) = ZZR ZZI = ZI(I,J-1) ZI(I,J-1) = ZI(I,J) ZI(I,J) = ZZI 560 CONTINUE C 580 DO 600 I = 1, J HR(I,J-1) = HR(I,J-1) + XR * HR(I,J) - XI * HI(I,J) HI(I,J-1) = HI(I,J-1) + XR * HI(I,J) + XI * HR(I,J) 600 CONTINUE C .......... ACCUMULATE TRANSFORMATIONS .......... DO 620 I = LOW, IGH ZR(I,J-1) = ZR(I,J-1) + XR * ZR(I,J) - XI * ZI(I,J) ZI(I,J-1) = ZI(I,J-1) + XR * ZI(I,J) + XI * ZR(I,J) 620 CONTINUE C 640 CONTINUE C GO TO 240 C .......... A ROOT FOUND .......... 660 HR(EN,EN) = HR(EN,EN) + TR WR(EN) = HR(EN,EN) HI(EN,EN) = HI(EN,EN) + TI WI(EN) = HI(EN,EN) EN = ENM1 GO TO 220 C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND C VECTORS OF UPPER TRIANGULAR FORM .......... 680 NORM = 0.0E0 C DO 720 I = 1, N C DO 720 J = I, N TR = ABS(HR(I,J)) + ABS(HI(I,J)) IF (TR .GT. NORM) NORM = TR 720 CONTINUE C HR(1,1) = NORM IF (N .EQ. 1 .OR. NORM .EQ. 0.0E0) GO TO 1001 C .......... FOR EN=N STEP -1 UNTIL 2 DO -- .......... DO 800 NN = 2, N EN = N + 2 - NN XR = WR(EN) XI = WI(EN) HR(EN,EN) = 1.0E0 HI(EN,EN) = 0.0E0 ENM1 = EN - 1 C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... DO 780 II = 1, ENM1 I = EN - II ZZR = 0.0E0 ZZI = 0.0E0 IP1 = I + 1 C DO 740 J = IP1, EN ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN) ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN) 740 CONTINUE C YR = XR - WR(I) YI = XI - WI(I) IF (YR .NE. 0.0E0 .OR. YI .NE. 0.0E0) GO TO 765 TST1 = NORM YR = TST1 760 YR = 0.01E0 * YR TST2 = NORM + YR IF (TST2 .GT. TST1) GO TO 760 765 CONTINUE CALL CDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN)) C .......... OVERFLOW CONTROL .......... TR = ABS(HR(I,EN)) + ABS(HI(I,EN)) IF (TR .EQ. 0.0E0) GO TO 780 TST1 = TR TST2 = TST1 + 1.0E0/TST1 IF (TST2 .GT. TST1) GO TO 780 DO 770 J = I, EN HR(J,EN) = HR(J,EN)/TR HI(J,EN) = HI(J,EN)/TR 770 CONTINUE C 780 CONTINUE C 800 CONTINUE C .......... END BACKSUBSTITUTION .......... ENM1 = N - 1 C .......... VECTORS OF ISOLATED ROOTS .......... DO 840 I = 1, ENM1 IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840 IP1 = I + 1 C DO 820 J = IP1, N ZR(I,J) = HR(I,J) ZI(I,J) = HI(I,J) 820 CONTINUE C 840 CONTINUE C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE C VECTORS OF ORIGINAL FULL MATRIX. C FOR J=N STEP -1 UNTIL LOW+1 DO -- .......... DO 880 JJ = LOW, ENM1 J = N + LOW - JJ M = MIN0(J,IGH) C DO 880 I = LOW, IGH ZZR = 0.0E0 ZZI = 0.0E0 C DO 860 K = LOW, M ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J) ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J) 860 CONTINUE C ZR(I,J) = ZZR ZI(I,J) = ZZI 880 CONTINUE C GO TO 1001 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT C CONVERGED AFTER 30*N ITERATIONS .......... 1000 IERR = EN 1001 RETURN END SUBROUTINE COMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR) C INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR REAL HR(NM,N),HI(NM,N),WR(N),WI(N) REAL SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2, X PYTHAG C C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN C AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971). C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM. C C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX C UPPER HESSENBERG MATRIX BY THE QR METHOD. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, C SET LOW=1, IGH=N. C C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN C THE REDUCTION BY CORTH, IF PERFORMED. C C ON OUTPUT C C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE C CALLING COMQR IF SUBSEQUENT CALCULATION OF C EIGENVECTORS IS TO BE PERFORMED. C C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT C FOR INDICES IERR+1,...,N. C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. C C CALLS CDIV FOR COMPLEX DIVISION. C CALLS CSROOT FOR COMPLEX SQUARE ROOT. C CALLS PYTHAG FOR SQRT(A*A + B*B) . C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C IERR = 0 IF (LOW .EQ. IGH) GO TO 180 C .......... CREATE REAL SUBDIAGONAL ELEMENTS .......... L = LOW + 1 C DO 170 I = L, IGH LL = MIN0(I+1,IGH) IF (HI(I,I-1) .EQ. 0.0E0) GO TO 170 NORM = PYTHAG(HR(I,I-1),HI(I,I-1)) YR = HR(I,I-1) / NORM YI = HI(I,I-1) / NORM HR(I,I-1) = NORM HI(I,I-1) = 0.0E0 C DO 155 J = I, IGH SI = YR * HI(I,J) - YI * HR(I,J) HR(I,J) = YR * HR(I,J) + YI * HI(I,J) HI(I,J) = SI 155 CONTINUE C DO 160 J = LOW, LL SI = YR * HI(J,I) + YI * HR(J,I) HR(J,I) = YR * HR(J,I) - YI * HI(J,I) HI(J,I) = SI 160 CONTINUE C 170 CONTINUE C .......... STORE ROOTS ISOLATED BY CBAL .......... 180 DO 200 I = 1, N IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200 WR(I) = HR(I,I) WI(I) = HI(I,I) 200 CONTINUE C EN = IGH TR = 0.0E0 TI = 0.0E0 ITN = 30*N C .......... SEARCH FOR NEXT EIGENVALUE .......... 220 IF (EN .LT. LOW) GO TO 1001 ITS = 0 ENM1 = EN - 1 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT C FOR L=EN STEP -1 UNTIL LOW E0 -- .......... 240 DO 260 LL = LOW, EN L = EN + LOW - LL IF (L .EQ. LOW) GO TO 300 TST1 = ABS(HR(L-1,L-1)) + ABS(HI(L-1,L-1)) X + ABS(HR(L,L)) + ABS(HI(L,L)) TST2 = TST1 + ABS(HR(L,L-1)) IF (TST2 .EQ. TST1) GO TO 300 260 CONTINUE C .......... FORM SHIFT .......... 300 IF (L .EQ. EN) GO TO 660 IF (ITN .EQ. 0) GO TO 1000 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320 SR = HR(EN,EN) SI = HI(EN,EN) XR = HR(ENM1,EN) * HR(EN,ENM1) XI = HI(ENM1,EN) * HR(EN,ENM1) IF (XR .EQ. 0.0E0 .AND. XI .EQ. 0.0E0) GO TO 340 YR = (HR(ENM1,ENM1) - SR) / 2.0E0 YI = (HI(ENM1,ENM1) - SI) / 2.0E0 CALL CSROOT(YR**2-YI**2+XR,2.0E0*YR*YI+XI,ZZR,ZZI) IF (YR * ZZR + YI * ZZI .GE. 0.0E0) GO TO 310 ZZR = -ZZR ZZI = -ZZI 310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI) SR = SR - XR SI = SI - XI GO TO 340 C .......... FORM EXCEPTIONAL SHIFT .......... 320 SR = ABS(HR(EN,ENM1)) + ABS(HR(ENM1,EN-2)) SI = 0.0E0 C 340 DO 360 I = LOW, EN HR(I,I) = HR(I,I) - SR HI(I,I) = HI(I,I) - SI 360 CONTINUE C TR = TR + SR TI = TI + SI ITS = ITS + 1 ITN = ITN - 1 C .......... REDUCE TO TRIANGLE (ROWS) .......... LP1 = L + 1 C DO 500 I = LP1, EN SR = HR(I,I-1) HR(I,I-1) = 0.0E0 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR) XR = HR(I-1,I-1) / NORM WR(I-1) = XR XI = HI(I-1,I-1) / NORM WI(I-1) = XI HR(I-1,I-1) = NORM HI(I-1,I-1) = 0.0E0 HI(I,I-1) = SR / NORM C DO 490 J = I, EN YR = HR(I-1,J) YI = HI(I-1,J) ZZR = HR(I,J) ZZI = HI(I,J) HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI 490 CONTINUE C 500 CONTINUE C SI = HI(EN,EN) IF (SI .EQ. 0.0E0) GO TO 540 NORM = PYTHAG(HR(EN,EN),SI) SR = HR(EN,EN) / NORM SI = SI / NORM HR(EN,EN) = NORM HI(EN,EN) = 0.0E0 C .......... INVERSE OPERATION (COLUMNS) .......... 540 DO 600 J = LP1, EN XR = WR(J-1) XI = WI(J-1) C DO 580 I = L, J YR = HR(I,J-1) YI = 0.0E0 ZZR = HR(I,J) ZZI = HI(I,J) IF (I .EQ. J) GO TO 560 YI = HI(I,J-1) HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI 560 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI 580 CONTINUE C 600 CONTINUE C IF (SI .EQ. 0.0E0) GO TO 240 C DO 630 I = L, EN YR = HR(I,EN) YI = HI(I,EN) HR(I,EN) = SR * YR - SI * YI HI(I,EN) = SR * YI + SI * YR 630 CONTINUE C GO TO 240 C .......... A ROOT FOUND .......... 660 WR(EN) = HR(EN,EN) + TR WI(EN) = HI(EN,EN) + TI EN = ENM1 GO TO 220 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT C CONVERGED AFTER 30*N ITERATIONS .......... 1000 IERR = EN 1001 RETURN END SUBROUTINE COMQR2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR) C INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1, X ITN,ITS,LOW,LP1,ENM1,IEND,IERR REAL HR(NM,N),HI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N), X ORTR(IGH),ORTI(IGH) REAL SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2, X PYTHAG C C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS C AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM. C C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE C THIS GENERAL MATRIX TO HESSENBERG FORM. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, C SET LOW=1, IGH=N. C C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS- C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED. C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND C ORTI(J) TO 0.0E0 FOR THESE ELEMENTS. C C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE C ARBITRARY. C C ON OUTPUT C C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI C HAVE BEEN DESTROYED. C C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT C FOR INDICES IERR+1,...,N. C C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF C THE EIGENVECTORS HAS BEEN FOUND. C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. C C CALLS CDIV FOR COMPLEX DIVISION. C CALLS CSROOT FOR COMPLEX SQUARE ROOT. C CALLS PYTHAG FOR SQRT(A*A + B*B) . C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C IERR = 0 C .......... INITIALIZE EIGENVECTOR MATRIX .......... DO 101 J = 1, N C DO 100 I = 1, N ZR(I,J) = 0.0E0 ZI(I,J) = 0.0E0 100 CONTINUE ZR(J,J) = 1.0E0 101 CONTINUE C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS C FROM THE INFORMATION LEFT BY CORTH .......... IEND = IGH - LOW - 1 IF (IEND) 180, 150, 105 C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... 105 DO 140 II = 1, IEND I = IGH - II IF (ORTR(I) .EQ. 0.0E0 .AND. ORTI(I) .EQ. 0.0E0) GO TO 140 IF (HR(I,I-1) .EQ. 0.0E0 .AND. HI(I,I-1) .EQ. 0.0E0) GO TO 140 C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH .......... NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I) IP1 = I + 1 C DO 110 K = IP1, IGH ORTR(K) = HR(K,I-1) ORTI(K) = HI(K,I-1) 110 CONTINUE C DO 130 J = I, IGH SR = 0.0E0 SI = 0.0E0 C DO 115 K = I, IGH SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J) SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J) 115 CONTINUE C SR = SR / NORM SI = SI / NORM C DO 120 K = I, IGH ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K) ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K) 120 CONTINUE C 130 CONTINUE C 140 CONTINUE C .......... CREATE REAL SUBDIAGONAL ELEMENTS .......... 150 L = LOW + 1 C DO 170 I = L, IGH LL = MIN0(I+1,IGH) IF (HI(I,I-1) .EQ. 0.0E0) GO TO 170 NORM = PYTHAG(HR(I,I-1),HI(I,I-1)) YR = HR(I,I-1) / NORM YI = HI(I,I-1) / NORM HR(I,I-1) = NORM HI(I,I-1) = 0.0E0 C DO 155 J = I, N SI = YR * HI(I,J) - YI * HR(I,J) HR(I,J) = YR * HR(I,J) + YI * HI(I,J) HI(I,J) = SI 155 CONTINUE C DO 160 J = 1, LL SI = YR * HI(J,I) + YI * HR(J,I) HR(J,I) = YR * HR(J,I) - YI * HI(J,I) HI(J,I) = SI 160 CONTINUE C DO 165 J = LOW, IGH SI = YR * ZI(J,I) + YI * ZR(J,I) ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I) ZI(J,I) = SI 165 CONTINUE C 170 CONTINUE C .......... STORE ROOTS ISOLATED BY CBAL .......... 180 DO 200 I = 1, N IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200 WR(I) = HR(I,I) WI(I) = HI(I,I) 200 CONTINUE C EN = IGH TR = 0.0E0 TI = 0.0E0 ITN = 30*N C .......... SEARCH FOR NEXT EIGENVALUE .......... 220 IF (EN .LT. LOW) GO TO 680 ITS = 0 ENM1 = EN - 1 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT C FOR L=EN STEP -1 UNTIL LOW DO -- .......... 240 DO 260 LL = LOW, EN L = EN + LOW - LL IF (L .EQ. LOW) GO TO 300 TST1 = ABS(HR(L-1,L-1)) + ABS(HI(L-1,L-1)) X + ABS(HR(L,L)) + ABS(HI(L,L)) TST2 = TST1 + ABS(HR(L,L-1)) IF (TST2 .EQ. TST1) GO TO 300 260 CONTINUE C .......... FORM SHIFT .......... 300 IF (L .EQ. EN) GO TO 660 IF (ITN .EQ. 0) GO TO 1000 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320 SR = HR(EN,EN) SI = HI(EN,EN) XR = HR(ENM1,EN) * HR(EN,ENM1) XI = HI(ENM1,EN) * HR(EN,ENM1) IF (XR .EQ. 0.0E0 .AND. XI .EQ. 0.0E0) GO TO 340 YR = (HR(ENM1,ENM1) - SR) / 2.0E0 YI = (HI(ENM1,ENM1) - SI) / 2.0E0 CALL CSROOT(YR**2-YI**2+XR,2.0E0*YR*YI+XI,ZZR,ZZI) IF (YR * ZZR + YI * ZZI .GE. 0.0E0) GO TO 310 ZZR = -ZZR ZZI = -ZZI 310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI) SR = SR - XR SI = SI - XI GO TO 340 C .......... FORM EXCEPTIONAL SHIFT .......... 320 SR = ABS(HR(EN,ENM1)) + ABS(HR(ENM1,EN-2)) SI = 0.0E0 C 340 DO 360 I = LOW, EN HR(I,I) = HR(I,I) - SR HI(I,I) = HI(I,I) - SI 360 CONTINUE C TR = TR + SR TI = TI + SI ITS = ITS + 1 ITN = ITN - 1 C .......... REDUCE TO TRIANGLE (ROWS) .......... LP1 = L + 1 C DO 500 I = LP1, EN SR = HR(I,I-1) HR(I,I-1) = 0.0E0 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR) XR = HR(I-1,I-1) / NORM WR(I-1) = XR XI = HI(I-1,I-1) / NORM WI(I-1) = XI HR(I-1,I-1) = NORM HI(I-1,I-1) = 0.0E0 HI(I,I-1) = SR / NORM C DO 490 J = I, N YR = HR(I-1,J) YI = HI(I-1,J) ZZR = HR(I,J) ZZI = HI(I,J) HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI 490 CONTINUE C 500 CONTINUE C SI = HI(EN,EN) IF (SI .EQ. 0.0E0) GO TO 540 NORM = PYTHAG(HR(EN,EN),SI) SR = HR(EN,EN) / NORM SI = SI / NORM HR(EN,EN) = NORM HI(EN,EN) = 0.0E0 IF (EN .EQ. N) GO TO 540 IP1 = EN + 1 C DO 520 J = IP1, N YR = HR(EN,J) YI = HI(EN,J) HR(EN,J) = SR * YR + SI * YI HI(EN,J) = SR * YI - SI * YR 520 CONTINUE C .......... INVERSE OPERATION (COLUMNS) .......... 540 DO 600 J = LP1, EN XR = WR(J-1) XI = WI(J-1) C DO 580 I = 1, J YR = HR(I,J-1) YI = 0.0E0 ZZR = HR(I,J) ZZI = HI(I,J) IF (I .EQ. J) GO TO 560 YI = HI(I,J-1) HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI 560 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI 580 CONTINUE C DO 590 I = LOW, IGH YR = ZR(I,J-1) YI = ZI(I,J-1) ZZR = ZR(I,J) ZZI = ZI(I,J) ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI 590 CONTINUE C 600 CONTINUE C IF (SI .EQ. 0.0E0) GO TO 240 C DO 630 I = 1, EN YR = HR(I,EN) YI = HI(I,EN) HR(I,EN) = SR * YR - SI * YI HI(I,EN) = SR * YI + SI * YR 630 CONTINUE C DO 640 I = LOW, IGH YR = ZR(I,EN) YI = ZI(I,EN) ZR(I,EN) = SR * YR - SI * YI ZI(I,EN) = SR * YI + SI * YR 640 CONTINUE C GO TO 240 C .......... A ROOT FOUND .......... 660 HR(EN,EN) = HR(EN,EN) + TR WR(EN) = HR(EN,EN) HI(EN,EN) = HI(EN,EN) + TI WI(EN) = HI(EN,EN) EN = ENM1 GO TO 220 C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND C VECTORS OF UPPER TRIANGULAR FORM .......... 680 NORM = 0.0E0 C DO 720 I = 1, N C DO 720 J = I, N TR = ABS(HR(I,J)) + ABS(HI(I,J)) IF (TR .GT. NORM) NORM = TR 720 CONTINUE C IF (N .EQ. 1 .OR. NORM .EQ. 0.0E0) GO TO 1001 C .......... FOR EN=N STEP -1 UNTIL 2 DO -- .......... DO 800 NN = 2, N EN = N + 2 - NN XR = WR(EN) XI = WI(EN) HR(EN,EN) = 1.0E0 HI(EN,EN) = 0.0E0 ENM1 = EN - 1 C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... DO 780 II = 1, ENM1 I = EN - II ZZR = 0.0E0 ZZI = 0.0E0 IP1 = I + 1 C DO 740 J = IP1, EN ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN) ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN) 740 CONTINUE C YR = XR - WR(I) YI = XI - WI(I) IF (YR .NE. 0.0E0 .OR. YI .NE. 0.0E0) GO TO 765 TST1 = NORM YR = TST1 760 YR = 0.01E0 * YR TST2 = NORM + YR IF (TST2 .GT. TST1) GO TO 760 765 CONTINUE CALL CDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN)) C .......... OVERFLOW CONTROL .......... TR = ABS(HR(I,EN)) + ABS(HI(I,EN)) IF (TR .EQ. 0.0E0) GO TO 780 TST1 = TR TST2 = TST1 + 1.0E0/TST1 IF (TST2 .GT. TST1) GO TO 780 DO 770 J = I, EN HR(J,EN) = HR(J,EN)/TR HI(J,EN) = HI(J,EN)/TR 770 CONTINUE C 780 CONTINUE C 800 CONTINUE C .......... END BACKSUBSTITUTION .......... ENM1 = N - 1 C .......... VECTORS OF ISOLATED ROOTS .......... DO 840 I = 1, ENM1 IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840 IP1 = I + 1 C DO 820 J = IP1, N ZR(I,J) = HR(I,J) ZI(I,J) = HI(I,J) 820 CONTINUE C 840 CONTINUE C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE C VECTORS OF ORIGINAL FULL MATRIX. C FOR J=N STEP -1 UNTIL LOW+1 DO -- .......... DO 880 JJ = LOW, ENM1 J = N + LOW - JJ M = MIN0(J,IGH) C DO 880 I = LOW, IGH ZZR = 0.0E0 ZZI = 0.0E0 C DO 860 K = LOW, M ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J) ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J) 860 CONTINUE C ZR(I,J) = ZZR ZI(I,J) = ZZI 880 CONTINUE C GO TO 1001 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT C CONVERGED AFTER 30*N ITERATIONS .......... 1000 IERR = EN 1001 RETURN END SUBROUTINE CORTB(NM,LOW,IGH,AR,AI,ORTR,ORTI,M,ZR,ZI) C INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1 REAL AR(NM,IGH),AI(NM,IGH),ORTR(IGH),ORTI(IGH), X ZR(NM,M),ZI(NM,M) REAL H,GI,GR C C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF C THE ALGOL PROCEDURE ORTBAK, NUM. MATH. 12, 349-368(1968) C BY MARTIN AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). C C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING C UPPER HESSENBERG MATRIX DETERMINED BY CORTH. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, C SET LOW=1 AND IGH EQUAL TO THE ORDER OF THE MATRIX. C C AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY C TRANSFORMATIONS USED IN THE REDUCTION BY CORTH C IN THEIR STRICT LOWER TRIANGLES. C C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE C TRANSFORMATIONS USED IN THE REDUCTION BY CORTH. C ONLY ELEMENTS LOW THROUGH IGH ARE USED. C C M IS THE NUMBER OF COLUMNS OF ZR AND ZI TO BE BACK TRANSFORMED. C C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVECTORS TO BE C BACK TRANSFORMED IN THEIR FIRST M COLUMNS. C C ON OUTPUT C C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS C IN THEIR FIRST M COLUMNS. C C ORTR AND ORTI HAVE BEEN ALTERED. C C NOTE THAT CORTB PRESERVES VECTOR EUCLIDEAN NORMS. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C IF (M .EQ. 0) GO TO 200 LA = IGH - 1 KP1 = LOW + 1 IF (LA .LT. KP1) GO TO 200 C .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... DO 140 MM = KP1, LA MP = LOW + IGH - MM IF (AR(MP,MP-1) .EQ. 0.0E0 .AND. AI(MP,MP-1) .EQ. 0.0E0) X GO TO 140 C .......... H BELOW IS NEGATIVE OF H FORMED IN CORTH .......... H = AR(MP,MP-1) * ORTR(MP) + AI(MP,MP-1) * ORTI(MP) MP1 = MP + 1 C DO 100 I = MP1, IGH ORTR(I) = AR(I,MP-1) ORTI(I) = AI(I,MP-1) 100 CONTINUE C DO 130 J = 1, M GR = 0.0E0 GI = 0.0E0 C DO 110 I = MP, IGH GR = GR + ORTR(I) * ZR(I,J) + ORTI(I) * ZI(I,J) GI = GI + ORTR(I) * ZI(I,J) - ORTI(I) * ZR(I,J) 110 CONTINUE C GR = GR / H GI = GI / H C DO 120 I = MP, IGH ZR(I,J) = ZR(I,J) + GR * ORTR(I) - GI * ORTI(I) ZI(I,J) = ZI(I,J) + GR * ORTI(I) + GI * ORTR(I) 120 CONTINUE C 130 CONTINUE C 140 CONTINUE C 200 RETURN END SUBROUTINE CORTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI) C INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW REAL AR(NM,N),AI(NM,N),ORTR(IGH),ORTI(IGH) REAL F,G,H,FI,FR,SCALE,PYTHAG C C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968) C BY MARTIN AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). C C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY C UNITARY SIMILARITY TRANSFORMATIONS. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, C SET LOW=1, IGH=N. C C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX. C C ON OUTPUT C C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION C IS STORED IN THE REMAINING TRIANGLES UNDER THE C HESSENBERG MATRIX. C C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED. C C CALLS PYTHAG FOR SQRT(A*A + B*B) . C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C LA = IGH - 1 KP1 = LOW + 1 IF (LA .LT. KP1) GO TO 200 C DO 180 M = KP1, LA H = 0.0E0 ORTR(M) = 0.0E0 ORTI(M) = 0.0E0 SCALE = 0.0E0 C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) .......... DO 90 I = M, IGH 90 SCALE = SCALE + ABS(AR(I,M-1)) + ABS(AI(I,M-1)) C IF (SCALE .EQ. 0.0E0) GO TO 180 MP = M + IGH C .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... DO 100 II = M, IGH I = MP - II ORTR(I) = AR(I,M-1) / SCALE ORTI(I) = AI(I,M-1) / SCALE H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I) 100 CONTINUE C G = SQRT(H) F = PYTHAG(ORTR(M),ORTI(M)) IF (F .EQ. 0.0E0) GO TO 103 H = H + F * G G = G / F ORTR(M) = (1.0E0 + G) * ORTR(M) ORTI(M) = (1.0E0 + G) * ORTI(M) GO TO 105 C 103 ORTR(M) = G AR(M,M-1) = SCALE C .......... FORM (I-(U*UT)/H) * A .......... 105 DO 130 J = M, N FR = 0.0E0 FI = 0.0E0 C .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... DO 110 II = M, IGH I = MP - II FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J) FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J) 110 CONTINUE C FR = FR / H FI = FI / H C DO 120 I = M, IGH AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I) AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I) 120 CONTINUE C 130 CONTINUE C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) .......... DO 160 I = 1, IGH FR = 0.0E0 FI = 0.0E0 C .......... FOR J=IGH STEP -1 UNTIL M DO -- .......... DO 140 JJ = M, IGH J = MP - JJ FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J) FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J) 140 CONTINUE C FR = FR / H FI = FI / H C DO 150 J = M, IGH AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J) AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J) 150 CONTINUE C 160 CONTINUE C ORTR(M) = SCALE * ORTR(M) ORTI(M) = SCALE * ORTI(M) AR(M,M-1) = -G * AR(M,M-1) AI(M,M-1) = -G * AI(M,M-1) 180 CONTINUE C 200 RETURN END SUBROUTINE ELMBAK(NM,LOW,IGH,A,INT,M,Z) C INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1 REAL A(NM,IGH),Z(NM,M) REAL X INTEGER INT(IGH) C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMBAK, C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). C C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL GENERAL C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING C UPPER HESSENBERG MATRIX DETERMINED BY ELMHES. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, C SET LOW=1 AND IGH EQUAL TO THE ORDER OF THE MATRIX. C C A CONTAINS THE MULTIPLIERS WHICH WERE USED IN THE C REDUCTION BY ELMHES IN ITS LOWER TRIANGLE C BELOW THE SUBDIAGONAL. C C INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS C INTERCHANGED IN THE REDUCTION BY ELMHES. C ONLY ELEMENTS LOW THROUGH IGH ARE USED. C C M IS THE NUMBER OF COLUMNS OF Z TO BE BACK TRANSFORMED. C C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGEN- C VECTORS TO BE BACK TRANSFORMED IN ITS FIRST M COLUMNS. C C ON OUTPUT C C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE C TRANSFORMED EIGENVECTORS IN ITS FIRST M COLUMNS. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C IF (M .EQ. 0) GO TO 200 LA = IGH - 1 KP1 = LOW + 1 IF (LA .LT. KP1) GO TO 200 C .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... DO 140 MM = KP1, LA MP = LOW + IGH - MM MP1 = MP + 1 C DO 110 I = MP1, IGH X = A(I,MP-1) IF (X .EQ. 0.0E0) GO TO 110 C DO 100 J = 1, M 100 Z(I,J) = Z(I,J) + X * Z(MP,J) C 110 CONTINUE C I = INT(MP) IF (I .EQ. MP) GO TO 140 C DO 130 J = 1, M X = Z(I,J) Z(I,J) = Z(MP,J) Z(MP,J) = X 130 CONTINUE C 140 CONTINUE C 200 RETURN END SUBROUTINE ELMHES(NM,N,LOW,IGH,A,INT) C INTEGER I,J,M,N,LA,NM,IGH,KP1,LOW,MM1,MP1 REAL A(NM,N) REAL X,Y INTEGER INT(IGH) C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMHES, C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). C C GIVEN A REAL GENERAL MATRIX, THIS SUBROUTINE C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY C STABILIZED ELEMENTARY SIMILARITY TRANSFORMATIONS. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, C SET LOW=1, IGH=N. C C A CONTAINS THE INPUT MATRIX. C C ON OUTPUT C C A CONTAINS THE HESSENBERG MATRIX. THE MULTIPLIERS C WHICH WERE USED IN THE REDUCTION ARE STORED IN THE C REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX. C C INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS C INTERCHANGED IN THE REDUCTION. C ONLY ELEMENTS LOW THROUGH IGH ARE USED. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C LA = IGH - 1 KP1 = LOW + 1 IF (LA .LT. KP1) GO TO 200 C DO 180 M = KP1, LA MM1 = M - 1 X = 0.0E0 I = M C DO 100 J = M, IGH IF (ABS(A(J,MM1)) .LE. ABS(X)) GO TO 100 X = A(J,MM1) I = J 100 CONTINUE C INT(M) = I IF (I .EQ. M) GO TO 130 C .......... INTERCHANGE ROWS AND COLUMNS OF A .......... DO 110 J = MM1, N Y = A(I,J) A(I,J) = A(M,J) A(M,J) = Y 110 CONTINUE C DO 120 J = 1, IGH Y = A(J,I) A(J,I) = A(J,M) A(J,M) = Y 120 CONTINUE C .......... END INTERCHANGE .......... 130 IF (X .EQ. 0.0E0) GO TO 180 MP1 = M + 1 C DO 160 I = MP1, IGH Y = A(I,MM1) IF (Y .EQ. 0.0E0) GO TO 160 Y = Y / X A(I,MM1) = Y C DO 140 J = M, N 140 A(I,J) = A(I,J) - Y * A(M,J) C DO 150 J = 1, IGH 150 A(J,M) = A(J,M) + Y * A(J,I) C 160 CONTINUE C 180 CONTINUE C 200 RETURN END SUBROUTINE ELTRAN(NM,N,LOW,IGH,A,INT,Z) C INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1 REAL A(NM,IGH),Z(NM,N) INTEGER INT(IGH) C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMTRANS, C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). C C THIS SUBROUTINE ACCUMULATES THE STABILIZED ELEMENTARY C SIMILARITY TRANSFORMATIONS USED IN THE REDUCTION OF A C REAL GENERAL MATRIX TO UPPER HESSENBERG FORM BY ELMHES. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, C SET LOW=1, IGH=N. C C A CONTAINS THE MULTIPLIERS WHICH WERE USED IN THE C REDUCTION BY ELMHES IN ITS LOWER TRIANGLE C BELOW THE SUBDIAGONAL. C C INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS C INTERCHANGED IN THE REDUCTION BY ELMHES. C ONLY ELEMENTS LOW THROUGH IGH ARE USED. C C ON OUTPUT C C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE C REDUCTION BY ELMHES. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C C .......... INITIALIZE Z TO IDENTITY MATRIX .......... DO 80 J = 1, N C DO 60 I = 1, N 60 Z(I,J) = 0.0E0 C Z(J,J) = 1.0E0 80 CONTINUE C KL = IGH - LOW - 1 IF (KL .LT. 1) GO TO 200 C .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... DO 140 MM = 1, KL MP = IGH - MM MP1 = MP + 1 C DO 100 I = MP1, IGH 100 Z(I,MP) = A(I,MP-1) C I = INT(MP) IF (I .EQ. MP) GO TO 140 C DO 130 J = MP, IGH Z(MP,J) = Z(I,J) Z(I,J) = 0.0E0 130 CONTINUE C Z(I,MP) = 1.0E0 140 CONTINUE C 200 RETURN END SUBROUTINE FIGI(NM,N,T,D,E,E2,IERR) C INTEGER I,N,NM,IERR REAL T(NM,3),D(N),E(N),E2(N) C C GIVEN A NONSYMMETRIC TRIDIAGONAL MATRIX SUCH THAT THE PRODUCTS C OF CORRESPONDING PAIRS OF OFF-DIAGONAL ELEMENTS ARE ALL C NON-NEGATIVE, THIS SUBROUTINE REDUCES IT TO A SYMMETRIC C TRIDIAGONAL MATRIX WITH THE SAME EIGENVALUES. IF, FURTHER, C A ZERO PRODUCT ONLY OCCURS WHEN BOTH FACTORS ARE ZERO, C THE REDUCED MATRIX IS SIMILAR TO THE ORIGINAL MATRIX. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C T CONTAINS THE INPUT MATRIX. ITS SUBDIAGONAL IS C STORED IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN, C ITS DIAGONAL IN THE N POSITIONS OF THE SECOND COLUMN, C AND ITS SUPERDIAGONAL IN THE FIRST N-1 POSITIONS OF C THE THIRD COLUMN. T(1,1) AND T(N,3) ARE ARBITRARY. C C ON OUTPUT C C T IS UNALTERED. C C D CONTAINS THE DIAGONAL ELEMENTS OF THE SYMMETRIC MATRIX. C C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE SYMMETRIC C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS NOT SET. C C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C N+I IF T(I,1)*T(I-1,3) IS NEGATIVE, C -(3*N+I) IF T(I,1)*T(I-1,3) IS ZERO WITH ONE FACTOR C NON-ZERO. IN THIS CASE, THE EIGENVECTORS OF C THE SYMMETRIC MATRIX ARE NOT SIMPLY RELATED C TO THOSE OF T AND SHOULD NOT BE SOUGHT. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C IERR = 0 C DO 100 I = 1, N IF (I .EQ. 1) GO TO 90 E2(I) = T(I,1) * T(I-1,3) IF (E2(I)) 1000, 60, 80 60 IF (T(I,1) .EQ. 0.0E0 .AND. T(I-1,3) .EQ. 0.0E0) GO TO 80 C .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL C ELEMENTS IS ZERO WITH ONE MEMBER NON-ZERO .......... IERR = -(3 * N + I) 80 E(I) = SQRT(E2(I)) 90 D(I) = T(I,2) 100 CONTINUE C GO TO 1001 C .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL C ELEMENTS IS NEGATIVE .......... 1000 IERR = N + I 1001 RETURN END SUBROUTINE FIGI2(NM,N,T,D,E,Z,IERR) C INTEGER I,J,N,NM,IERR REAL T(NM,3),D(N),E(N),Z(NM,N) REAL H C C GIVEN A NONSYMMETRIC TRIDIAGONAL MATRIX SUCH THAT THE PRODUCTS C OF CORRESPONDING PAIRS OF OFF-DIAGONAL ELEMENTS ARE ALL C NON-NEGATIVE, AND ZERO ONLY WHEN BOTH FACTORS ARE ZERO, THIS C SUBROUTINE REDUCES IT TO A SYMMETRIC TRIDIAGONAL MATRIX C USING AND ACCUMULATING DIAGONAL SIMILARITY TRANSFORMATIONS. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C T CONTAINS THE INPUT MATRIX. ITS SUBDIAGONAL IS C STORED IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN, C ITS DIAGONAL IN THE N POSITIONS OF THE SECOND COLUMN, C AND ITS SUPERDIAGONAL IN THE FIRST N-1 POSITIONS OF C THE THIRD COLUMN. T(1,1) AND T(N,3) ARE ARBITRARY. C C ON OUTPUT C C T IS UNALTERED. C C D CONTAINS THE DIAGONAL ELEMENTS OF THE SYMMETRIC MATRIX. C C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE SYMMETRIC C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS NOT SET. C C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN C THE REDUCTION. C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C N+I IF T(I,1)*T(I-1,3) IS NEGATIVE, C 2*N+I IF T(I,1)*T(I-1,3) IS ZERO WITH C ONE FACTOR NON-ZERO. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C ------------------------------------------------------------------ C IERR = 0 C DO 100 I = 1, N C DO 50 J = 1, N 50 Z(I,J) = 0.0E0 C IF (I .EQ. 1) GO TO 70 H = T(I,1) * T(I-1,3) IF (H) 900, 60, 80 60 IF (T(I,1) .NE. 0.0E0 .OR. T(I-1,3) .NE. 0.0E0) GO TO 1000 E(I) = 0.0E0 70 Z(I,I) = 1.0E0 GO TO 90 80 E(I) = SQRT(H) Z(I,I) = Z(I-1,I-1) * E(I) / T(I-1,3) 90 D(I) = T(I,2) 100 CONTINUE C GO TO 1001 C .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL C ELEMENTS IS NEGATIVE .......... 900 IERR = N + I GO TO 10