home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / eispack-1.0-src.tgz / tar.out / contrib / eispack / double / source < prev   
Text File  |  1996-09-28  |  356KB  |  11,445 lines
  1.       SUBROUTINE CDIV(AR,AI,BR,BI,CR,CI)
  2.       DOUBLE PRECISION AR,AI,BR,BI,CR,CI
  3. C
  4. C     COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
  5. C
  6.       DOUBLE PRECISION S,ARS,AIS,BRS,BIS
  7.       S = DABS(BR) + DABS(BI)
  8.       ARS = AR/S
  9.       AIS = AI/S
  10.       BRS = BR/S
  11.       BIS = BI/S
  12.       S = BRS**2 + BIS**2
  13.       CR = (ARS*BRS + AIS*BIS)/S
  14.       CI = (AIS*BRS - ARS*BIS)/S
  15.       RETURN
  16.       END
  17.       SUBROUTINE CSROOT(XR,XI,YR,YI)
  18.       DOUBLE PRECISION XR,XI,YR,YI
  19. C
  20. C     (YR,YI) = COMPLEX DSQRT(XR,XI) 
  21. C     BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
  22. C
  23.       DOUBLE PRECISION S,TR,TI,PYTHAG
  24.       TR = XR
  25.       TI = XI
  26.       S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
  27.       IF (TR .GE. 0.0D0) YR = S
  28.       IF (TI .LT. 0.0D0) S = -S
  29.       IF (TR .LE. 0.0D0) YI = S
  30.       IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
  31.       IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
  32.       RETURN
  33.       END
  34.       DOUBLE PRECISION FUNCTION EPSLON (X)
  35.       DOUBLE PRECISION X
  36. C
  37. C     ESTIMATE UNIT ROUNDOFF IN QUANTITIES OF SIZE X.
  38. C
  39.       DOUBLE PRECISION A,B,C,EPS
  40. C
  41. C     THIS PROGRAM SHOULD FUNCTION PROPERLY ON ALL SYSTEMS
  42. C     SATISFYING THE FOLLOWING TWO ASSUMPTIONS,
  43. C        1.  THE BASE USED IN REPRESENTING FLOATING POINT
  44. C            NUMBERS IS NOT A POWER OF THREE.
  45. C        2.  THE QUANTITY  A  IN STATEMENT 10 IS REPRESENTED TO 
  46. C            THE ACCURACY USED IN FLOATING POINT VARIABLES
  47. C            THAT ARE STORED IN MEMORY.
  48. C     THE STATEMENT NUMBER 10 AND THE GO TO 10 ARE INTENDED TO
  49. C     FORCE OPTIMIZING COMPILERS TO GENERATE CODE SATISFYING 
  50. C     ASSUMPTION 2.
  51. C     UNDER THESE ASSUMPTIONS, IT SHOULD BE TRUE THAT,
  52. C            A  IS NOT EXACTLY EQUAL TO FOUR-THIRDS,
  53. C            B  HAS A ZERO FOR ITS LAST BIT OR DIGIT,
  54. C            C  IS NOT EXACTLY EQUAL TO ONE,
  55. C            EPS  MEASURES THE SEPARATION OF 1.0 FROM
  56. C                 THE NEXT LARGER FLOATING POINT NUMBER.
  57. C     THE DEVELOPERS OF EISPACK WOULD APPRECIATE BEING INFORMED
  58. C     ABOUT ANY SYSTEMS WHERE THESE ASSUMPTIONS DO NOT HOLD.
  59. C
  60. C     THIS VERSION DATED 4/6/83.
  61. C
  62.       A = 4.0D0/3.0D0
  63.    10 B = A - 1.0D0
  64.       C = B + B + B
  65.       EPS = DABS(C-1.0D0)
  66.       IF (EPS .EQ. 0.0D0) GO TO 10
  67.       EPSLON = EPS*DABS(X)
  68.       RETURN
  69.       END
  70.       DOUBLE PRECISION FUNCTION PYTHAG(A,B)
  71.       DOUBLE PRECISION A,B
  72. C
  73. C     FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
  74. C
  75.       DOUBLE PRECISION P,R,S,T,U
  76.       P = DMAX1(DABS(A),DABS(B))
  77.       IF (P .EQ. 0.0D0) GO TO 20
  78.       R = (DMIN1(DABS(A),DABS(B))/P)**2
  79.    10 CONTINUE
  80.          T = 4.0D0 + R
  81.          IF (T .EQ. 4.0D0) GO TO 20
  82.          S = R/T
  83.          U = 1.0D0 + 2.0D0*S
  84.          P = U*P
  85.          R = (S/U)**2 * R
  86.       GO TO 10
  87.    20 PYTHAG = P
  88.       RETURN
  89.       END
  90.       SUBROUTINE BAKVEC(NM,N,T,E,M,Z,IERR)
  91. C
  92.       INTEGER I,J,M,N,NM,IERR
  93.       DOUBLE PRECISION T(NM,3),E(N),Z(NM,M)
  94. C
  95. C     THIS SUBROUTINE FORMS THE EIGENVECTORS OF A NONSYMMETRIC
  96. C     TRIDIAGONAL MATRIX BY BACK TRANSFORMING THOSE OF THE
  97. C     CORRESPONDING SYMMETRIC MATRIX DETERMINED BY  FIGI.
  98. C
  99. C     ON INPUT
  100. C
  101. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  102. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  103. C          DIMENSION STATEMENT.
  104. C
  105. C        N IS THE ORDER OF THE MATRIX.
  106. C
  107. C        T CONTAINS THE NONSYMMETRIC MATRIX.  ITS SUBDIAGONAL IS
  108. C          STORED IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN,
  109. C          ITS DIAGONAL IN THE N POSITIONS OF THE SECOND COLUMN,
  110. C          AND ITS SUPERDIAGONAL IN THE FIRST N-1 POSITIONS OF
  111. C          THE THIRD COLUMN.  T(1,1) AND T(N,3) ARE ARBITRARY.
  112. C
  113. C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE SYMMETRIC
  114. C          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS ARBITRARY.
  115. C
  116. C        M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
  117. C
  118. C        Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED
  119. C          IN ITS FIRST M COLUMNS.
  120. C
  121. C     ON OUTPUT
  122. C
  123. C        T IS UNALTERED.
  124. C
  125. C        E IS DESTROYED.
  126. C
  127. C        Z CONTAINS THE TRANSFORMED EIGENVECTORS
  128. C          IN ITS FIRST M COLUMNS.
  129. C
  130. C        IERR IS SET TO
  131. C          ZERO       FOR NORMAL RETURN,
  132. C          2*N+I      IF E(I) IS ZERO WITH T(I,1) OR T(I-1,3) NON-ZERO.
  133. C                     IN THIS CASE, THE SYMMETRIC MATRIX IS NOT SIMILAR
  134. C                     TO THE ORIGINAL MATRIX, AND THE EIGENVECTORS
  135. C                     CANNOT BE FOUND BY THIS PROGRAM.
  136. C
  137. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  138. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  139. C
  140. C     THIS VERSION DATED AUGUST 1983.
  141. C
  142. C     ------------------------------------------------------------------
  143. C
  144.       IERR = 0
  145.       IF (M .EQ. 0) GO TO 1001
  146.       E(1) = 1.0D0
  147.       IF (N .EQ. 1) GO TO 1001
  148. C
  149.       DO 100 I = 2, N
  150.          IF (E(I) .NE. 0.0D0) GO TO 80
  151.          IF (T(I,1) .NE. 0.0D0 .OR. T(I-1,3) .NE. 0.0D0) GO TO 1000
  152.          E(I) = 1.0D0
  153.          GO TO 100
  154.    80    E(I) = E(I-1) * E(I) / T(I-1,3)
  155.   100 CONTINUE
  156. C
  157.       DO 120 J = 1, M
  158. C
  159.          DO 120 I = 2, N
  160.          Z(I,J) = Z(I,J) * E(I)
  161.   120 CONTINUE
  162. C
  163.       GO TO 1001
  164. C     .......... SET ERROR -- EIGENVECTORS CANNOT BE
  165. C                FOUND BY THIS PROGRAM ..........
  166.  1000 IERR = 2 * N + I
  167.  1001 RETURN
  168.       END
  169.       SUBROUTINE BALANC(NM,N,A,LOW,IGH,SCALE)
  170. C
  171.       INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
  172.       DOUBLE PRECISION A(NM,N),SCALE(N)
  173.       DOUBLE PRECISION C,F,G,R,S,B2,RADIX
  174.       LOGICAL NOCONV
  175. C
  176. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALANCE,
  177. C     NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
  178. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
  179. C
  180. C     THIS SUBROUTINE BALANCES A REAL MATRIX AND ISOLATES
  181. C     EIGENVALUES WHENEVER POSSIBLE.
  182. C
  183. C     ON INPUT
  184. C
  185. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  186. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  187. C          DIMENSION STATEMENT.
  188. C
  189. C        N IS THE ORDER OF THE MATRIX.
  190. C
  191. C        A CONTAINS THE INPUT MATRIX TO BE BALANCED.
  192. C
  193. C     ON OUTPUT
  194. C
  195. C        A CONTAINS THE BALANCED MATRIX.
  196. C
  197. C        LOW AND IGH ARE TWO INTEGERS SUCH THAT A(I,J)
  198. C          IS EQUAL TO ZERO IF
  199. C           (1) I IS GREATER THAN J AND
  200. C           (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
  201. C
  202. C        SCALE CONTAINS INFORMATION DETERMINING THE
  203. C           PERMUTATIONS AND SCALING FACTORS USED.
  204. C
  205. C     SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
  206. C     HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
  207. C     WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
  208. C     OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J).  THEN
  209. C        SCALE(J) = P(J),    FOR J = 1,...,LOW-1
  210. C                 = D(J,J),      J = LOW,...,IGH
  211. C                 = P(J)         J = IGH+1,...,N.
  212. C     THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
  213. C     THEN 1 TO LOW-1.
  214. C
  215. C     NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
  216. C
  217. C     THE ALGOL PROCEDURE EXC CONTAINED IN BALANCE APPEARS IN
  218. C     BALANC  IN LINE.  (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
  219. C     K,L HAVE BEEN REVERSED.)
  220. C
  221. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  222. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  223. C
  224. C     THIS VERSION DATED AUGUST 1983.
  225. C
  226. C     ------------------------------------------------------------------
  227. C
  228.       RADIX = 16.0D0
  229. C
  230.       B2 = RADIX * RADIX
  231.       K = 1
  232.       L = N
  233.       GO TO 100
  234. C     .......... IN-LINE PROCEDURE FOR ROW AND
  235. C                COLUMN EXCHANGE ..........
  236.    20 SCALE(M) = J
  237.       IF (J .EQ. M) GO TO 50
  238. C
  239.       DO 30 I = 1, L
  240.          F = A(I,J)
  241.          A(I,J) = A(I,M)
  242.          A(I,M) = F
  243.    30 CONTINUE
  244. C
  245.       DO 40 I = K, N
  246.          F = A(J,I)
  247.          A(J,I) = A(M,I)
  248.          A(M,I) = F
  249.    40 CONTINUE
  250. C
  251.    50 GO TO (80,130), IEXC
  252. C     .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
  253. C                AND PUSH THEM DOWN ..........
  254.    80 IF (L .EQ. 1) GO TO 280
  255.       L = L - 1
  256. C     .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
  257.   100 DO 120 JJ = 1, L
  258.          J = L + 1 - JJ
  259. C
  260.          DO 110 I = 1, L
  261.             IF (I .EQ. J) GO TO 110
  262.             IF (A(J,I) .NE. 0.0D0) GO TO 120
  263.   110    CONTINUE
  264. C
  265.          M = L
  266.          IEXC = 1
  267.          GO TO 20
  268.   120 CONTINUE
  269. C
  270.       GO TO 140
  271. C     .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
  272. C                AND PUSH THEM LEFT ..........
  273.   130 K = K + 1
  274. C
  275.   140 DO 170 J = K, L
  276. C
  277.          DO 150 I = K, L
  278.             IF (I .EQ. J) GO TO 150
  279.             IF (A(I,J) .NE. 0.0D0) GO TO 170
  280.   150    CONTINUE
  281. C
  282.          M = K
  283.          IEXC = 2
  284.          GO TO 20
  285.   170 CONTINUE
  286. C     .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
  287.       DO 180 I = K, L
  288.   180 SCALE(I) = 1.0D0
  289. C     .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
  290.   190 NOCONV = .FALSE.
  291. C
  292.       DO 270 I = K, L
  293.          C = 0.0D0
  294.          R = 0.0D0
  295. C
  296.          DO 200 J = K, L
  297.             IF (J .EQ. I) GO TO 200
  298.             C = C + DABS(A(J,I))
  299.             R = R + DABS(A(I,J))
  300.   200    CONTINUE
  301. C     .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
  302.          IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GO TO 270
  303.          G = R / RADIX
  304.          F = 1.0D0
  305.          S = C + R
  306.   210    IF (C .GE. G) GO TO 220
  307.          F = F * RADIX
  308.          C = C * B2
  309.          GO TO 210
  310.   220    G = R * RADIX
  311.   230    IF (C .LT. G) GO TO 240
  312.          F = F / RADIX
  313.          C = C / B2
  314.          GO TO 230
  315. C     .......... NOW BALANCE ..........
  316.   240    IF ((C + R) / F .GE. 0.95D0 * S) GO TO 270
  317.          G = 1.0D0 / F
  318.          SCALE(I) = SCALE(I) * F
  319.          NOCONV = .TRUE.
  320. C
  321.          DO 250 J = K, N
  322.   250    A(I,J) = A(I,J) * G
  323. C
  324.          DO 260 J = 1, L
  325.   260    A(J,I) = A(J,I) * F
  326. C
  327.   270 CONTINUE
  328. C
  329.       IF (NOCONV) GO TO 190
  330. C
  331.   280 LOW = K
  332.       IGH = L
  333.       RETURN
  334.       END
  335.       SUBROUTINE BALBAK(NM,N,LOW,IGH,SCALE,M,Z)
  336. C
  337.       INTEGER I,J,K,M,N,II,NM,IGH,LOW
  338.       DOUBLE PRECISION SCALE(N),Z(NM,M)
  339.       DOUBLE PRECISION S
  340. C
  341. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALBAK,
  342. C     NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
  343. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
  344. C
  345. C     THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL GENERAL
  346. C     MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
  347. C     BALANCED MATRIX DETERMINED BY  BALANC.
  348. C
  349. C     ON INPUT
  350. C
  351. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  352. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  353. C          DIMENSION STATEMENT.
  354. C
  355. C        N IS THE ORDER OF THE MATRIX.
  356. C
  357. C        LOW AND IGH ARE INTEGERS DETERMINED BY  BALANC.
  358. C
  359. C        SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
  360. C          AND SCALING FACTORS USED BY  BALANC.
  361. C
  362. C        M IS THE NUMBER OF COLUMNS OF Z TO BE BACK TRANSFORMED.
  363. C
  364. C        Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGEN-
  365. C          VECTORS TO BE BACK TRANSFORMED IN ITS FIRST M COLUMNS.
  366. C
  367. C     ON OUTPUT
  368. C
  369. C        Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE
  370. C          TRANSFORMED EIGENVECTORS IN ITS FIRST M COLUMNS.
  371. C
  372. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  373. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  374. C
  375. C     THIS VERSION DATED AUGUST 1983.
  376. C
  377. C     ------------------------------------------------------------------
  378. C
  379.       IF (M .EQ. 0) GO TO 200
  380.       IF (IGH .EQ. LOW) GO TO 120
  381. C
  382.       DO 110 I = LOW, IGH
  383.          S = SCALE(I)
  384. C     .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
  385. C                IF THE FOREGOING STATEMENT IS REPLACED BY
  386. C                S=1.0D0/SCALE(I). ..........
  387.          DO 100 J = 1, M
  388.   100    Z(I,J) = Z(I,J) * S
  389. C
  390.   110 CONTINUE
  391. C     ......... FOR I=LOW-1 STEP -1 UNTIL 1,
  392. C               IGH+1 STEP 1 UNTIL N DO -- ..........
  393.   120 DO 140 II = 1, N
  394.          I = II
  395.          IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140
  396.          IF (I .LT. LOW) I = LOW - II
  397.          K = SCALE(I)
  398.          IF (K .EQ. I) GO TO 140
  399. C
  400.          DO 130 J = 1, M
  401.             S = Z(I,J)
  402.             Z(I,J) = Z(K,J)
  403.             Z(K,J) = S
  404.   130    CONTINUE
  405. C
  406.   140 CONTINUE
  407. C
  408.   200 RETURN
  409.       END
  410.       SUBROUTINE BANDR(NM,N,MB,A,D,E,E2,MATZ,Z)
  411. C
  412.       INTEGER J,K,L,N,R,I1,I2,J1,J2,KR,MB,MR,M1,NM,N2,R1,UGL,MAXL,MAXR
  413.       DOUBLE PRECISION A(NM,MB),D(N),E(N),E2(N),Z(NM,N)
  414.       DOUBLE PRECISION G,U,B1,B2,C2,F1,F2,S2,DMIN,DMINRT
  415.       LOGICAL MATZ
  416. C
  417. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BANDRD,
  418. C     NUM. MATH. 12, 231-241(1968) BY SCHWARZ.
  419. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 273-283(1971).
  420. C
  421. C     THIS SUBROUTINE REDUCES A REAL SYMMETRIC BAND MATRIX
  422. C     TO A SYMMETRIC TRIDIAGONAL MATRIX USING AND OPTIONALLY
  423. C     ACCUMULATING ORTHOGONAL SIMILARITY TRANSFORMATIONS.
  424. C
  425. C     ON INPUT
  426. C
  427. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  428. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  429. C          DIMENSION STATEMENT.
  430. C
  431. C        N IS THE ORDER OF THE MATRIX.
  432. C
  433. C        MB IS THE (HALF) BAND WIDTH OF THE MATRIX, DEFINED AS THE
  434. C          NUMBER OF ADJACENT DIAGONALS, INCLUDING THE PRINCIPAL
  435. C          DIAGONAL, REQUIRED TO SPECIFY THE NON-ZERO PORTION OF THE
  436. C          LOWER TRIANGLE OF THE MATRIX.
  437. C
  438. C        A CONTAINS THE LOWER TRIANGLE OF THE SYMMETRIC BAND INPUT
  439. C          MATRIX STORED AS AN N BY MB ARRAY.  ITS LOWEST SUBDIAGONAL
  440. C          IS STORED IN THE LAST N+1-MB POSITIONS OF THE FIRST COLUMN,
  441. C          ITS NEXT SUBDIAGONAL IN THE LAST N+2-MB POSITIONS OF THE
  442. C          SECOND COLUMN, FURTHER SUBDIAGONALS SIMILARLY, AND FINALLY
  443. C          ITS PRINCIPAL DIAGONAL IN THE N POSITIONS OF THE LAST COLUMN.
  444. C          CONTENTS OF STORAGES NOT PART OF THE MATRIX ARE ARBITRARY.
  445. C
  446. C        MATZ SHOULD BE SET TO .TRUE. IF THE TRANSFORMATION MATRIX IS
  447. C          TO BE ACCUMULATED, AND TO .FALSE. OTHERWISE.
  448. C
  449. C     ON OUTPUT
  450. C
  451. C        A HAS BEEN DESTROYED, EXCEPT FOR ITS LAST TWO COLUMNS WHICH
  452. C          CONTAIN A COPY OF THE TRIDIAGONAL MATRIX.
  453. C
  454. C        D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX.
  455. C
  456. C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
  457. C          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS SET TO ZERO.
  458. C
  459. C        E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
  460. C          E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
  461. C
  462. C        Z CONTAINS THE ORTHOGONAL TRANSFORMATION MATRIX PRODUCED IN
  463. C          THE REDUCTION IF MATZ HAS BEEN SET TO .TRUE.  OTHERWISE, Z
  464. C          IS NOT REFERENCED.
  465. C
  466. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  467. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  468. C
  469. C     THIS VERSION DATED AUGUST 1983.
  470. C
  471. C     ------------------------------------------------------------------
  472. C
  473.       DMIN = 2.0D0**(-64)
  474.       DMINRT = 2.0D0**(-32)
  475. C     .......... INITIALIZE DIAGONAL SCALING MATRIX ..........
  476.       DO 30 J = 1, N
  477.    30 D(J) = 1.0D0
  478. C
  479.       IF (.NOT. MATZ) GO TO 60
  480. C
  481.       DO 50 J = 1, N
  482. C
  483.          DO 40 K = 1, N
  484.    40    Z(J,K) = 0.0D0
  485. C
  486.          Z(J,J) = 1.0D0
  487.    50 CONTINUE
  488. C
  489.    60 M1 = MB - 1
  490.       IF (M1 - 1) 900, 800, 70
  491.    70 N2 = N - 2
  492. C
  493.       DO 700 K = 1, N2
  494.          MAXR = MIN0(M1,N-K)
  495. C     .......... FOR R=MAXR STEP -1 UNTIL 2 DO -- ..........
  496.          DO 600 R1 = 2, MAXR
  497.             R = MAXR + 2 - R1
  498.             KR = K + R
  499.             MR = MB - R
  500.             G = A(KR,MR)
  501.             A(KR-1,1) = A(KR-1,MR+1)
  502.             UGL = K
  503. C
  504.             DO 500 J = KR, N, M1
  505.                J1 = J - 1
  506.                J2 = J1 - 1
  507.                IF (G .EQ. 0.0D0) GO TO 600
  508.                B1 = A(J1,1) / G
  509.                B2 = B1 * D(J1) / D(J)
  510.                S2 = 1.0D0 / (1.0D0 + B1 * B2)
  511.                IF (S2 .GE. 0.5D0 ) GO TO 450
  512.                B1 = G / A(J1,1)
  513.                B2 = B1 * D(J) / D(J1)
  514.                C2 = 1.0D0 - S2
  515.                D(J1) = C2 * D(J1)
  516.                D(J) = C2 * D(J)
  517.                F1 = 2.0D0 * A(J,M1)
  518.                F2 = B1 * A(J1,MB)
  519.                A(J,M1) = -B2 * (B1 * A(J,M1) - A(J,MB)) - F2 + A(J,M1)
  520.                A(J1,MB) = B2 * (B2 * A(J,MB) + F1) + A(J1,MB)
  521.                A(J,MB) = B1 * (F2 - F1) + A(J,MB)
  522. C
  523.                DO 200 L = UGL, J2
  524.                   I2 = MB - J + L
  525.                   U = A(J1,I2+1) + B2 * A(J,I2)
  526.                   A(J,I2) = -B1 * A(J1,I2+1) + A(J,I2)
  527.                   A(J1,I2+1) = U
  528.   200          CONTINUE
  529. C
  530.                UGL = J
  531.                A(J1,1) = A(J1,1) + B2 * G
  532.                IF (J .EQ. N) GO TO 350
  533.                MAXL = MIN0(M1,N-J1)
  534. C
  535.                DO 300 L = 2, MAXL
  536.                   I1 = J1 + L
  537.                   I2 = MB - L
  538.                   U = A(I1,I2) + B2 * A(I1,I2+1)
  539.                   A(I1,I2+1) = -B1 * A(I1,I2) + A(I1,I2+1)
  540.                   A(I1,I2) = U
  541.   300          CONTINUE
  542. C
  543.                I1 = J + M1
  544.                IF (I1 .GT. N) GO TO 350
  545.                G = B2 * A(I1,1)
  546.   350          IF (.NOT. MATZ) GO TO 500
  547. C
  548.                DO 400 L = 1, N
  549.                   U = Z(L,J1) + B2 * Z(L,J)
  550.                   Z(L,J) = -B1 * Z(L,J1) + Z(L,J)
  551.                   Z(L,J1) = U
  552.   400          CONTINUE
  553. C
  554.                GO TO 500
  555. C
  556.   450          U = D(J1)
  557.                D(J1) = S2 * D(J)
  558.                D(J) = S2 * U
  559.                F1 = 2.0D0 * A(J,M1)
  560.                F2 = B1 * A(J,MB)
  561.                U = B1 * (F2 - F1) + A(J1,MB)
  562.                A(J,M1) = B2 * (B1 * A(J,M1) - A(J1,MB)) + F2 - A(J,M1)
  563.                A(J1,MB) = B2 * (B2 * A(J1,MB) + F1) + A(J,MB)
  564.                A(J,MB) = U
  565. C
  566.                DO 460 L = UGL, J2
  567.                   I2 = MB - J + L
  568.                   U = B2 * A(J1,I2+1) + A(J,I2)
  569.                   A(J,I2) = -A(J1,I2+1) + B1 * A(J,I2)
  570.                   A(J1,I2+1) = U
  571.   460          CONTINUE
  572. C
  573.                UGL = J
  574.                A(J1,1) = B2 * A(J1,1) + G
  575.                IF (J .EQ. N) GO TO 480
  576.                MAXL = MIN0(M1,N-J1)
  577. C
  578.                DO 470 L = 2, MAXL
  579.                   I1 = J1 + L
  580.                   I2 = MB - L
  581.                   U = B2 * A(I1,I2) + A(I1,I2+1)
  582.                   A(I1,I2+1) = -A(I1,I2) + B1 * A(I1,I2+1)
  583.                   A(I1,I2) = U
  584.   470          CONTINUE
  585. C
  586.                I1 = J + M1
  587.                IF (I1 .GT. N) GO TO 480
  588.                G = A(I1,1)
  589.                A(I1,1) = B1 * A(I1,1)
  590.   480          IF (.NOT. MATZ) GO TO 500
  591. C
  592.                DO 490 L = 1, N
  593.                   U = B2 * Z(L,J1) + Z(L,J)
  594.                   Z(L,J) = -Z(L,J1) + B1 * Z(L,J)
  595.                   Z(L,J1) = U
  596.   490          CONTINUE
  597. C
  598.   500       CONTINUE
  599. C
  600.   600    CONTINUE
  601. C
  602.          IF (MOD(K,64) .NE. 0) GO TO 700
  603. C     .......... RESCALE TO AVOID UNDERFLOW OR OVERFLOW ..........
  604.          DO 650 J = K, N
  605.             IF (D(J) .GE. DMIN) GO TO 650
  606.             MAXL = MAX0(1,MB+1-J)
  607. C
  608.             DO 610 L = MAXL, M1
  609.   610       A(J,L) = DMINRT * A(J,L)
  610. C
  611.             IF (J .EQ. N) GO TO 630
  612.             MAXL = MIN0(M1,N-J)
  613. C
  614.             DO 620 L = 1, MAXL
  615.                I1 = J + L
  616.                I2 = MB - L
  617.                A(I1,I2) = DMINRT * A(I1,I2)
  618.   620       CONTINUE
  619. C
  620.   630       IF (.NOT. MATZ) GO TO 645
  621. C
  622.             DO 640 L = 1, N
  623.   640       Z(L,J) = DMINRT * Z(L,J)
  624. C
  625.   645       A(J,MB) = DMIN * A(J,MB)
  626.             D(J) = D(J) / DMIN
  627.   650    CONTINUE
  628. C
  629.   700 CONTINUE
  630. C     .......... FORM SQUARE ROOT OF SCALING MATRIX ..........
  631.   800 DO 810 J = 2, N
  632.   810 E(J) = DSQRT(D(J))
  633. C
  634.       IF (.NOT. MATZ) GO TO 840
  635. C
  636.       DO 830 J = 1, N
  637. C
  638.          DO 820 K = 2, N
  639.   820    Z(J,K) = E(K) * Z(J,K)
  640. C
  641.   830 CONTINUE
  642. C
  643.   840 U = 1.0D0
  644. C
  645.       DO 850 J = 2, N
  646.          A(J,M1) = U * E(J) * A(J,M1)
  647.          U = E(J)
  648.          E2(J) = A(J,M1) ** 2
  649.          A(J,MB) = D(J) * A(J,MB)
  650.          D(J) = A(J,MB)
  651.          E(J) = A(J,M1)
  652.   850 CONTINUE
  653. C
  654.       D(1) = A(1,MB)
  655.       E(1) = 0.0D0
  656.       E2(1) = 0.0D0
  657.       GO TO 1001
  658. C
  659.   900 DO 950 J = 1, N
  660.          D(J) = A(J,MB)
  661.          E(J) = 0.0D0
  662.          E2(J) = 0.0D0
  663.   950 CONTINUE
  664. C
  665.  1001 RETURN
  666.       END
  667.       SUBROUTINE BANDV(NM,N,MBW,A,E21,M,W,Z,IERR,NV,RV,RV6)
  668. C
  669.       INTEGER I,J,K,M,N,R,II,IJ,JJ,KJ,MB,M1,NM,NV,IJ1,ITS,KJ1,MBW,M21,
  670.      X        IERR,MAXJ,MAXK,GROUP
  671.       DOUBLE PRECISION A(NM,MBW),W(M),Z(NM,M),RV(NV),RV6(N)
  672.       DOUBLE PRECISION U,V,UK,XU,X0,X1,E21,EPS2,EPS3,EPS4,NORM,ORDER,
  673.      X       EPSLON,PYTHAG
  674. C
  675. C     THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A REAL SYMMETRIC
  676. C     BAND MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES, USING INVERSE
  677. C     ITERATION.  THE SUBROUTINE MAY ALSO BE USED TO SOLVE SYSTEMS
  678. C     OF LINEAR EQUATIONS WITH A SYMMETRIC OR NON-SYMMETRIC BAND
  679. C     COEFFICIENT MATRIX.
  680. C
  681. C     ON INPUT
  682. C
  683. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  684. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  685. C          DIMENSION STATEMENT.
  686. C
  687. C        N IS THE ORDER OF THE MATRIX.
  688. C
  689. C        MBW IS THE NUMBER OF COLUMNS OF THE ARRAY A USED TO STORE THE
  690. C          BAND MATRIX.  IF THE MATRIX IS SYMMETRIC, MBW IS ITS (HALF)
  691. C          BAND WIDTH, DENOTED MB AND DEFINED AS THE NUMBER OF ADJACENT
  692. C          DIAGONALS, INCLUDING THE PRINCIPAL DIAGONAL, REQUIRED TO
  693. C          SPECIFY THE NON-ZERO PORTION OF THE LOWER TRIANGLE OF THE
  694. C          MATRIX.  IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS
  695. C          OF LINEAR EQUATIONS AND THE COEFFICIENT MATRIX IS NOT
  696. C          SYMMETRIC, IT MUST HOWEVER HAVE THE SAME NUMBER OF ADJACENT
  697. C          DIAGONALS ABOVE THE MAIN DIAGONAL AS BELOW, AND IN THIS
  698. C          CASE, MBW=2*MB-1.
  699. C
  700. C        A CONTAINS THE LOWER TRIANGLE OF THE SYMMETRIC BAND INPUT
  701. C          MATRIX STORED AS AN N BY MB ARRAY.  ITS LOWEST SUBDIAGONAL
  702. C          IS STORED IN THE LAST N+1-MB POSITIONS OF THE FIRST COLUMN,
  703. C          ITS NEXT SUBDIAGONAL IN THE LAST N+2-MB POSITIONS OF THE
  704. C          SECOND COLUMN, FURTHER SUBDIAGONALS SIMILARLY, AND FINALLY
  705. C          ITS PRINCIPAL DIAGONAL IN THE N POSITIONS OF COLUMN MB.
  706. C          IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS OF LINEAR
  707. C          EQUATIONS AND THE COEFFICIENT MATRIX IS NOT SYMMETRIC, A IS
  708. C          N BY 2*MB-1 INSTEAD WITH LOWER TRIANGLE AS ABOVE AND WITH
  709. C          ITS FIRST SUPERDIAGONAL STORED IN THE FIRST N-1 POSITIONS OF
  710. C          COLUMN MB+1, ITS SECOND SUPERDIAGONAL IN THE FIRST N-2
  711. C          POSITIONS OF COLUMN MB+2, FURTHER SUPERDIAGONALS SIMILARLY,
  712. C          AND FINALLY ITS HIGHEST SUPERDIAGONAL IN THE FIRST N+1-MB
  713. C          POSITIONS OF THE LAST COLUMN.
  714. C          CONTENTS OF STORAGES NOT PART OF THE MATRIX ARE ARBITRARY.
  715. C
  716. C        E21 SPECIFIES THE ORDERING OF THE EIGENVALUES AND CONTAINS
  717. C            0.0D0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, OR
  718. C            2.0D0 IF THE EIGENVALUES ARE IN DESCENDING ORDER.
  719. C          IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS OF LINEAR
  720. C          EQUATIONS, E21 SHOULD BE SET TO 1.0D0 IF THE COEFFICIENT
  721. C          MATRIX IS SYMMETRIC AND TO -1.0D0 IF NOT.
  722. C
  723. C        M IS THE NUMBER OF SPECIFIED EIGENVALUES OR THE NUMBER OF
  724. C          SYSTEMS OF LINEAR EQUATIONS.
  725. C
  726. C        W CONTAINS THE M EIGENVALUES IN ASCENDING OR DESCENDING ORDER.
  727. C          IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS OF LINEAR
  728. C          EQUATIONS (A-W(R)*I)*X(R)=B(R), WHERE I IS THE IDENTITY
  729. C          MATRIX, W(R) SHOULD BE SET ACCORDINGLY, FOR R=1,2,...,M.
  730. C
  731. C        Z CONTAINS THE CONSTANT MATRIX COLUMNS (B(R),R=1,2,...,M), IF
  732. C          THE SUBROUTINE IS USED TO SOLVE SYSTEMS OF LINEAR EQUATIONS.
  733. C
  734. C        NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER RV
  735. C          AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT.
  736. C
  737. C     ON OUTPUT
  738. C
  739. C        A AND W ARE UNALTERED.
  740. C
  741. C        Z CONTAINS THE ASSOCIATED SET OF ORTHOGONAL EIGENVECTORS.
  742. C          ANY VECTOR WHICH FAILS TO CONVERGE IS SET TO ZERO.  IF THE
  743. C          SUBROUTINE IS USED TO SOLVE SYSTEMS OF LINEAR EQUATIONS,
  744. C          Z CONTAINS THE SOLUTION MATRIX COLUMNS (X(R),R=1,2,...,M).
  745. C
  746. C        IERR IS SET TO
  747. C          ZERO       FOR NORMAL RETURN,
  748. C          -R         IF THE EIGENVECTOR CORRESPONDING TO THE R-TH
  749. C                     EIGENVALUE FAILS TO CONVERGE, OR IF THE R-TH
  750. C                     SYSTEM OF LINEAR EQUATIONS IS NEARLY SINGULAR.
  751. C
  752. C        RV AND RV6 ARE TEMPORARY STORAGE ARRAYS.  NOTE THAT RV IS
  753. C          OF DIMENSION AT LEAST N*(2*MB-1).  IF THE SUBROUTINE
  754. C          IS BEING USED TO SOLVE SYSTEMS OF LINEAR EQUATIONS, THE
  755. C          DETERMINANT (UP TO SIGN) OF A-W(M)*I IS AVAILABLE, UPON
  756. C          RETURN, AS THE PRODUCT OF THE FIRST N ELEMENTS OF RV.
  757. C
  758. C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
  759. C
  760. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  761. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  762. C
  763. C     THIS VERSION DATED AUGUST 1983.
  764. C
  765. C     ------------------------------------------------------------------
  766. C
  767.       IERR = 0
  768.       IF (M .EQ. 0) GO TO 1001
  769.       MB = MBW
  770.       IF (E21 .LT. 0.0D0) MB = (MBW + 1) / 2
  771.       M1 = MB - 1
  772.       M21 = M1 + MB
  773.       ORDER = 1.0D0 - DABS(E21)
  774. C     .......... FIND VECTORS BY INVERSE ITERATION ..........
  775.       DO 920 R = 1, M
  776.          ITS = 1
  777.          X1 = W(R)
  778.          IF (R .NE. 1) GO TO 100
  779. C     .......... COMPUTE NORM OF MATRIX ..........
  780.          NORM = 0.0D0
  781. C
  782.          DO 60 J = 1, MB
  783.             JJ = MB + 1 - J
  784.             KJ = JJ + M1
  785.             IJ = 1
  786.             V = 0.0D0
  787. C
  788.             DO 40 I = JJ, N
  789.                V = V + DABS(A(I,J))
  790.                IF (E21 .GE. 0.0D0) GO TO 40
  791.                V = V + DABS(A(IJ,KJ))
  792.                IJ = IJ + 1
  793.    40       CONTINUE
  794. C
  795.             NORM = DMAX1(NORM,V)
  796.    60    CONTINUE
  797. C
  798.          IF (E21 .LT. 0.0D0) NORM = 0.5D0 * NORM
  799. C     .......... EPS2 IS THE CRITERION FOR GROUPING,
  800. C                EPS3 REPLACES ZERO PIVOTS AND EQUAL
  801. C                ROOTS ARE MODIFIED BY EPS3,
  802. C                EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW ..........
  803.          IF (NORM .EQ. 0.0D0) NORM = 1.0D0
  804.          EPS2 = 1.0D-3 * NORM * DABS(ORDER)
  805.          EPS3 = EPSLON(NORM)
  806.          UK = N
  807.          UK = DSQRT(UK)
  808.          EPS4 = UK * EPS3
  809.    80    GROUP = 0
  810.          GO TO 120
  811. C     .......... LOOK FOR CLOSE OR COINCIDENT ROOTS ..........
  812.   100    IF (DABS(X1-X0) .GE. EPS2) GO TO 80
  813.          GROUP = GROUP + 1
  814.          IF (ORDER * (X1 - X0) .LE. 0.0D0) X1 = X0 + ORDER * EPS3
  815. C     .......... EXPAND MATRIX, SUBTRACT EIGENVALUE,
  816. C                AND INITIALIZE VECTOR ..........
  817.   120    DO 200 I = 1, N
  818.             IJ = I + MIN0(0,I-M1) * N
  819.             KJ = IJ + MB * N
  820.             IJ1 = KJ + M1 * N
  821.             IF (M1 .EQ. 0) GO TO 180
  822. C
  823.             DO 150 J = 1, M1
  824.                IF (IJ .GT. M1) GO TO 125
  825.                IF (IJ .GT. 0) GO TO 130
  826.                RV(IJ1) = 0.0D0
  827.                IJ1 = IJ1 + N
  828.                GO TO 130
  829.   125          RV(IJ) = A(I,J)
  830.   130          IJ = IJ + N
  831.                II = I + J
  832.                IF (II .GT. N) GO TO 150
  833.                JJ = MB - J
  834.                IF (E21 .GE. 0.0D0) GO TO 140
  835.                II = I
  836.                JJ = MB + J
  837.   140          RV(KJ) = A(II,JJ)
  838.                KJ = KJ + N
  839.   150       CONTINUE
  840. C
  841.   180       RV(IJ) = A(I,MB) - X1
  842.             RV6(I) = EPS4
  843.             IF (ORDER .EQ. 0.0D0) RV6(I) = Z(I,R)
  844.   200    CONTINUE
  845. C
  846.          IF (M1 .EQ. 0) GO TO 600
  847. C     .......... ELIMINATION WITH INTERCHANGES ..........
  848.          DO 580 I = 1, N
  849.             II = I + 1
  850.             MAXK = MIN0(I+M1-1,N)
  851.             MAXJ = MIN0(N-I,M21-2) * N
  852. C
  853.             DO 360 K = I, MAXK
  854.                KJ1 = K
  855.                J = KJ1 + N
  856.                JJ = J + MAXJ
  857. C
  858.                DO 340 KJ = J, JJ, N
  859.                   RV(KJ1) = RV(KJ)
  860.                   KJ1 = KJ
  861.   340          CONTINUE
  862. C
  863.                RV(KJ1) = 0.0D0
  864.   360       CONTINUE
  865. C
  866.             IF (I .EQ. N) GO TO 580
  867.             U = 0.0D0
  868.             MAXK = MIN0(I+M1,N)
  869.             MAXJ = MIN0(N-II,M21-2) * N
  870. C
  871.             DO 450 J = I, MAXK
  872.                IF (DABS(RV(J)) .LT. DABS(U)) GO TO 450
  873.                U = RV(J)
  874.                K = J
  875.   450       CONTINUE
  876. C
  877.             J = I + N
  878.             JJ = J + MAXJ
  879.             IF (K .EQ. I) GO TO 520
  880.             KJ = K
  881. C
  882.             DO 500 IJ = I, JJ, N
  883.                V = RV(IJ)
  884.                RV(IJ) = RV(KJ)
  885.                RV(KJ) = V
  886.                KJ = KJ + N
  887.   500       CONTINUE
  888. C
  889.             IF (ORDER .NE. 0.0D0) GO TO 520
  890.             V = RV6(I)
  891.             RV6(I) = RV6(K)
  892.             RV6(K) = V
  893.   520       IF (U .EQ. 0.0D0) GO TO 580
  894. C
  895.             DO 560 K = II, MAXK
  896.                V = RV(K) / U
  897.                KJ = K
  898. C
  899.                DO 540 IJ = J, JJ, N
  900.                   KJ = KJ + N
  901.                   RV(KJ) = RV(KJ) - V * RV(IJ)
  902.   540          CONTINUE
  903. C
  904.                IF (ORDER .EQ. 0.0D0) RV6(K) = RV6(K) - V * RV6(I)
  905.   560       CONTINUE
  906. C
  907.   580    CONTINUE
  908. C     .......... BACK SUBSTITUTION
  909. C                FOR I=N STEP -1 UNTIL 1 DO -- ..........
  910.   600    DO 630 II = 1, N
  911.             I = N + 1 - II
  912.             MAXJ = MIN0(II,M21)
  913.             IF (MAXJ .EQ. 1) GO TO 620
  914.             IJ1 = I
  915.             J = IJ1 + N
  916.             JJ = J + (MAXJ - 2) * N
  917. C
  918.             DO 610 IJ = J, JJ, N
  919.                IJ1 = IJ1 + 1
  920.                RV6(I) = RV6(I) - RV(IJ) * RV6(IJ1)
  921.   610       CONTINUE
  922. C
  923.   620       V = RV(I)
  924.             IF (DABS(V) .GE. EPS3) GO TO 625
  925. C     .......... SET ERROR -- NEARLY SINGULAR LINEAR SYSTEM ..........
  926.             IF (ORDER .EQ. 0.0D0) IERR = -R
  927.             V = DSIGN(EPS3,V)
  928.   625       RV6(I) = RV6(I) / V
  929.   630    CONTINUE
  930. C
  931.          XU = 1.0D0
  932.          IF (ORDER .EQ. 0.0D0) GO TO 870
  933. C     .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS
  934. C                MEMBERS OF GROUP ..........
  935.          IF (GROUP .EQ. 0) GO TO 700
  936. C
  937.          DO 680 JJ = 1, GROUP
  938.             J = R - GROUP - 1 + JJ
  939.             XU = 0.0D0
  940. C
  941.             DO 640 I = 1, N
  942.   640       XU = XU + RV6(I) * Z(I,J)
  943. C
  944.             DO 660 I = 1, N
  945.   660       RV6(I) = RV6(I) - XU * Z(I,J)
  946. C
  947.   680    CONTINUE
  948. C
  949.   700    NORM = 0.0D0
  950. C
  951.          DO 720 I = 1, N
  952.   720    NORM = NORM + DABS(RV6(I))
  953. C
  954.          IF (NORM .GE. 0.1D0) GO TO 840
  955. C     .......... IN-LINE PROCEDURE FOR CHOOSING
  956. C                A NEW STARTING VECTOR ..........
  957.          IF (ITS .GE. N) GO TO 830
  958.          ITS = ITS + 1
  959.          XU = EPS4 / (UK + 1.0D0)
  960.          RV6(1) = EPS4
  961. C
  962.          DO 760 I = 2, N
  963.   760    RV6(I) = XU
  964. C
  965.          RV6(ITS) = RV6(ITS) - EPS4 * UK
  966.          GO TO 600
  967. C     .......... SET ERROR -- NON-CONVERGED EIGENVECTOR ..........
  968.   830    IERR = -R
  969.          XU = 0.0D0
  970.          GO TO 870
  971. C     .......... NORMALIZE SO THAT SUM OF SQUARES IS
  972. C                1 AND EXPAND TO FULL ORDER ..........
  973.   840    U = 0.0D0
  974. C
  975.          DO 860 I = 1, N
  976.   860    U = PYTHAG(U,RV6(I))
  977. C
  978.          XU = 1.0D0 / U
  979. C
  980.   870    DO 900 I = 1, N
  981.   900    Z(I,R) = RV6(I) * XU
  982. C
  983.          X0 = X1
  984.   920 CONTINUE
  985. C
  986.  1001 RETURN
  987.       END
  988.       SUBROUTINE BISECT(N,EPS1,D,E,E2,LB,UB,MM,M,W,IND,IERR,RV4,RV5)
  989. C
  990.       INTEGER I,J,K,L,M,N,P,Q,R,S,II,MM,M1,M2,TAG,IERR,ISTURM
  991.       DOUBLE PRECISION D(N),E(N),E2(N),W(MM),RV4(N),RV5(N)
  992.       DOUBLE PRECISION U,V,LB,T1,T2,UB,XU,X0,X1,EPS1,TST1,TST2,EPSLON
  993.       INTEGER IND(MM)
  994. C
  995. C     THIS SUBROUTINE IS A TRANSLATION OF THE BISECTION TECHNIQUE
  996. C     IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON.
  997. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971).
  998. C
  999. C     THIS SUBROUTINE FINDS THOSE EIGENVALUES OF A TRIDIAGONAL
  1000. C     SYMMETRIC MATRIX WHICH LIE IN A SPECIFIED INTERVAL,
  1001. C     USING BISECTION.
  1002. C
  1003. C     ON INPUT
  1004. C
  1005. C        N IS THE ORDER OF THE MATRIX.
  1006. C
  1007. C        EPS1 IS AN ABSOLUTE ERROR TOLERANCE FOR THE COMPUTED
  1008. C          EIGENVALUES.  IF THE INPUT EPS1 IS NON-POSITIVE,
  1009. C          IT IS RESET FOR EACH SUBMATRIX TO A DEFAULT VALUE,
  1010. C          NAMELY, MINUS THE PRODUCT OF THE RELATIVE MACHINE
  1011. C          PRECISION AND THE 1-NORM OF THE SUBMATRIX.
  1012. C
  1013. C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
  1014. C
  1015. C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
  1016. C          IN ITS LAST N-1 POSITIONS.  E(1) IS ARBITRARY.
  1017. C
  1018. C        E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
  1019. C          E2(1) IS ARBITRARY.
  1020. C
  1021. C        LB AND UB DEFINE THE INTERVAL TO BE SEARCHED FOR EIGENVALUES.
  1022. C          IF LB IS NOT LESS THAN UB, NO EIGENVALUES WILL BE FOUND.
  1023. C
  1024. C        MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF
  1025. C          EIGENVALUES IN THE INTERVAL.  WARNING. IF MORE THAN
  1026. C          MM EIGENVALUES ARE DETERMINED TO LIE IN THE INTERVAL,
  1027. C          AN ERROR RETURN IS MADE WITH NO EIGENVALUES FOUND.
  1028. C
  1029. C     ON OUTPUT
  1030. C
  1031. C        EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS
  1032. C          (LAST) DEFAULT VALUE.
  1033. C
  1034. C        D AND E ARE UNALTERED.
  1035. C
  1036. C        ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED
  1037. C          AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE
  1038. C          MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES.
  1039. C          E2(1) IS ALSO SET TO ZERO.
  1040. C
  1041. C        M IS THE NUMBER OF EIGENVALUES DETERMINED TO LIE IN (LB,UB).
  1042. C
  1043. C        W CONTAINS THE M EIGENVALUES IN ASCENDING ORDER.
  1044. C
  1045. C        IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES
  1046. C          ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W --
  1047. C          1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM
  1048. C          THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC..
  1049. C
  1050. C        IERR IS SET TO
  1051. C          ZERO       FOR NORMAL RETURN,
  1052. C          3*N+1      IF M EXCEEDS MM.
  1053. C
  1054. C        RV4 AND RV5 ARE TEMPORARY STORAGE ARRAYS.
  1055. C
  1056. C     THE ALGOL PROCEDURE STURMCNT CONTAINED IN TRISTURM
  1057. C     APPEARS IN BISECT IN-LINE.
  1058. C
  1059. C     NOTE THAT SUBROUTINE TQL1 OR IMTQL1 IS GENERALLY FASTER THAN
  1060. C     BISECT, IF MORE THAN N/4 EIGENVALUES ARE TO BE FOUND.
  1061. C
  1062. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  1063. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  1064. C
  1065. C     THIS VERSION DATED AUGUST 1983.
  1066. C
  1067. C     ------------------------------------------------------------------
  1068. C
  1069.       IERR = 0
  1070.       TAG = 0
  1071.       T1 = LB
  1072.       T2 = UB
  1073. C     .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES ..........
  1074.       DO 40 I = 1, N
  1075.          IF (I .EQ. 1) GO TO 20
  1076.          TST1 = DABS(D(I)) + DABS(D(I-1))
  1077.          TST2 = TST1 + DABS(E(I))
  1078.          IF (TST2 .GT. TST1) GO TO 40
  1079.    20    E2(I) = 0.0D0
  1080.    40 CONTINUE
  1081. C     .......... DETERMINE THE NUMBER OF EIGENVALUES
  1082. C                IN THE INTERVAL ..........
  1083.       P = 1
  1084.       Q = N
  1085.       X1 = UB
  1086.       ISTURM = 1
  1087.       GO TO 320
  1088.    60 M = S
  1089.       X1 = LB
  1090.       ISTURM = 2
  1091.       GO TO 320
  1092.    80 M = M - S
  1093.       IF (M .GT. MM) GO TO 980
  1094.       Q = 0
  1095.       R = 0
  1096. C     .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING
  1097. C                INTERVAL BY THE GERSCHGORIN BOUNDS ..........
  1098.   100 IF (R .EQ. M) GO TO 1001
  1099.       TAG = TAG + 1
  1100.       P = Q + 1
  1101.       XU = D(P)
  1102.       X0 = D(P)
  1103.       U = 0.0D0
  1104. C
  1105.       DO 120 Q = P, N
  1106.          X1 = U
  1107.          U = 0.0D0
  1108.          V = 0.0D0
  1109.          IF (Q .EQ. N) GO TO 110
  1110.          U = DABS(E(Q+1))
  1111.          V = E2(Q+1)
  1112.   110    XU = DMIN1(D(Q)-(X1+U),XU)
  1113.          X0 = DMAX1(D(Q)+(X1+U),X0)
  1114.          IF (V .EQ. 0.0D0) GO TO 140
  1115.   120 CONTINUE
  1116. C
  1117.   140 X1 = EPSLON(DMAX1(DABS(XU),DABS(X0)))
  1118.       IF (EPS1 .LE. 0.0D0) EPS1 = -X1
  1119.       IF (P .NE. Q) GO TO 180
  1120. C     .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL ..........
  1121.       IF (T1 .GT. D(P) .OR. D(P) .GE. T2) GO TO 940
  1122.       M1 = P
  1123.       M2 = P
  1124.       RV5(P) = D(P)
  1125.       GO TO 900
  1126.   180 X1 = X1 * (Q - P + 1)
  1127.       LB = DMAX1(T1,XU-X1)
  1128.       UB = DMIN1(T2,X0+X1)
  1129.       X1 = LB
  1130.       ISTURM = 3
  1131.       GO TO 320
  1132.   200 M1 = S + 1
  1133.       X1 = UB
  1134.       ISTURM = 4
  1135.       GO TO 320
  1136.   220 M2 = S
  1137.       IF (M1 .GT. M2) GO TO 940
  1138. C     .......... FIND ROOTS BY BISECTION ..........
  1139.       X0 = UB
  1140.       ISTURM = 5
  1141. C
  1142.       DO 240 I = M1, M2
  1143.          RV5(I) = UB
  1144.          RV4(I) = LB
  1145.   240 CONTINUE
  1146. C     .......... LOOP FOR K-TH EIGENVALUE
  1147. C                FOR K=M2 STEP -1 UNTIL M1 DO --
  1148. C                (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) ..........
  1149.       K = M2
  1150.   250    XU = LB
  1151. C     .......... FOR I=K STEP -1 UNTIL M1 DO -- ..........
  1152.          DO 260 II = M1, K
  1153.             I = M1 + K - II
  1154.             IF (XU .GE. RV4(I)) GO TO 260
  1155.             XU = RV4(I)
  1156.             GO TO 280
  1157.   260    CONTINUE
  1158. C
  1159.   280    IF (X0 .GT. RV5(K)) X0 = RV5(K)
  1160. C     .......... NEXT BISECTION STEP ..........
  1161.   300    X1 = (XU + X0) * 0.5D0
  1162.          IF ((X0 - XU) .LE. DABS(EPS1)) GO TO 420
  1163.          TST1 = 2.0D0 * (DABS(XU) + DABS(X0))
  1164.          TST2 = TST1 + (X0 - XU)
  1165.          IF (TST2 .EQ. TST1) GO TO 420
  1166. C     .......... IN-LINE PROCEDURE FOR STURM SEQUENCE ..........
  1167.   320    S = P - 1
  1168.          U = 1.0D0
  1169. C
  1170.          DO 340 I = P, Q
  1171.             IF (U .NE. 0.0D0) GO TO 325
  1172.             V = DABS(E(I)) / EPSLON(1.0D0)
  1173.             IF (E2(I) .EQ. 0.0D0) V = 0.0D0
  1174.             GO TO 330
  1175.   325       V = E2(I) / U
  1176.   330       U = D(I) - X1 - V
  1177.             IF (U .LT. 0.0D0) S = S + 1
  1178.   340    CONTINUE
  1179. C
  1180.          GO TO (60,80,200,220,360), ISTURM
  1181. C     .......... REFINE INTERVALS ..........
  1182.   360    IF (S .GE. K) GO TO 400
  1183.          XU = X1
  1184.          IF (S .GE. M1) GO TO 380
  1185.          RV4(M1) = X1
  1186.          GO TO 300
  1187.   380    RV4(S+1) = X1
  1188.          IF (RV5(S) .GT. X1) RV5(S) = X1
  1189.          GO TO 300
  1190.   400    X0 = X1
  1191.          GO TO 300
  1192. C     .......... K-TH EIGENVALUE FOUND ..........
  1193.   420    RV5(K) = X1
  1194.       K = K - 1
  1195.       IF (K .GE. M1) GO TO 250
  1196. C     .......... ORDER EIGENVALUES TAGGED WITH THEIR
  1197. C                SUBMATRIX ASSOCIATIONS ..........
  1198.   900 S = R
  1199.       R = R + M2 - M1 + 1
  1200.       J = 1
  1201.       K = M1
  1202. C
  1203.       DO 920 L = 1, R
  1204.          IF (J .GT. S) GO TO 910
  1205.          IF (K .GT. M2) GO TO 940
  1206.          IF (RV5(K) .GE. W(L)) GO TO 915
  1207. C
  1208.          DO 905 II = J, S
  1209.             I = L + S - II
  1210.             W(I+1) = W(I)
  1211.             IND(I+1) = IND(I)
  1212.   905    CONTINUE
  1213. C
  1214.   910    W(L) = RV5(K)
  1215.          IND(L) = TAG
  1216.          K = K + 1
  1217.          GO TO 920
  1218.   915    J = J + 1
  1219.   920 CONTINUE
  1220. C
  1221.   940 IF (Q .LT. N) GO TO 100
  1222.       GO TO 1001
  1223. C     .......... SET ERROR -- UNDERESTIMATE OF NUMBER OF
  1224. C                EIGENVALUES IN INTERVAL ..........
  1225.   980 IERR = 3 * N + 1
  1226.  1001 LB = T1
  1227.       UB = T2
  1228.       RETURN
  1229.       END
  1230.       SUBROUTINE BQR(NM,N,MB,A,T,R,IERR,NV,RV)
  1231. C
  1232.       INTEGER I,J,K,L,M,N,II,IK,JK,JM,KJ,KK,KM,LL,MB,MK,MN,MZ,
  1233.      X        M1,M2,M3,M4,NI,NM,NV,ITS,KJ1,M21,M31,IERR,IMULT
  1234.       DOUBLE PRECISION A(NM,MB),RV(NV)
  1235.       DOUBLE PRECISION F,G,Q,R,S,T,TST1,TST2,SCALE,PYTHAG
  1236. C
  1237. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BQR,
  1238. C     NUM. MATH. 16, 85-92(1970) BY MARTIN, REINSCH, AND WILKINSON.
  1239. C     HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 266-272(1971).
  1240. C
  1241. C     THIS SUBROUTINE FINDS THE EIGENVALUE OF SMALLEST (USUALLY)
  1242. C     MAGNITUDE OF A REAL SYMMETRIC BAND MATRIX USING THE
  1243. C     QR ALGORITHM WITH SHIFTS OF ORIGIN.  CONSECUTIVE CALLS
  1244. C     CAN BE MADE TO FIND FURTHER EIGENVALUES.
  1245. C
  1246. C     ON INPUT
  1247. C
  1248. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  1249. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  1250. C          DIMENSION STATEMENT.
  1251. C
  1252. C        N IS THE ORDER OF THE MATRIX.
  1253. C
  1254. C        MB IS THE (HALF) BAND WIDTH OF THE MATRIX, DEFINED AS THE
  1255. C          NUMBER OF ADJACENT DIAGONALS, INCLUDING THE PRINCIPAL
  1256. C          DIAGONAL, REQUIRED TO SPECIFY THE NON-ZERO PORTION OF THE
  1257. C          LOWER TRIANGLE OF THE MATRIX.
  1258. C
  1259. C        A CONTAINS THE LOWER TRIANGLE OF THE SYMMETRIC BAND INPUT
  1260. C          MATRIX STORED AS AN N BY MB ARRAY.  ITS LOWEST SUBDIAGONAL
  1261. C          IS STORED IN THE LAST N+1-MB POSITIONS OF THE FIRST COLUMN,
  1262. C          ITS NEXT SUBDIAGONAL IN THE LAST N+2-MB POSITIONS OF THE
  1263. C          SECOND COLUMN, FURTHER SUBDIAGONALS SIMILARLY, AND FINALLY
  1264. C          ITS PRINCIPAL DIAGONAL IN THE N POSITIONS OF THE LAST COLUMN.
  1265. C          CONTENTS OF STORAGES NOT PART OF THE MATRIX ARE ARBITRARY.
  1266. C          ON A SUBSEQUENT CALL, ITS OUTPUT CONTENTS FROM THE PREVIOUS
  1267. C          CALL SHOULD BE PASSED.
  1268. C
  1269. C        T SPECIFIES THE SHIFT (OF EIGENVALUES) APPLIED TO THE DIAGONAL
  1270. C          OF A IN FORMING THE INPUT MATRIX. WHAT IS ACTUALLY DETERMINED
  1271. C          IS THE EIGENVALUE OF A+TI (I IS THE IDENTITY MATRIX) NEAREST
  1272. C          TO T.  ON A SUBSEQUENT CALL, THE OUTPUT VALUE OF T FROM THE
  1273. C          PREVIOUS CALL SHOULD BE PASSED IF THE NEXT NEAREST EIGENVALUE
  1274. C          IS SOUGHT.
  1275. C
  1276. C        R SHOULD BE SPECIFIED AS ZERO ON THE FIRST CALL, AND AS ITS
  1277. C          OUTPUT VALUE FROM THE PREVIOUS CALL ON A SUBSEQUENT CALL.
  1278. C          IT IS USED TO DETERMINE WHEN THE LAST ROW AND COLUMN OF
  1279. C          THE TRANSFORMED BAND MATRIX CAN BE REGARDED AS NEGLIGIBLE.
  1280. C
  1281. C        NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER RV
  1282. C          AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT.
  1283. C
  1284. C     ON OUTPUT
  1285. C
  1286. C        A CONTAINS THE TRANSFORMED BAND MATRIX.  THE MATRIX A+TI
  1287. C          DERIVED FROM THE OUTPUT PARAMETERS IS SIMILAR TO THE
  1288. C          INPUT A+TI TO WITHIN ROUNDING ERRORS.  ITS LAST ROW AND
  1289. C          COLUMN ARE NULL (IF IERR IS ZERO).
  1290. C
  1291. C        T CONTAINS THE COMPUTED EIGENVALUE OF A+TI (IF IERR IS ZERO).
  1292. C
  1293. C        R CONTAINS THE MAXIMUM OF ITS INPUT VALUE AND THE NORM OF THE
  1294. C          LAST COLUMN OF THE INPUT MATRIX A.
  1295. C
  1296. C        IERR IS SET TO
  1297. C          ZERO       FOR NORMAL RETURN,
  1298. C          N          IF THE EIGENVALUE HAS NOT BEEN
  1299. C                     DETERMINED AFTER 30 ITERATIONS.
  1300. C
  1301. C        RV IS A TEMPORARY STORAGE ARRAY OF DIMENSION AT LEAST
  1302. C          (2*MB**2+4*MB-3).  THE FIRST (3*MB-2) LOCATIONS CORRESPOND
  1303. C          TO THE ALGOL ARRAY B, THE NEXT (2*MB-1) LOCATIONS CORRESPOND
  1304. C          TO THE ALGOL ARRAY H, AND THE FINAL (2*MB**2-MB) LOCATIONS
  1305. C          CORRESPOND TO THE MB BY (2*MB-1) ALGOL ARRAY U.
  1306. C
  1307. C     NOTE. FOR A SUBSEQUENT CALL, N SHOULD BE REPLACED BY N-1, BUT
  1308. C     MB SHOULD NOT BE ALTERED EVEN WHEN IT EXCEEDS THE CURRENT N.
  1309. C
  1310. C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
  1311. C
  1312. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  1313. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  1314. C
  1315. C     THIS VERSION DATED AUGUST 1983.
  1316. C
  1317. C     ------------------------------------------------------------------
  1318. C
  1319.       IERR = 0
  1320.       M1 = MIN0(MB,N)
  1321.       M = M1 - 1
  1322.       M2 = M + M
  1323.       M21 = M2 + 1
  1324.       M3 = M21 + M
  1325.       M31 = M3 + 1
  1326.       M4 = M31 + M2
  1327.       MN = M + N
  1328.       MZ = MB - M1
  1329.       ITS = 0
  1330. C     .......... TEST FOR CONVERGENCE ..........
  1331.    40 G = A(N,MB)
  1332.       IF (M .EQ. 0) GO TO 360
  1333.       F = 0.0D0
  1334. C
  1335.       DO 50 K = 1, M
  1336.          MK = K + MZ
  1337.          F = F + DABS(A(N,MK))
  1338.    50 CONTINUE
  1339. C
  1340.       IF (ITS .EQ. 0 .AND. F .GT. R) R = F
  1341.       TST1 = R
  1342.       TST2 = TST1 + F
  1343.       IF (TST2 .LE. TST1) GO TO 360
  1344.       IF (ITS .EQ. 30) GO TO 1000
  1345.       ITS = ITS + 1
  1346. C     .......... FORM SHIFT FROM BOTTOM 2 BY 2 MINOR ..........
  1347.       IF (F .GT. 0.25D0 * R .AND. ITS .LT. 5) GO TO 90
  1348.       F = A(N,MB-1)
  1349.       IF (F .EQ. 0.0D0) GO TO 70
  1350.       Q = (A(N-1,MB) - G) / (2.0D0 * F)
  1351.       S = PYTHAG(Q,1.0D0)
  1352.       G = G - F / (Q + DSIGN(S,Q))
  1353.    70 T = T + G
  1354. C
  1355.       DO 80 I = 1, N
  1356.    80 A(I,MB) = A(I,MB) - G
  1357. C
  1358.    90 DO 100 K = M31, M4
  1359.   100 RV(K) = 0.0D0
  1360. C
  1361.       DO 350 II = 1, MN
  1362.          I = II - M
  1363.          NI = N - II
  1364.          IF (NI .LT. 0) GO TO 230
  1365. C     .......... FORM COLUMN OF SHIFTED MATRIX A-G*I ..........
  1366.          L = MAX0(1,2-I)
  1367. C
  1368.          DO 110 K = 1, M3
  1369.   110    RV(K) = 0.0D0
  1370. C
  1371.          DO 120 K = L, M1
  1372.             KM = K + M
  1373.             MK = K + MZ
  1374.             RV(KM) = A(II,MK)
  1375.   120    CONTINUE
  1376. C
  1377.          LL = MIN0(M,NI)
  1378.          IF (LL .EQ. 0) GO TO 135
  1379. C
  1380.          DO 130 K = 1, LL
  1381.             KM = K + M21
  1382.             IK = II + K
  1383.             MK = MB - K
  1384.             RV(KM) = A(IK,MK)
  1385.   130    CONTINUE
  1386. C     .......... PRE-MULTIPLY WITH HOUSEHOLDER REFLECTIONS ..........
  1387.   135    LL = M2
  1388.          IMULT = 0
  1389. C     .......... MULTIPLICATION PROCEDURE ..........
  1390.   140    KJ = M4 - M1
  1391. C
  1392.          DO 170 J = 1, LL
  1393.             KJ = KJ + M1
  1394.             JM = J + M3
  1395.             IF (RV(JM) .EQ. 0.0D0) GO TO 170
  1396.             F = 0.0D0
  1397. C
  1398.             DO 150 K = 1, M1
  1399.                KJ = KJ + 1
  1400.                JK = J + K - 1
  1401.                F = F + RV(KJ) * RV(JK)
  1402.   150       CONTINUE
  1403. C
  1404.             F = F / RV(JM)
  1405.             KJ = KJ - M1
  1406. C
  1407.             DO 160 K = 1, M1
  1408.                KJ = KJ + 1
  1409.                JK = J + K - 1
  1410.                RV(JK) = RV(JK) - RV(KJ) * F
  1411.   160       CONTINUE
  1412. C
  1413.             KJ = KJ - M1
  1414.   170    CONTINUE
  1415. C
  1416.          IF (IMULT .NE. 0) GO TO 280
  1417. C     .......... HOUSEHOLDER REFLECTION ..........
  1418.          F = RV(M21)
  1419.          S = 0.0D0
  1420.          RV(M4) = 0.0D0
  1421.          SCALE = 0.0D0
  1422. C
  1423.          DO 180 K = M21, M3
  1424.   180    SCALE = SCALE + DABS(RV(K))
  1425. C
  1426.          IF (SCALE .EQ. 0.0D0) GO TO 210
  1427. C
  1428.          DO 190 K = M21, M3
  1429.   190    S = S + (RV(K)/SCALE)**2
  1430. C
  1431.          S = SCALE * SCALE * S
  1432.          G = -DSIGN(DSQRT(S),F)
  1433.          RV(M21) = G
  1434.          RV(M4) = S - F * G
  1435.          KJ = M4 + M2 * M1 + 1
  1436.          RV(KJ) = F - G
  1437. C
  1438.          DO 200 K = 2, M1
  1439.             KJ = KJ + 1
  1440.             KM = K + M2
  1441.             RV(KJ) = RV(KM)
  1442.   200    CONTINUE
  1443. C     .......... SAVE COLUMN OF TRIANGULAR FACTOR R ..........
  1444.   210    DO 220 K = L, M1
  1445.             KM = K + M
  1446.             MK = K + MZ
  1447.             A(II,MK) = RV(KM)
  1448.   220    CONTINUE
  1449. C
  1450.   230    L = MAX0(1,M1+1-I)
  1451.          IF (I .LE. 0) GO TO 300
  1452. C     .......... PERFORM ADDITIONAL STEPS ..........
  1453.          DO 240 K = 1, M21
  1454.   240    RV(K) = 0.0D0
  1455. C
  1456.          LL = MIN0(M1,NI+M1)
  1457. C     .......... GET ROW OF TRIANGULAR FACTOR R ..........
  1458.          DO 250 KK = 1, LL
  1459.             K = KK - 1
  1460.             KM = K + M1
  1461.             IK = I + K
  1462.             MK = MB - K
  1463.             RV(KM) = A(IK,MK)
  1464.   250    CONTINUE
  1465. C     .......... POST-MULTIPLY WITH HOUSEHOLDER REFLECTIONS ..........
  1466.          LL = M1
  1467.          IMULT = 1
  1468.          GO TO 140
  1469. C     .......... STORE COLUMN OF NEW A MATRIX ..........
  1470.   280    DO 290 K = L, M1
  1471.             MK = K + MZ
  1472.             A(I,MK) = RV(K)
  1473.   290    CONTINUE
  1474. C     .......... UPDATE HOUSEHOLDER REFLECTIONS ..........
  1475.   300    IF (L .GT. 1) L = L - 1
  1476.          KJ1 = M4 + L * M1
  1477. C
  1478.          DO 320 J = L, M2
  1479.             JM = J + M3
  1480.             RV(JM) = RV(JM+1)
  1481. C
  1482.             DO 320 K = 1, M1
  1483.                KJ1 = KJ1 + 1
  1484.                KJ = KJ1 - M1
  1485.                RV(KJ) = RV(KJ1)
  1486.   320    CONTINUE
  1487. C
  1488.   350 CONTINUE
  1489. C
  1490.       GO TO 40
  1491. C     .......... CONVERGENCE ..........
  1492.   360 T = T + G
  1493. C
  1494.       DO 380 I = 1, N
  1495.   380 A(I,MB) = A(I,MB) - G
  1496. C
  1497.       DO 400 K = 1, M1
  1498.          MK = K + MZ
  1499.          A(N,MK) = 0.0D0
  1500.   400 CONTINUE
  1501. C
  1502.       GO TO 1001
  1503. C     .......... SET ERROR -- NO CONVERGENCE TO
  1504. C                EIGENVALUE AFTER 30 ITERATIONS ..........
  1505.  1000 IERR = N
  1506.  1001 RETURN
  1507.       END
  1508.       SUBROUTINE CBABK2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
  1509. C
  1510.       INTEGER I,J,K,M,N,II,NM,IGH,LOW
  1511.       DOUBLE PRECISION SCALE(N),ZR(NM,M),ZI(NM,M)
  1512.       DOUBLE PRECISION S
  1513. C
  1514. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
  1515. C     CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
  1516. C     NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
  1517. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
  1518. C
  1519. C     THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
  1520. C     MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
  1521. C     BALANCED MATRIX DETERMINED BY  CBAL.
  1522. C
  1523. C     ON INPUT
  1524. C
  1525. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  1526. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  1527. C          DIMENSION STATEMENT.
  1528. C
  1529. C        N IS THE ORDER OF THE MATRIX.
  1530. C
  1531. C        LOW AND IGH ARE INTEGERS DETERMINED BY  CBAL.
  1532. C
  1533. C        SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
  1534. C          AND SCALING FACTORS USED BY  CBAL.
  1535. C
  1536. C        M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
  1537. C
  1538. C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
  1539. C          RESPECTIVELY, OF THE EIGENVECTORS TO BE
  1540. C          BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
  1541. C
  1542. C     ON OUTPUT
  1543. C
  1544. C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
  1545. C          RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
  1546. C          IN THEIR FIRST M COLUMNS.
  1547. C
  1548. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  1549. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  1550. C
  1551. C     THIS VERSION DATED AUGUST 1983.
  1552. C
  1553. C     ------------------------------------------------------------------
  1554. C
  1555.       IF (M .EQ. 0) GO TO 200
  1556.       IF (IGH .EQ. LOW) GO TO 120
  1557. C
  1558.       DO 110 I = LOW, IGH
  1559.          S = SCALE(I)
  1560. C     .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
  1561. C                IF THE FOREGOING STATEMENT IS REPLACED BY
  1562. C                S=1.0D0/SCALE(I). ..........
  1563.          DO 100 J = 1, M
  1564.             ZR(I,J) = ZR(I,J) * S
  1565.             ZI(I,J) = ZI(I,J) * S
  1566.   100    CONTINUE
  1567. C
  1568.   110 CONTINUE
  1569. C     .......... FOR I=LOW-1 STEP -1 UNTIL 1,
  1570. C                IGH+1 STEP 1 UNTIL N DO -- ..........
  1571.   120 DO 140 II = 1, N
  1572.          I = II
  1573.          IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140
  1574.          IF (I .LT. LOW) I = LOW - II
  1575.          K = SCALE(I)
  1576.          IF (K .EQ. I) GO TO 140
  1577. C
  1578.          DO 130 J = 1, M
  1579.             S = ZR(I,J)
  1580.             ZR(I,J) = ZR(K,J)
  1581.             ZR(K,J) = S
  1582.             S = ZI(I,J)
  1583.             ZI(I,J) = ZI(K,J)
  1584.             ZI(K,J) = S
  1585.   130    CONTINUE
  1586. C
  1587.   140 CONTINUE
  1588. C
  1589.   200 RETURN
  1590.       END
  1591.       SUBROUTINE CBAL(NM,N,AR,AI,LOW,IGH,SCALE)
  1592. C
  1593.       INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
  1594.       DOUBLE PRECISION AR(NM,N),AI(NM,N),SCALE(N)
  1595.       DOUBLE PRECISION C,F,G,R,S,B2,RADIX
  1596.       LOGICAL NOCONV
  1597. C
  1598. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
  1599. C     CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
  1600. C     NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
  1601. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
  1602. C
  1603. C     THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
  1604. C     EIGENVALUES WHENEVER POSSIBLE.
  1605. C
  1606. C     ON INPUT
  1607. C
  1608. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  1609. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  1610. C          DIMENSION STATEMENT.
  1611. C
  1612. C        N IS THE ORDER OF THE MATRIX.
  1613. C
  1614. C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
  1615. C          RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
  1616. C
  1617. C     ON OUTPUT
  1618. C
  1619. C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
  1620. C          RESPECTIVELY, OF THE BALANCED MATRIX.
  1621. C
  1622. C        LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
  1623. C          ARE EQUAL TO ZERO IF
  1624. C           (1) I IS GREATER THAN J AND
  1625. C           (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
  1626. C
  1627. C        SCALE CONTAINS INFORMATION DETERMINING THE
  1628. C           PERMUTATIONS AND SCALING FACTORS USED.
  1629. C
  1630. C     SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
  1631. C     HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
  1632. C     WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
  1633. C     OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J).  THEN
  1634. C        SCALE(J) = P(J),    FOR J = 1,...,LOW-1
  1635. C                 = D(J,J)       J = LOW,...,IGH
  1636. C                 = P(J)         J = IGH+1,...,N.
  1637. C     THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
  1638. C     THEN 1 TO LOW-1.
  1639. C
  1640. C     NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
  1641. C
  1642. C     THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
  1643. C     CBAL  IN LINE.  (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
  1644. C     K,L HAVE BEEN REVERSED.)
  1645. C
  1646. C     ARITHMETIC IS REAL THROUGHOUT.
  1647. C
  1648. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  1649. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  1650. C
  1651. C     THIS VERSION DATED AUGUST 1983.
  1652. C
  1653. C     ------------------------------------------------------------------
  1654. C
  1655.       RADIX = 16.0D0
  1656. C
  1657.       B2 = RADIX * RADIX
  1658.       K = 1
  1659.       L = N
  1660.       GO TO 100
  1661. C     .......... IN-LINE PROCEDURE FOR ROW AND
  1662. C                COLUMN EXCHANGE ..........
  1663.    20 SCALE(M) = J
  1664.       IF (J .EQ. M) GO TO 50
  1665. C
  1666.       DO 30 I = 1, L
  1667.          F = AR(I,J)
  1668.          AR(I,J) = AR(I,M)
  1669.          AR(I,M) = F
  1670.          F = AI(I,J)
  1671.          AI(I,J) = AI(I,M)
  1672.          AI(I,M) = F
  1673.    30 CONTINUE
  1674. C
  1675.       DO 40 I = K, N
  1676.          F = AR(J,I)
  1677.          AR(J,I) = AR(M,I)
  1678.          AR(M,I) = F
  1679.          F = AI(J,I)
  1680.          AI(J,I) = AI(M,I)
  1681.          AI(M,I) = F
  1682.    40 CONTINUE
  1683. C
  1684.    50 GO TO (80,130), IEXC
  1685. C     .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
  1686. C                AND PUSH THEM DOWN ..........
  1687.    80 IF (L .EQ. 1) GO TO 280
  1688.       L = L - 1
  1689. C     .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
  1690.   100 DO 120 JJ = 1, L
  1691.          J = L + 1 - JJ
  1692. C
  1693.          DO 110 I = 1, L
  1694.             IF (I .EQ. J) GO TO 110
  1695.             IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GO TO 120
  1696.   110    CONTINUE
  1697. C
  1698.          M = L
  1699.          IEXC = 1
  1700.          GO TO 20
  1701.   120 CONTINUE
  1702. C
  1703.       GO TO 140
  1704. C     .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
  1705. C                AND PUSH THEM LEFT ..........
  1706.   130 K = K + 1
  1707. C
  1708.   140 DO 170 J = K, L
  1709. C
  1710.          DO 150 I = K, L
  1711.             IF (I .EQ. J) GO TO 150
  1712.             IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GO TO 170
  1713.   150    CONTINUE
  1714. C
  1715.          M = K
  1716.          IEXC = 2
  1717.          GO TO 20
  1718.   170 CONTINUE
  1719. C     .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
  1720.       DO 180 I = K, L
  1721.   180 SCALE(I) = 1.0D0
  1722. C     .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
  1723.   190 NOCONV = .FALSE.
  1724. C
  1725.       DO 270 I = K, L
  1726.          C = 0.0D0
  1727.          R = 0.0D0
  1728. C
  1729.          DO 200 J = K, L
  1730.             IF (J .EQ. I) GO TO 200
  1731.             C = C + DABS(AR(J,I)) + DABS(AI(J,I))
  1732.             R = R + DABS(AR(I,J)) + DABS(AI(I,J))
  1733.   200    CONTINUE
  1734. C     .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
  1735.          IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GO TO 270
  1736.          G = R / RADIX
  1737.          F = 1.0D0
  1738.          S = C + R
  1739.   210    IF (C .GE. G) GO TO 220
  1740.          F = F * RADIX
  1741.          C = C * B2
  1742.          GO TO 210
  1743.   220    G = R * RADIX
  1744.   230    IF (C .LT. G) GO TO 240
  1745.          F = F / RADIX
  1746.          C = C / B2
  1747.          GO TO 230
  1748. C     .......... NOW BALANCE ..........
  1749.   240    IF ((C + R) / F .GE. 0.95D0 * S) GO TO 270
  1750.          G = 1.0D0 / F
  1751.          SCALE(I) = SCALE(I) * F
  1752.          NOCONV = .TRUE.
  1753. C
  1754.          DO 250 J = K, N
  1755.             AR(I,J) = AR(I,J) * G
  1756.             AI(I,J) = AI(I,J) * G
  1757.   250    CONTINUE
  1758. C
  1759.          DO 260 J = 1, L
  1760.             AR(J,I) = AR(J,I) * F
  1761.             AI(J,I) = AI(J,I) * F
  1762.   260    CONTINUE
  1763. C
  1764.   270 CONTINUE
  1765. C
  1766.       IF (NOCONV) GO TO 190
  1767. C
  1768.   280 LOW = K
  1769.       IGH = L
  1770.       RETURN
  1771.       END
  1772.       SUBROUTINE CG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
  1773. C
  1774.       INTEGER N,NM,IS1,IS2,IERR,MATZ
  1775.       DOUBLE PRECISION AR(NM,N),AI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N),
  1776.      X       FV1(N),FV2(N),FV3(N)
  1777. C
  1778. C     THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
  1779. C     SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
  1780. C     TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
  1781. C     OF A COMPLEX GENERAL MATRIX.
  1782. C
  1783. C     ON INPUT
  1784. C
  1785. C        NM  MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
  1786. C        ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  1787. C        DIMENSION STATEMENT.
  1788. C
  1789. C        N  IS THE ORDER OF THE MATRIX  A=(AR,AI).
  1790. C
  1791. C        AR  AND  AI  CONTAIN THE REAL AND IMAGINARY PARTS,
  1792. C        RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
  1793. C
  1794. C        MATZ  IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
  1795. C        ONLY EIGENVALUES ARE DESIRED.  OTHERWISE IT IS SET TO
  1796. C        ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
  1797. C
  1798. C     ON OUTPUT
  1799. C
  1800. C        WR  AND  WI  CONTAIN THE REAL AND IMAGINARY PARTS,
  1801. C        RESPECTIVELY, OF THE EIGENVALUES.
  1802. C
  1803. C        ZR  AND  ZI  CONTAIN THE REAL AND IMAGINARY PARTS,
  1804. C        RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
  1805. C
  1806. C        IERR  IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
  1807. C           COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
  1808. C           AND COMQR2.  THE NORMAL COMPLETION CODE IS ZERO.
  1809. C
  1810. C        FV1, FV2, AND  FV3  ARE TEMPORARY STORAGE ARRAYS.
  1811. C
  1812. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  1813. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  1814. C
  1815. C     THIS VERSION DATED AUGUST 1983.
  1816. C
  1817. C     ------------------------------------------------------------------
  1818. C
  1819.       IF (N .LE. NM) GO TO 10
  1820.       IERR = 10 * N
  1821.       GO TO 50
  1822. C
  1823.    10 CALL  CBAL(NM,N,AR,AI,IS1,IS2,FV1)
  1824.       CALL  CORTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
  1825.       IF (MATZ .NE. 0) GO TO 20
  1826. C     .......... FIND EIGENVALUES ONLY ..........
  1827.       CALL  COMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
  1828.       GO TO 50
  1829. C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
  1830.    20 CALL  COMQR2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
  1831.       IF (IERR .NE. 0) GO TO 50
  1832.       CALL  CBABK2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
  1833.    50 RETURN
  1834.       END
  1835.       SUBROUTINE CH(NM,N,AR,AI,W,MATZ,ZR,ZI,FV1,FV2,FM1,IERR)
  1836. C
  1837.       INTEGER I,J,N,NM,IERR,MATZ
  1838.       DOUBLE PRECISION AR(NM,N),AI(NM,N),W(N),ZR(NM,N),ZI(NM,N),
  1839.      X       FV1(N),FV2(N),FM1(2,N)
  1840. C
  1841. C     THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
  1842. C     SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
  1843. C     TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
  1844. C     OF A COMPLEX HERMITIAN MATRIX.
  1845. C
  1846. C     ON INPUT
  1847. C
  1848. C        NM  MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
  1849. C        ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  1850. C        DIMENSION STATEMENT.
  1851. C
  1852. C        N  IS THE ORDER OF THE MATRIX  A=(AR,AI).
  1853. C
  1854. C        AR  AND  AI  CONTAIN THE REAL AND IMAGINARY PARTS,
  1855. C        RESPECTIVELY, OF THE COMPLEX HERMITIAN MATRIX.
  1856. C
  1857. C        MATZ  IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
  1858. C        ONLY EIGENVALUES ARE DESIRED.  OTHERWISE IT IS SET TO
  1859. C        ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
  1860. C
  1861. C     ON OUTPUT
  1862. C
  1863. C        W  CONTAINS THE EIGENVALUES IN ASCENDING ORDER.
  1864. C
  1865. C        ZR  AND  ZI  CONTAIN THE REAL AND IMAGINARY PARTS,
  1866. C        RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
  1867. C
  1868. C        IERR  IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
  1869. C           COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT
  1870. C           AND TQL2.  THE NORMAL COMPLETION CODE IS ZERO.
  1871. C
  1872. C        FV1, FV2, AND  FM1  ARE TEMPORARY STORAGE ARRAYS.
  1873. C
  1874. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  1875. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  1876. C
  1877. C     THIS VERSION DATED AUGUST 1983.
  1878. C
  1879. C     ------------------------------------------------------------------
  1880. C
  1881.       IF (N .LE. NM) GO TO 10
  1882.       IERR = 10 * N
  1883.       GO TO 50
  1884. C
  1885.    10 CALL  HTRIDI(NM,N,AR,AI,W,FV1,FV2,FM1)
  1886.       IF (MATZ .NE. 0) GO TO 20
  1887. C     .......... FIND EIGENVALUES ONLY ..........
  1888.       CALL  TQLRAT(N,W,FV2,IERR)
  1889.       GO TO 50
  1890. C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
  1891.    20 DO 40 I = 1, N
  1892. C
  1893.          DO 30 J = 1, N
  1894.             ZR(J,I) = 0.0D0
  1895.    30    CONTINUE
  1896. C
  1897.          ZR(I,I) = 1.0D0
  1898.    40 CONTINUE
  1899. C
  1900.       CALL  TQL2(NM,N,W,FV1,ZR,IERR)
  1901.       IF (IERR .NE. 0) GO TO 50
  1902.       CALL  HTRIBK(NM,N,AR,AI,FM1,N,ZR,ZI)
  1903.    50 RETURN
  1904.       END
  1905.       SUBROUTINE CINVIT(NM,N,AR,AI,WR,WI,SELECT,MM,M,ZR,ZI,
  1906.      X                  IERR,RM1,RM2,RV1,RV2)
  1907. C
  1908.       INTEGER I,J,K,M,N,S,II,MM,MP,NM,UK,IP1,ITS,KM1,IERR
  1909.       DOUBLE PRECISION AR(NM,N),AI(NM,N),WR(N),WI(N),ZR(NM,MM),
  1910.      X       ZI(NM,MM),RM1(N,N),RM2(N,N),RV1(N),RV2(N)
  1911.       DOUBLE PRECISION X,Y,EPS3,NORM,NORMV,EPSLON,GROWTO,ILAMBD,PYTHAG,
  1912.      X       RLAMBD,UKROOT
  1913.       LOGICAL SELECT(N)
  1914. C
  1915. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE CX INVIT
  1916. C     BY PETERS AND WILKINSON.
  1917. C     HANDBOOK FOR AUTO. COMP. VOL.II-LINEAR ALGEBRA, 418-439(1971).
  1918. C
  1919. C     THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A COMPLEX UPPER
  1920. C     HESSENBERG MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES,
  1921. C     USING INVERSE ITERATION.
  1922. C
  1923. C     ON INPUT
  1924. C
  1925. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  1926. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  1927. C          DIMENSION STATEMENT.
  1928. C
  1929. C        N IS THE ORDER OF THE MATRIX.
  1930. C
  1931. C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
  1932. C          RESPECTIVELY, OF THE HESSENBERG MATRIX.
  1933. C
  1934. C        WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, RESPECTIVELY,
  1935. C          OF THE EIGENVALUES OF THE MATRIX.  THE EIGENVALUES MUST BE
  1936. C          STORED IN A MANNER IDENTICAL TO THAT OF SUBROUTINE  COMLR,
  1937. C          WHICH RECOGNIZES POSSIBLE SPLITTING OF THE MATRIX.
  1938. C
  1939. C        SELECT SPECIFIES THE EIGENVECTORS TO BE FOUND.  THE
  1940. C          EIGENVECTOR CORRESPONDING TO THE J-TH EIGENVALUE IS
  1941. C          SPECIFIED BY SETTING SELECT(J) TO .TRUE..
  1942. C
  1943. C        MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF
  1944. C          EIGENVECTORS TO BE FOUND.
  1945. C
  1946. C     ON OUTPUT
  1947. C
  1948. C        AR, AI, WI, AND SELECT ARE UNALTERED.
  1949. C
  1950. C        WR MAY HAVE BEEN ALTERED SINCE CLOSE EIGENVALUES ARE PERTURBED
  1951. C          SLIGHTLY IN SEARCHING FOR INDEPENDENT EIGENVECTORS.
  1952. C
  1953. C        M IS THE NUMBER OF EIGENVECTORS ACTUALLY FOUND.
  1954. C
  1955. C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, RESPECTIVELY,
  1956. C          OF THE EIGENVECTORS.  THE EIGENVECTORS ARE NORMALIZED
  1957. C          SO THAT THE COMPONENT OF LARGEST MAGNITUDE IS 1.
  1958. C          ANY VECTOR WHICH FAILS THE ACCEPTANCE TEST IS SET TO ZERO.
  1959. C
  1960. C        IERR IS SET TO
  1961. C          ZERO       FOR NORMAL RETURN,
  1962. C          -(2*N+1)   IF MORE THAN MM EIGENVECTORS HAVE BEEN SPECIFIED,
  1963. C          -K         IF THE ITERATION CORRESPONDING TO THE K-TH
  1964. C                     VALUE FAILS,
  1965. C          -(N+K)     IF BOTH ERROR SITUATIONS OCCUR.
  1966. C
  1967. C        RM1, RM2, RV1, AND RV2 ARE TEMPORARY STORAGE ARRAYS.
  1968. C
  1969. C     THE ALGOL PROCEDURE GUESSVEC APPEARS IN CINVIT IN LINE.
  1970. C
  1971. C     CALLS CDIV FOR COMPLEX DIVISION.
  1972. C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
  1973. C
  1974. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  1975. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  1976. C
  1977. C     THIS VERSION DATED AUGUST 1983.
  1978. C
  1979. C     ------------------------------------------------------------------
  1980. C
  1981.       IERR = 0
  1982.       UK = 0
  1983.       S = 1
  1984. C
  1985.       DO 980 K = 1, N
  1986.          IF (.NOT. SELECT(K)) GO TO 980
  1987.          IF (S .GT. MM) GO TO 1000
  1988.          IF (UK .GE. K) GO TO 200
  1989. C     .......... CHECK FOR POSSIBLE SPLITTING ..........
  1990.          DO 120 UK = K, N
  1991.             IF (UK .EQ. N) GO TO 140
  1992.             IF (AR(UK+1,UK) .EQ. 0.0D0 .AND. AI(UK+1,UK) .EQ. 0.0D0)
  1993.      X         GO TO 140
  1994.   120    CONTINUE
  1995. C     .......... COMPUTE INFINITY NORM OF LEADING UK BY UK
  1996. C                (HESSENBERG) MATRIX ..........
  1997.   140    NORM = 0.0D0
  1998.          MP = 1
  1999. C
  2000.          DO 180 I = 1, UK
  2001.             X = 0.0D0
  2002. C
  2003.             DO 160 J = MP, UK
  2004.   160       X = X + PYTHAG(AR(I,J),AI(I,J))
  2005. C
  2006.             IF (X .GT. NORM) NORM = X
  2007.             MP = I
  2008.   180    CONTINUE
  2009. C     .......... EPS3 REPLACES ZERO PIVOT IN DECOMPOSITION
  2010. C                AND CLOSE ROOTS ARE MODIFIED BY EPS3 ..........
  2011.          IF (NORM .EQ. 0.0D0) NORM = 1.0D0
  2012.          EPS3 = EPSLON(NORM)
  2013. C     .......... GROWTO IS THE CRITERION FOR GROWTH ..........
  2014.          UKROOT = UK
  2015.          UKROOT = DSQRT(UKROOT)
  2016.          GROWTO = 0.1D0 / UKROOT
  2017.   200    RLAMBD = WR(K)
  2018.          ILAMBD = WI(K)
  2019.          IF (K .EQ. 1) GO TO 280
  2020.          KM1 = K - 1
  2021.          GO TO 240
  2022. C     .......... PERTURB EIGENVALUE IF IT IS CLOSE
  2023. C                TO ANY PREVIOUS EIGENVALUE ..........
  2024.   220    RLAMBD = RLAMBD + EPS3
  2025. C     .......... FOR I=K-1 STEP -1 UNTIL 1 DO -- ..........
  2026.   240    DO 260 II = 1, KM1
  2027.             I = K - II
  2028.             IF (SELECT(I) .AND. DABS(WR(I)-RLAMBD) .LT. EPS3 .AND.
  2029.      X         DABS(WI(I)-ILAMBD) .LT. EPS3) GO TO 220
  2030.   260    CONTINUE
  2031. C
  2032.          WR(K) = RLAMBD
  2033. C     .......... FORM UPPER HESSENBERG (AR,AI)-(RLAMBD,ILAMBD)*I
  2034. C                AND INITIAL COMPLEX VECTOR ..........
  2035.   280    MP = 1
  2036. C
  2037.          DO 320 I = 1, UK
  2038. C
  2039.             DO 300 J = MP, UK
  2040.                RM1(I,J) = AR(I,J)
  2041.                RM2(I,J) = AI(I,J)
  2042.   300       CONTINUE
  2043. C
  2044.             RM1(I,I) = RM1(I,I) - RLAMBD
  2045.             RM2(I,I) = RM2(I,I) - ILAMBD
  2046.             MP = I
  2047.             RV1(I) = EPS3
  2048.   320    CONTINUE
  2049. C     .......... TRIANGULAR DECOMPOSITION WITH INTERCHANGES,
  2050. C                REPLACING ZERO PIVOTS BY EPS3 ..........
  2051.          IF (UK .EQ. 1) GO TO 420
  2052. C
  2053.          DO 400 I = 2, UK
  2054.             MP = I - 1
  2055.             IF (PYTHAG(RM1(I,MP),RM2(I,MP)) .LE.
  2056.      X          PYTHAG(RM1(MP,MP),RM2(MP,MP))) GO TO 360
  2057. C
  2058.             DO 340 J = MP, UK
  2059.                Y = RM1(I,J)
  2060.                RM1(I,J) = RM1(MP,J)
  2061.                RM1(MP,J) = Y
  2062.                Y = RM2(I,J)
  2063.                RM2(I,J) = RM2(MP,J)
  2064.                RM2(MP,J) = Y
  2065.   340       CONTINUE
  2066. C
  2067.   360       IF (RM1(MP,MP) .EQ. 0.0D0 .AND. RM2(MP,MP) .EQ. 0.0D0)
  2068.      X         RM1(MP,MP) = EPS3
  2069.             CALL CDIV(RM1(I,MP),RM2(I,MP),RM1(MP,MP),RM2(MP,MP),X,Y)
  2070.             IF (X .EQ. 0.0D0 .AND. Y .EQ. 0.0D0) GO TO 400
  2071. C
  2072.             DO 380 J = I, UK
  2073.                RM1(I,J) = RM1(I,J) - X * RM1(MP,J) + Y * RM2(MP,J)
  2074.                RM2(I,J) = RM2(I,J) - X * RM2(MP,J) - Y * RM1(MP,J)
  2075.   380       CONTINUE
  2076. C
  2077.   400    CONTINUE
  2078. C
  2079.   420    IF (RM1(UK,UK) .EQ. 0.0D0 .AND. RM2(UK,UK) .EQ. 0.0D0)
  2080.      X      RM1(UK,UK) = EPS3
  2081.          ITS = 0
  2082. C     .......... BACK SUBSTITUTION
  2083. C                FOR I=UK STEP -1 UNTIL 1 DO -- ..........
  2084.   660    DO 720 II = 1, UK
  2085.             I = UK + 1 - II
  2086.             X = RV1(I)
  2087.             Y = 0.0D0
  2088.             IF (I .EQ. UK) GO TO 700
  2089.             IP1 = I + 1
  2090. C
  2091.             DO 680 J = IP1, UK
  2092.                X = X - RM1(I,J) * RV1(J) + RM2(I,J) * RV2(J)
  2093.                Y = Y - RM1(I,J) * RV2(J) - RM2(I,J) * RV1(J)
  2094.   680       CONTINUE
  2095. C
  2096.   700       CALL CDIV(X,Y,RM1(I,I),RM2(I,I),RV1(I),RV2(I))
  2097.   720    CONTINUE
  2098. C     .......... ACCEPTANCE TEST FOR EIGENVECTOR
  2099. C                AND NORMALIZATION ..........
  2100.          ITS = ITS + 1
  2101.          NORM = 0.0D0
  2102.          NORMV = 0.0D0
  2103. C
  2104.          DO 780 I = 1, UK
  2105.             X = PYTHAG(RV1(I),RV2(I))
  2106.             IF (NORMV .GE. X) GO TO 760
  2107.             NORMV = X
  2108.             J = I
  2109.   760       NORM = NORM + X
  2110.   780    CONTINUE
  2111. C
  2112.          IF (NORM .LT. GROWTO) GO TO 840
  2113. C     .......... ACCEPT VECTOR ..........
  2114.          X = RV1(J)
  2115.          Y = RV2(J)
  2116. C
  2117.          DO 820 I = 1, UK
  2118.             CALL CDIV(RV1(I),RV2(I),X,Y,ZR(I,S),ZI(I,S))
  2119.   820    CONTINUE
  2120. C
  2121.          IF (UK .EQ. N) GO TO 940
  2122.          J = UK + 1
  2123.          GO TO 900
  2124. C     .......... IN-LINE PROCEDURE FOR CHOOSING
  2125. C                A NEW STARTING VECTOR ..........
  2126.   840    IF (ITS .GE. UK) GO TO 880
  2127.          X = UKROOT
  2128.          Y = EPS3 / (X + 1.0D0)
  2129.          RV1(1) = EPS3
  2130. C
  2131.          DO 860 I = 2, UK
  2132.   860    RV1(I) = Y
  2133. C
  2134.          J = UK - ITS + 1
  2135.          RV1(J) = RV1(J) - EPS3 * X
  2136.          GO TO 660
  2137. C     .......... SET ERROR -- UNACCEPTED EIGENVECTOR ..........
  2138.   880    J = 1
  2139.          IERR = -K
  2140. C     .......... SET REMAINING VECTOR COMPONENTS TO ZERO ..........
  2141.   900    DO 920 I = J, N
  2142.             ZR(I,S) = 0.0D0
  2143.             ZI(I,S) = 0.0D0
  2144.   920    CONTINUE
  2145. C
  2146.   940    S = S + 1
  2147.   980 CONTINUE
  2148. C
  2149.       GO TO 1001
  2150. C     .......... SET ERROR -- UNDERESTIMATE OF EIGENVECTOR
  2151. C                SPACE REQUIRED ..........
  2152.  1000 IF (IERR .NE. 0) IERR = IERR - N
  2153.       IF (IERR .EQ. 0) IERR = -(2 * N + 1)
  2154.  1001 M = S - 1
  2155.       RETURN
  2156.       END
  2157.       SUBROUTINE COMBAK(NM,LOW,IGH,AR,AI,INT,M,ZR,ZI)
  2158. C
  2159.       INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1
  2160.       DOUBLE PRECISION AR(NM,IGH),AI(NM,IGH),ZR(NM,M),ZI(NM,M)
  2161.       DOUBLE PRECISION XR,XI
  2162.       INTEGER INT(IGH)
  2163. C
  2164. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMBAK,
  2165. C     NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON.
  2166. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
  2167. C
  2168. C     THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
  2169. C     MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
  2170. C     UPPER HESSENBERG MATRIX DETERMINED BY  COMHES.
  2171. C
  2172. C     ON INPUT
  2173. C
  2174. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  2175. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  2176. C          DIMENSION STATEMENT.
  2177. C
  2178. C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
  2179. C          SUBROUTINE  CBAL.  IF  CBAL  HAS NOT BEEN USED,
  2180. C          SET LOW=1 AND IGH EQUAL TO THE ORDER OF THE MATRIX.
  2181. C
  2182. C        AR AND AI CONTAIN THE MULTIPLIERS WHICH WERE USED IN THE
  2183. C          REDUCTION BY  COMHES  IN THEIR LOWER TRIANGLES
  2184. C          BELOW THE SUBDIAGONAL.
  2185. C
  2186. C        INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS
  2187. C          INTERCHANGED IN THE REDUCTION BY  COMHES.
  2188. C          ONLY ELEMENTS LOW THROUGH IGH ARE USED.
  2189. C
  2190. C        M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
  2191. C
  2192. C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
  2193. C          RESPECTIVELY, OF THE EIGENVECTORS TO BE
  2194. C          BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
  2195. C
  2196. C     ON OUTPUT
  2197. C
  2198. C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
  2199. C          RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
  2200. C          IN THEIR FIRST M COLUMNS.
  2201. C
  2202. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  2203. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  2204. C
  2205. C     THIS VERSION DATED AUGUST 1983.
  2206. C
  2207. C     ------------------------------------------------------------------
  2208. C
  2209.       IF (M .EQ. 0) GO TO 200
  2210.       LA = IGH - 1
  2211.       KP1 = LOW + 1
  2212.       IF (LA .LT. KP1) GO TO 200
  2213. C     .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
  2214.       DO 140 MM = KP1, LA
  2215.          MP = LOW + IGH - MM
  2216.          MP1 = MP + 1
  2217. C
  2218.          DO 110 I = MP1, IGH
  2219.             XR = AR(I,MP-1)
  2220.             XI = AI(I,MP-1)
  2221.             IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 110
  2222. C
  2223.             DO 100 J = 1, M
  2224.                ZR(I,J) = ZR(I,J) + XR * ZR(MP,J) - XI * ZI(MP,J)
  2225.                ZI(I,J) = ZI(I,J) + XR * ZI(MP,J) + XI * ZR(MP,J)
  2226.   100       CONTINUE
  2227. C
  2228.   110    CONTINUE
  2229. C
  2230.          I = INT(MP)
  2231.          IF (I .EQ. MP) GO TO 140
  2232. C
  2233.          DO 130 J = 1, M
  2234.             XR = ZR(I,J)
  2235.             ZR(I,J) = ZR(MP,J)
  2236.             ZR(MP,J) = XR
  2237.             XI = ZI(I,J)
  2238.             ZI(I,J) = ZI(MP,J)
  2239.             ZI(MP,J) = XI
  2240.   130    CONTINUE
  2241. C
  2242.   140 CONTINUE
  2243. C
  2244.   200 RETURN
  2245.       END
  2246.       SUBROUTINE COMHES(NM,N,LOW,IGH,AR,AI,INT)
  2247. C
  2248.       INTEGER I,J,M,N,LA,NM,IGH,KP1,LOW,MM1,MP1
  2249.       DOUBLE PRECISION AR(NM,N),AI(NM,N)
  2250.       DOUBLE PRECISION XR,XI,YR,YI
  2251.       INTEGER INT(IGH)
  2252. C
  2253. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMHES,
  2254. C     NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON.
  2255. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
  2256. C
  2257. C     GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
  2258. C     REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
  2259. C     LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
  2260. C     STABILIZED ELEMENTARY SIMILARITY TRANSFORMATIONS.
  2261. C
  2262. C     ON INPUT
  2263. C
  2264. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  2265. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  2266. C          DIMENSION STATEMENT.
  2267. C
  2268. C        N IS THE ORDER OF THE MATRIX.
  2269. C
  2270. C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
  2271. C          SUBROUTINE  CBAL.  IF  CBAL  HAS NOT BEEN USED,
  2272. C          SET LOW=1, IGH=N.
  2273. C
  2274. C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
  2275. C          RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
  2276. C
  2277. C     ON OUTPUT
  2278. C
  2279. C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
  2280. C          RESPECTIVELY, OF THE HESSENBERG MATRIX.  THE
  2281. C          MULTIPLIERS WHICH WERE USED IN THE REDUCTION
  2282. C          ARE STORED IN THE REMAINING TRIANGLES UNDER THE
  2283. C          HESSENBERG MATRIX.
  2284. C
  2285. C        INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS
  2286. C          INTERCHANGED IN THE REDUCTION.
  2287. C          ONLY ELEMENTS LOW THROUGH IGH ARE USED.
  2288. C
  2289. C     CALLS CDIV FOR COMPLEX DIVISION.
  2290. C
  2291. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  2292. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  2293. C
  2294. C     THIS VERSION DATED AUGUST 1983.
  2295. C
  2296. C     ------------------------------------------------------------------
  2297. C
  2298.       LA = IGH - 1
  2299.       KP1 = LOW + 1
  2300.       IF (LA .LT. KP1) GO TO 200
  2301. C
  2302.       DO 180 M = KP1, LA
  2303.          MM1 = M - 1
  2304.          XR = 0.0D0
  2305.          XI = 0.0D0
  2306.          I = M
  2307. C
  2308.          DO 100 J = M, IGH
  2309.             IF (DABS(AR(J,MM1)) + DABS(AI(J,MM1))
  2310.      X         .LE. DABS(XR) + DABS(XI)) GO TO 100
  2311.             XR = AR(J,MM1)
  2312.             XI = AI(J,MM1)
  2313.             I = J
  2314.   100    CONTINUE
  2315. C
  2316.          INT(M) = I
  2317.          IF (I .EQ. M) GO TO 130
  2318. C     .......... INTERCHANGE ROWS AND COLUMNS OF AR AND AI ..........
  2319.          DO 110 J = MM1, N
  2320.             YR = AR(I,J)
  2321.             AR(I,J) = AR(M,J)
  2322.             AR(M,J) = YR
  2323.             YI = AI(I,J)
  2324.             AI(I,J) = AI(M,J)
  2325.             AI(M,J) = YI
  2326.   110    CONTINUE
  2327. C
  2328.          DO 120 J = 1, IGH
  2329.             YR = AR(J,I)
  2330.             AR(J,I) = AR(J,M)
  2331.             AR(J,M) = YR
  2332.             YI = AI(J,I)
  2333.             AI(J,I) = AI(J,M)
  2334.             AI(J,M) = YI
  2335.   120    CONTINUE
  2336. C     .......... END INTERCHANGE ..........
  2337.   130    IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 180
  2338.          MP1 = M + 1
  2339. C
  2340.          DO 160 I = MP1, IGH
  2341.             YR = AR(I,MM1)
  2342.             YI = AI(I,MM1)
  2343.             IF (YR .EQ. 0.0D0 .AND. YI .EQ. 0.0D0) GO TO 160
  2344.             CALL CDIV(YR,YI,XR,XI,YR,YI)
  2345.             AR(I,MM1) = YR
  2346.             AI(I,MM1) = YI
  2347. C
  2348.             DO 140 J = M, N
  2349.                AR(I,J) = AR(I,J) - YR * AR(M,J) + YI * AI(M,J)
  2350.                AI(I,J) = AI(I,J) - YR * AI(M,J) - YI * AR(M,J)
  2351.   140       CONTINUE
  2352. C
  2353.             DO 150 J = 1, IGH
  2354.                AR(J,M) = AR(J,M) + YR * AR(J,I) - YI * AI(J,I)
  2355.                AI(J,M) = AI(J,M) + YR * AI(J,I) + YI * AR(J,I)
  2356.   150       CONTINUE
  2357. C
  2358.   160    CONTINUE
  2359. C
  2360.   180 CONTINUE
  2361. C
  2362.   200 RETURN
  2363.       END
  2364.       SUBROUTINE COMLR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
  2365. C
  2366.       INTEGER I,J,L,M,N,EN,LL,MM,NM,IGH,IM1,ITN,ITS,LOW,MP1,ENM1,IERR
  2367.       DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N)
  2368.       DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,TST1,TST2
  2369. C
  2370. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMLR,
  2371. C     NUM. MATH. 12, 369-376(1968) BY MARTIN AND WILKINSON.
  2372. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
  2373. C
  2374. C     THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
  2375. C     UPPER HESSENBERG MATRIX BY THE MODIFIED LR METHOD.
  2376. C
  2377. C     ON INPUT
  2378. C
  2379. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  2380. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  2381. C          DIMENSION STATEMENT.
  2382. C
  2383. C        N IS THE ORDER OF THE MATRIX.
  2384. C
  2385. C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
  2386. C          SUBROUTINE  CBAL.  IF  CBAL  HAS NOT BEEN USED,
  2387. C          SET LOW=1, IGH=N.
  2388. C
  2389. C        HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
  2390. C          RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
  2391. C          THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN THE
  2392. C          MULTIPLIERS WHICH WERE USED IN THE REDUCTION BY  COMHES,
  2393. C          IF PERFORMED.
  2394. C
  2395. C     ON OUTPUT
  2396. C
  2397. C        THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
  2398. C          DESTROYED.  THEREFORE, THEY MUST BE SAVED BEFORE
  2399. C          CALLING  COMLR  IF SUBSEQUENT CALCULATION OF
  2400. C          EIGENVECTORS IS TO BE PERFORMED.
  2401. C
  2402. C        WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
  2403. C          RESPECTIVELY, OF THE EIGENVALUES.  IF AN ERROR
  2404. C          EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
  2405. C          FOR INDICES IERR+1,...,N.
  2406. C
  2407. C        IERR IS SET TO
  2408. C          ZERO       FOR NORMAL RETURN,
  2409. C          J          IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
  2410. C                     WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
  2411. C
  2412. C     CALLS CDIV FOR COMPLEX DIVISION.
  2413. C     CALLS CSROOT FOR COMPLEX SQUARE ROOT.
  2414. C
  2415. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  2416. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  2417. C
  2418. C     THIS VERSION DATED AUGUST 1983.
  2419. C
  2420. C     ------------------------------------------------------------------
  2421. C
  2422.       IERR = 0
  2423. C     .......... STORE ROOTS ISOLATED BY CBAL ..........
  2424.       DO 200 I = 1, N
  2425.          IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
  2426.          WR(I) = HR(I,I)
  2427.          WI(I) = HI(I,I)
  2428.   200 CONTINUE
  2429. C
  2430.       EN = IGH
  2431.       TR = 0.0D0
  2432.       TI = 0.0D0
  2433.       ITN = 30*N
  2434. C     .......... SEARCH FOR NEXT EIGENVALUE ..........
  2435.   220 IF (EN .LT. LOW) GO TO 1001
  2436.       ITS = 0
  2437.       ENM1 = EN - 1
  2438. C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
  2439. C                FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
  2440.   240 DO 260 LL = LOW, EN
  2441.          L = EN + LOW - LL
  2442.          IF (L .EQ. LOW) GO TO 300
  2443.          TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
  2444.      X            + DABS(HR(L,L)) + DABS(HI(L,L))
  2445.          TST2 = TST1 + DABS(HR(L,L-1)) + DABS(HI(L,L-1))
  2446.          IF (TST2 .EQ. TST1) GO TO 300
  2447.   260 CONTINUE
  2448. C     .......... FORM SHIFT ..........
  2449.   300 IF (L .EQ. EN) GO TO 660
  2450.       IF (ITN .EQ. 0) GO TO 1000
  2451.       IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320
  2452.       SR = HR(EN,EN)
  2453.       SI = HI(EN,EN)
  2454.       XR = HR(ENM1,EN) * HR(EN,ENM1) - HI(ENM1,EN) * HI(EN,ENM1)
  2455.       XI = HR(ENM1,EN) * HI(EN,ENM1) + HI(ENM1,EN) * HR(EN,ENM1)
  2456.       IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 340
  2457.       YR = (HR(ENM1,ENM1) - SR) / 2.0D0
  2458.       YI = (HI(ENM1,ENM1) - SI) / 2.0D0
  2459.       CALL CSROOT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
  2460.       IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GO TO 310
  2461.       ZZR = -ZZR
  2462.       ZZI = -ZZI
  2463.   310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
  2464.       SR = SR - XR
  2465.       SI = SI - XI
  2466.       GO TO 340
  2467. C     .......... FORM EXCEPTIONAL SHIFT ..........
  2468.   320 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
  2469.       SI = DABS(HI(EN,ENM1)) + DABS(HI(ENM1,EN-2))
  2470. C
  2471.   340 DO 360 I = LOW, EN
  2472.          HR(I,I) = HR(I,I) - SR
  2473.          HI(I,I) = HI(I,I) - SI
  2474.   360 CONTINUE
  2475. C
  2476.       TR = TR + SR
  2477.       TI = TI + SI
  2478.       ITS = ITS + 1
  2479.       ITN = ITN - 1
  2480. C     .......... LOOK FOR TWO CONSECUTIVE SMALL
  2481. C                SUB-DIAGONAL ELEMENTS ..........
  2482.       XR = DABS(HR(ENM1,ENM1)) + DABS(HI(ENM1,ENM1))
  2483.       YR = DABS(HR(EN,ENM1)) + DABS(HI(EN,ENM1))
  2484.       ZZR = DABS(HR(EN,EN)) + DABS(HI(EN,EN))
  2485. C     .......... FOR M=EN-1 STEP -1 UNTIL L DO -- ..........
  2486.       DO 380 MM = L, ENM1
  2487.          M = ENM1 + L - MM
  2488.          IF (M .EQ. L) GO TO 420
  2489.          YI = YR
  2490.          YR = DABS(HR(M,M-1)) + DABS(HI(M,M-1))
  2491.          XI = ZZR
  2492.          ZZR = XR
  2493.          XR = DABS(HR(M-1,M-1)) + DABS(HI(M-1,M-1))
  2494.          TST1 = ZZR / YI * (ZZR + XR + XI)
  2495.          TST2 = TST1 + YR
  2496.          IF (TST2 .EQ. TST1) GO TO 420
  2497.   380 CONTINUE
  2498. C     .......... TRIANGULAR DECOMPOSITION H=L*R ..........
  2499.   420 MP1 = M + 1
  2500. C
  2501.       DO 520 I = MP1, EN
  2502.          IM1 = I - 1
  2503.          XR = HR(IM1,IM1)
  2504.          XI = HI(IM1,IM1)
  2505.          YR = HR(I,IM1)
  2506.          YI = HI(I,IM1)
  2507.          IF (DABS(XR) + DABS(XI) .GE. DABS(YR) + DABS(YI)) GO TO 460
  2508. C     .......... INTERCHANGE ROWS OF HR AND HI ..........
  2509.          DO 440 J = IM1, EN
  2510.             ZZR = HR(IM1,J)
  2511.             HR(IM1,J) = HR(I,J)
  2512.             HR(I,J) = ZZR
  2513.             ZZI = HI(IM1,J)
  2514.             HI(IM1,J) = HI(I,J)
  2515.             HI(I,J) = ZZI
  2516.   440    CONTINUE
  2517. C
  2518.          CALL CDIV(XR,XI,YR,YI,ZZR,ZZI)
  2519.          WR(I) = 1.0D0
  2520.          GO TO 480
  2521.   460    CALL CDIV(YR,YI,XR,XI,ZZR,ZZI)
  2522.          WR(I) = -1.0D0
  2523.   480    HR(I,IM1) = ZZR
  2524.          HI(I,IM1) = ZZI
  2525. C
  2526.          DO 500 J = I, EN
  2527.             HR(I,J) = HR(I,J) - ZZR * HR(IM1,J) + ZZI * HI(IM1,J)
  2528.             HI(I,J) = HI(I,J) - ZZR * HI(IM1,J) - ZZI * HR(IM1,J)
  2529.   500    CONTINUE
  2530. C
  2531.   520 CONTINUE
  2532. C     .......... COMPOSITION R*L=H ..........
  2533.       DO 640 J = MP1, EN
  2534.          XR = HR(J,J-1)
  2535.          XI = HI(J,J-1)
  2536.          HR(J,J-1) = 0.0D0
  2537.          HI(J,J-1) = 0.0D0
  2538. C     .......... INTERCHANGE COLUMNS OF HR AND HI,
  2539. C                IF NECESSARY ..........
  2540.          IF (WR(J) .LE. 0.0D0) GO TO 580
  2541. C
  2542.          DO 540 I = L, J
  2543.             ZZR = HR(I,J-1)
  2544.             HR(I,J-1) = HR(I,J)
  2545.             HR(I,J) = ZZR
  2546.             ZZI = HI(I,J-1)
  2547.             HI(I,J-1) = HI(I,J)
  2548.             HI(I,J) = ZZI
  2549.   540    CONTINUE
  2550. C
  2551.   580    DO 600 I = L, J
  2552.             HR(I,J-1) = HR(I,J-1) + XR * HR(I,J) - XI * HI(I,J)
  2553.             HI(I,J-1) = HI(I,J-1) + XR * HI(I,J) + XI * HR(I,J)
  2554.   600    CONTINUE
  2555. C
  2556.   640 CONTINUE
  2557. C
  2558.       GO TO 240
  2559. C     .......... A ROOT FOUND ..........
  2560.   660 WR(EN) = HR(EN,EN) + TR
  2561.       WI(EN) = HI(EN,EN) + TI
  2562.       EN = ENM1
  2563.       GO TO 220
  2564. C     .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
  2565. C                CONVERGED AFTER 30*N ITERATIONS ..........
  2566.  1000 IERR = EN
  2567.  1001 RETURN
  2568.       END
  2569.       SUBROUTINE COMLR2(NM,N,LOW,IGH,INT,HR,HI,WR,WI,ZR,ZI,IERR)
  2570. C
  2571.       INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NM,NN,IGH,IM1,IP1,
  2572.      X        ITN,ITS,LOW,MP1,ENM1,IEND,IERR
  2573.       DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N)
  2574.       DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2
  2575.       INTEGER INT(IGH)
  2576. C
  2577. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMLR2,
  2578. C     NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON.
  2579. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
  2580. C
  2581. C     THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
  2582. C     OF A COMPLEX UPPER HESSENBERG MATRIX BY THE MODIFIED LR
  2583. C     METHOD.  THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
  2584. C     CAN ALSO BE FOUND IF  COMHES  HAS BEEN USED TO REDUCE
  2585. C     THIS GENERAL MATRIX TO HESSENBERG FORM.
  2586. C
  2587. C     ON INPUT
  2588. C
  2589. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  2590. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  2591. C          DIMENSION STATEMENT.
  2592. C
  2593. C        N IS THE ORDER OF THE MATRIX.
  2594. C
  2595. C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
  2596. C          SUBROUTINE  CBAL.  IF  CBAL  HAS NOT BEEN USED,
  2597. C          SET LOW=1, IGH=N.
  2598. C
  2599. C        INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS INTERCHANGED
  2600. C          IN THE REDUCTION BY  COMHES, IF PERFORMED.  ONLY ELEMENTS
  2601. C          LOW THROUGH IGH ARE USED.  IF THE EIGENVECTORS OF THE HESSEN-
  2602. C          BERG MATRIX ARE DESIRED, SET INT(J)=J FOR THESE ELEMENTS.
  2603. C
  2604. C        HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
  2605. C          RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
  2606. C          THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN THE
  2607. C          MULTIPLIERS WHICH WERE USED IN THE REDUCTION BY  COMHES,
  2608. C          IF PERFORMED.  IF THE EIGENVECTORS OF THE HESSENBERG
  2609. C          MATRIX ARE DESIRED, THESE ELEMENTS MUST BE SET TO ZERO.
  2610. C
  2611. C     ON OUTPUT
  2612. C
  2613. C        THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
  2614. C          DESTROYED, BUT THE LOCATION HR(1,1) CONTAINS THE NORM
  2615. C          OF THE TRIANGULARIZED MATRIX.
  2616. C
  2617. C        WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
  2618. C          RESPECTIVELY, OF THE EIGENVALUES.  IF AN ERROR
  2619. C          EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
  2620. C          FOR INDICES IERR+1,...,N.
  2621. C
  2622. C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
  2623. C          RESPECTIVELY, OF THE EIGENVECTORS.  THE EIGENVECTORS
  2624. C          ARE UNNORMALIZED.  IF AN ERROR EXIT IS MADE, NONE OF
  2625. C          THE EIGENVECTORS HAS BEEN FOUND.
  2626. C
  2627. C        IERR IS SET TO
  2628. C          ZERO       FOR NORMAL RETURN,
  2629. C          J          IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
  2630. C                     WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
  2631. C
  2632. C     
  2633. C     CALLS CDIV FOR COMPLEX DIVISION.
  2634. C     CALLS CSROOT FOR COMPLEX SQUARE ROOT.
  2635. C
  2636. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  2637. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  2638. C
  2639. C     THIS VERSION DATED AUGUST 1983.
  2640. C
  2641. C     ------------------------------------------------------------------
  2642. C
  2643.       IERR = 0
  2644. C     .......... INITIALIZE EIGENVECTOR MATRIX ..........
  2645.       DO 100 I = 1, N
  2646. C
  2647.          DO 100 J = 1, N
  2648.             ZR(I,J) = 0.0D0
  2649.             ZI(I,J) = 0.0D0
  2650.             IF (I .EQ. J) ZR(I,J) = 1.0D0
  2651.   100 CONTINUE
  2652. C     .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
  2653. C                FROM THE INFORMATION LEFT BY COMHES ..........
  2654.       IEND = IGH - LOW - 1
  2655.       IF (IEND .LE. 0) GO TO 180
  2656. C     .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
  2657.       DO 160 II = 1, IEND
  2658.          I = IGH - II
  2659.          IP1 = I + 1
  2660. C
  2661.          DO 120 K = IP1, IGH
  2662.             ZR(K,I) = HR(K,I-1)
  2663.             ZI(K,I) = HI(K,I-1)
  2664.   120    CONTINUE
  2665. C
  2666.          J = INT(I)
  2667.          IF (I .EQ. J) GO TO 160
  2668. C
  2669.          DO 140 K = I, IGH
  2670.             ZR(I,K) = ZR(J,K)
  2671.             ZI(I,K) = ZI(J,K)
  2672.             ZR(J,K) = 0.0D0
  2673.             ZI(J,K) = 0.0D0
  2674.   140    CONTINUE
  2675. C
  2676.          ZR(J,I) = 1.0D0
  2677.   160 CONTINUE
  2678. C     .......... STORE ROOTS ISOLATED BY CBAL ..........
  2679.   180 DO 200 I = 1, N
  2680.          IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
  2681.          WR(I) = HR(I,I)
  2682.          WI(I) = HI(I,I)
  2683.   200 CONTINUE
  2684. C
  2685.       EN = IGH
  2686.       TR = 0.0D0
  2687.       TI = 0.0D0
  2688.       ITN = 30*N
  2689. C     .......... SEARCH FOR NEXT EIGENVALUE ..........
  2690.   220 IF (EN .LT. LOW) GO TO 680
  2691.       ITS = 0
  2692.       ENM1 = EN - 1
  2693. C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
  2694. C                FOR L=EN STEP -1 UNTIL LOW DO -- ..........
  2695.   240 DO 260 LL = LOW, EN
  2696.          L = EN + LOW - LL
  2697.          IF (L .EQ. LOW) GO TO 300
  2698.          TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
  2699.      X            + DABS(HR(L,L)) + DABS(HI(L,L))
  2700.          TST2 = TST1 + DABS(HR(L,L-1)) + DABS(HI(L,L-1))
  2701.          IF (TST2 .EQ. TST1) GO TO 300
  2702.   260 CONTINUE
  2703. C     .......... FORM SHIFT ..........
  2704.   300 IF (L .EQ. EN) GO TO 660
  2705.       IF (ITN .EQ. 0) GO TO 1000
  2706.       IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320
  2707.       SR = HR(EN,EN)
  2708.       SI = HI(EN,EN)
  2709.       XR = HR(ENM1,EN) * HR(EN,ENM1) - HI(ENM1,EN) * HI(EN,ENM1)
  2710.       XI = HR(ENM1,EN) * HI(EN,ENM1) + HI(ENM1,EN) * HR(EN,ENM1)
  2711.       IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 340
  2712.       YR = (HR(ENM1,ENM1) - SR) / 2.0D0
  2713.       YI = (HI(ENM1,ENM1) - SI) / 2.0D0
  2714.       CALL CSROOT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
  2715.       IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GO TO 310
  2716.       ZZR = -ZZR
  2717.       ZZI = -ZZI
  2718.   310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
  2719.       SR = SR - XR
  2720.       SI = SI - XI
  2721.       GO TO 340
  2722. C     .......... FORM EXCEPTIONAL SHIFT ..........
  2723.   320 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
  2724.       SI = DABS(HI(EN,ENM1)) + DABS(HI(ENM1,EN-2))
  2725. C
  2726.   340 DO 360 I = LOW, EN
  2727.          HR(I,I) = HR(I,I) - SR
  2728.          HI(I,I) = HI(I,I) - SI
  2729.   360 CONTINUE
  2730. C
  2731.       TR = TR + SR
  2732.       TI = TI + SI
  2733.       ITS = ITS + 1
  2734.       ITN = ITN - 1
  2735. C     .......... LOOK FOR TWO CONSECUTIVE SMALL
  2736. C                SUB-DIAGONAL ELEMENTS ..........
  2737.       XR = DABS(HR(ENM1,ENM1)) + DABS(HI(ENM1,ENM1))
  2738.       YR = DABS(HR(EN,ENM1)) + DABS(HI(EN,ENM1))
  2739.       ZZR = DABS(HR(EN,EN)) + DABS(HI(EN,EN))
  2740. C     .......... FOR M=EN-1 STEP -1 UNTIL L DO -- ..........
  2741.       DO 380 MM = L, ENM1
  2742.          M = ENM1 + L - MM
  2743.          IF (M .EQ. L) GO TO 420
  2744.          YI = YR
  2745.          YR = DABS(HR(M,M-1)) + DABS(HI(M,M-1))
  2746.          XI = ZZR
  2747.          ZZR = XR
  2748.          XR = DABS(HR(M-1,M-1)) + DABS(HI(M-1,M-1))
  2749.          TST1 = ZZR / YI * (ZZR + XR + XI)
  2750.          TST2 = TST1 + YR
  2751.          IF (TST2 .EQ. TST1) GO TO 420
  2752.   380 CONTINUE
  2753. C     .......... TRIANGULAR DECOMPOSITION H=L*R ..........
  2754.   420 MP1 = M + 1
  2755. C
  2756.       DO 520 I = MP1, EN
  2757.          IM1 = I - 1
  2758.          XR = HR(IM1,IM1)
  2759.          XI = HI(IM1,IM1)
  2760.          YR = HR(I,IM1)
  2761.          YI = HI(I,IM1)
  2762.          IF (DABS(XR) + DABS(XI) .GE. DABS(YR) + DABS(YI)) GO TO 460
  2763. C     .......... INTERCHANGE ROWS OF HR AND HI ..........
  2764.          DO 440 J = IM1, N
  2765.             ZZR = HR(IM1,J)
  2766.             HR(IM1,J) = HR(I,J)
  2767.             HR(I,J) = ZZR
  2768.             ZZI = HI(IM1,J)
  2769.             HI(IM1,J) = HI(I,J)
  2770.             HI(I,J) = ZZI
  2771.   440    CONTINUE
  2772. C
  2773.          CALL CDIV(XR,XI,YR,YI,ZZR,ZZI)
  2774.          WR(I) = 1.0D0
  2775.          GO TO 480
  2776.   460    CALL CDIV(YR,YI,XR,XI,ZZR,ZZI)
  2777.          WR(I) = -1.0D0
  2778.   480    HR(I,IM1) = ZZR
  2779.          HI(I,IM1) = ZZI
  2780. C
  2781.          DO 500 J = I, N
  2782.             HR(I,J) = HR(I,J) - ZZR * HR(IM1,J) + ZZI * HI(IM1,J)
  2783.             HI(I,J) = HI(I,J) - ZZR * HI(IM1,J) - ZZI * HR(IM1,J)
  2784.   500    CONTINUE
  2785. C
  2786.   520 CONTINUE
  2787. C     .......... COMPOSITION R*L=H ..........
  2788.       DO 640 J = MP1, EN
  2789.          XR = HR(J,J-1)
  2790.          XI = HI(J,J-1)
  2791.          HR(J,J-1) = 0.0D0
  2792.          HI(J,J-1) = 0.0D0
  2793. C     .......... INTERCHANGE COLUMNS OF HR, HI, ZR, AND ZI,
  2794. C                IF NECESSARY ..........
  2795.          IF (WR(J) .LE. 0.0D0) GO TO 580
  2796. C
  2797.          DO 540 I = 1, J
  2798.             ZZR = HR(I,J-1)
  2799.             HR(I,J-1) = HR(I,J)
  2800.             HR(I,J) = ZZR
  2801.             ZZI = HI(I,J-1)
  2802.             HI(I,J-1) = HI(I,J)
  2803.             HI(I,J) = ZZI
  2804.   540    CONTINUE
  2805. C
  2806.          DO 560 I = LOW, IGH
  2807.             ZZR = ZR(I,J-1)
  2808.             ZR(I,J-1) = ZR(I,J)
  2809.             ZR(I,J) = ZZR
  2810.             ZZI = ZI(I,J-1)
  2811.             ZI(I,J-1) = ZI(I,J)
  2812.             ZI(I,J) = ZZI
  2813.   560    CONTINUE
  2814. C
  2815.   580    DO 600 I = 1, J
  2816.             HR(I,J-1) = HR(I,J-1) + XR * HR(I,J) - XI * HI(I,J)
  2817.             HI(I,J-1) = HI(I,J-1) + XR * HI(I,J) + XI * HR(I,J)
  2818.   600    CONTINUE
  2819. C     .......... ACCUMULATE TRANSFORMATIONS ..........
  2820.          DO 620 I = LOW, IGH
  2821.             ZR(I,J-1) = ZR(I,J-1) + XR * ZR(I,J) - XI * ZI(I,J)
  2822.             ZI(I,J-1) = ZI(I,J-1) + XR * ZI(I,J) + XI * ZR(I,J)
  2823.   620    CONTINUE
  2824. C
  2825.   640 CONTINUE
  2826. C
  2827.       GO TO 240
  2828. C     .......... A ROOT FOUND ..........
  2829.   660 HR(EN,EN) = HR(EN,EN) + TR
  2830.       WR(EN) = HR(EN,EN)
  2831.       HI(EN,EN) = HI(EN,EN) + TI
  2832.       WI(EN) = HI(EN,EN)
  2833.       EN = ENM1
  2834.       GO TO 220
  2835. C     .......... ALL ROOTS FOUND.  BACKSUBSTITUTE TO FIND
  2836. C                VECTORS OF UPPER TRIANGULAR FORM ..........
  2837.   680 NORM = 0.0D0
  2838. C
  2839.       DO 720 I = 1, N
  2840. C
  2841.          DO 720 J = I, N
  2842.             TR = DABS(HR(I,J)) + DABS(HI(I,J))
  2843.             IF (TR .GT. NORM) NORM = TR
  2844.   720 CONTINUE
  2845. C
  2846.       HR(1,1) = NORM
  2847.       IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GO TO 1001
  2848. C     .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
  2849.       DO 800 NN = 2, N
  2850.          EN = N + 2 - NN
  2851.          XR = WR(EN)
  2852.          XI = WI(EN)
  2853.          HR(EN,EN) = 1.0D0
  2854.          HI(EN,EN) = 0.0D0
  2855.          ENM1 = EN - 1
  2856. C     .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
  2857.          DO 780 II = 1, ENM1
  2858.             I = EN - II
  2859.             ZZR = 0.0D0
  2860.             ZZI = 0.0D0
  2861.             IP1 = I + 1
  2862. C
  2863.             DO 740 J = IP1, EN
  2864.                ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
  2865.                ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
  2866.   740       CONTINUE
  2867. C
  2868.             YR = XR - WR(I)
  2869.             YI = XI - WI(I)
  2870.             IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GO TO 765
  2871.                TST1 = NORM
  2872.                YR = TST1
  2873.   760          YR = 0.01D0 * YR
  2874.                TST2 = NORM + YR
  2875.                IF (TST2 .GT. TST1) GO TO 760
  2876.   765       CONTINUE
  2877.             CALL CDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
  2878. C     .......... OVERFLOW CONTROL ..........
  2879.             TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
  2880.             IF (TR .EQ. 0.0D0) GO TO 780
  2881.             TST1 = TR
  2882.             TST2 = TST1 + 1.0D0/TST1
  2883.             IF (TST2 .GT. TST1) GO TO 780
  2884.             DO 770 J = I, EN
  2885.                HR(J,EN) = HR(J,EN)/TR
  2886.                HI(J,EN) = HI(J,EN)/TR
  2887.   770       CONTINUE
  2888. C
  2889.   780    CONTINUE
  2890. C
  2891.   800 CONTINUE
  2892. C     .......... END BACKSUBSTITUTION ..........
  2893.       ENM1 = N - 1
  2894. C     .......... VECTORS OF ISOLATED ROOTS ..........
  2895.       DO  840 I = 1, ENM1
  2896.          IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840
  2897.          IP1 = I + 1
  2898. C
  2899.          DO 820 J = IP1, N
  2900.             ZR(I,J) = HR(I,J)
  2901.             ZI(I,J) = HI(I,J)
  2902.   820    CONTINUE
  2903. C
  2904.   840 CONTINUE
  2905. C     .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
  2906. C                VECTORS OF ORIGINAL FULL MATRIX.
  2907. C                FOR J=N STEP -1 UNTIL LOW+1 DO -- ..........
  2908.       DO 880 JJ = LOW, ENM1
  2909.          J = N + LOW - JJ
  2910.          M = MIN0(J,IGH)
  2911. C
  2912.          DO 880 I = LOW, IGH
  2913.             ZZR = 0.0D0
  2914.             ZZI = 0.0D0
  2915. C
  2916.             DO 860 K = LOW, M
  2917.                ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
  2918.                ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
  2919.   860       CONTINUE
  2920. C
  2921.             ZR(I,J) = ZZR
  2922.             ZI(I,J) = ZZI
  2923.   880 CONTINUE
  2924. C
  2925.       GO TO 1001
  2926. C     .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
  2927. C                CONVERGED AFTER 30*N ITERATIONS ..........
  2928.  1000 IERR = EN
  2929.  1001 RETURN
  2930.       END
  2931.       SUBROUTINE COMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
  2932. C
  2933.       INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
  2934.       DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N)
  2935.       DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
  2936.      X       PYTHAG
  2937. C
  2938. C     THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
  2939. C     ALGOL PROCEDURE  COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
  2940. C     AND WILKINSON.
  2941. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
  2942. C     THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
  2943. C     (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
  2944. C
  2945. C     THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
  2946. C     UPPER HESSENBERG MATRIX BY THE QR METHOD.
  2947. C
  2948. C     ON INPUT
  2949. C
  2950. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  2951. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  2952. C          DIMENSION STATEMENT.
  2953. C
  2954. C        N IS THE ORDER OF THE MATRIX.
  2955. C
  2956. C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
  2957. C          SUBROUTINE  CBAL.  IF  CBAL  HAS NOT BEEN USED,
  2958. C          SET LOW=1, IGH=N.
  2959. C
  2960. C        HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
  2961. C          RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
  2962. C          THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
  2963. C          INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
  2964. C          THE REDUCTION BY  CORTH, IF PERFORMED.
  2965. C
  2966. C     ON OUTPUT
  2967. C
  2968. C        THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
  2969. C          DESTROYED.  THEREFORE, THEY MUST BE SAVED BEFORE
  2970. C          CALLING  COMQR  IF SUBSEQUENT CALCULATION OF
  2971. C          EIGENVECTORS IS TO BE PERFORMED.
  2972. C
  2973. C        WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
  2974. C          RESPECTIVELY, OF THE EIGENVALUES.  IF AN ERROR
  2975. C          EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
  2976. C          FOR INDICES IERR+1,...,N.
  2977. C
  2978. C        IERR IS SET TO
  2979. C          ZERO       FOR NORMAL RETURN,
  2980. C          J          IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
  2981. C                     WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
  2982. C
  2983. C     CALLS CDIV FOR COMPLEX DIVISION.
  2984. C     CALLS CSROOT FOR COMPLEX SQUARE ROOT.
  2985. C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
  2986. C
  2987. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  2988. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  2989. C
  2990. C     THIS VERSION DATED AUGUST 1983.
  2991. C
  2992. C     ------------------------------------------------------------------
  2993. C
  2994.       IERR = 0
  2995.       IF (LOW .EQ. IGH) GO TO 180
  2996. C     .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
  2997.       L = LOW + 1
  2998. C
  2999.       DO 170 I = L, IGH
  3000.          LL = MIN0(I+1,IGH)
  3001.          IF (HI(I,I-1) .EQ. 0.0D0) GO TO 170
  3002.          NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
  3003.          YR = HR(I,I-1) / NORM
  3004.          YI = HI(I,I-1) / NORM
  3005.          HR(I,I-1) = NORM
  3006.          HI(I,I-1) = 0.0D0
  3007. C
  3008.          DO 155 J = I, IGH
  3009.             SI = YR * HI(I,J) - YI * HR(I,J)
  3010.             HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
  3011.             HI(I,J) = SI
  3012.   155    CONTINUE
  3013. C
  3014.          DO 160 J = LOW, LL
  3015.             SI = YR * HI(J,I) + YI * HR(J,I)
  3016.             HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
  3017.             HI(J,I) = SI
  3018.   160    CONTINUE
  3019. C
  3020.   170 CONTINUE
  3021. C     .......... STORE ROOTS ISOLATED BY CBAL ..........
  3022.   180 DO 200 I = 1, N
  3023.          IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
  3024.          WR(I) = HR(I,I)
  3025.          WI(I) = HI(I,I)
  3026.   200 CONTINUE
  3027. C
  3028.       EN = IGH
  3029.       TR = 0.0D0
  3030.       TI = 0.0D0
  3031.       ITN = 30*N
  3032. C     .......... SEARCH FOR NEXT EIGENVALUE ..........
  3033.   220 IF (EN .LT. LOW) GO TO 1001
  3034.       ITS = 0
  3035.       ENM1 = EN - 1
  3036. C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
  3037. C                FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
  3038.   240 DO 260 LL = LOW, EN
  3039.          L = EN + LOW - LL
  3040.          IF (L .EQ. LOW) GO TO 300
  3041.          TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
  3042.      X            + DABS(HR(L,L)) + DABS(HI(L,L))
  3043.          TST2 = TST1 + DABS(HR(L,L-1))
  3044.          IF (TST2 .EQ. TST1) GO TO 300
  3045.   260 CONTINUE
  3046. C     .......... FORM SHIFT ..........
  3047.   300 IF (L .EQ. EN) GO TO 660
  3048.       IF (ITN .EQ. 0) GO TO 1000
  3049.       IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320
  3050.       SR = HR(EN,EN)
  3051.       SI = HI(EN,EN)
  3052.       XR = HR(ENM1,EN) * HR(EN,ENM1)
  3053.       XI = HI(ENM1,EN) * HR(EN,ENM1)
  3054.       IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 340
  3055.       YR = (HR(ENM1,ENM1) - SR) / 2.0D0
  3056.       YI = (HI(ENM1,ENM1) - SI) / 2.0D0
  3057.       CALL CSROOT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
  3058.       IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GO TO 310
  3059.       ZZR = -ZZR
  3060.       ZZI = -ZZI
  3061.   310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
  3062.       SR = SR - XR
  3063.       SI = SI - XI
  3064.       GO TO 340
  3065. C     .......... FORM EXCEPTIONAL SHIFT ..........
  3066.   320 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
  3067.       SI = 0.0D0
  3068. C
  3069.   340 DO 360 I = LOW, EN
  3070.          HR(I,I) = HR(I,I) - SR
  3071.          HI(I,I) = HI(I,I) - SI
  3072.   360 CONTINUE
  3073. C
  3074.       TR = TR + SR
  3075.       TI = TI + SI
  3076.       ITS = ITS + 1
  3077.       ITN = ITN - 1
  3078. C     .......... REDUCE TO TRIANGLE (ROWS) ..........
  3079.       LP1 = L + 1
  3080. C
  3081.       DO 500 I = LP1, EN
  3082.          SR = HR(I,I-1)
  3083.          HR(I,I-1) = 0.0D0
  3084.          NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
  3085.          XR = HR(I-1,I-1) / NORM
  3086.          WR(I-1) = XR
  3087.          XI = HI(I-1,I-1) / NORM
  3088.          WI(I-1) = XI
  3089.          HR(I-1,I-1) = NORM
  3090.          HI(I-1,I-1) = 0.0D0
  3091.          HI(I,I-1) = SR / NORM
  3092. C
  3093.          DO 490 J = I, EN
  3094.             YR = HR(I-1,J)
  3095.             YI = HI(I-1,J)
  3096.             ZZR = HR(I,J)
  3097.             ZZI = HI(I,J)
  3098.             HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
  3099.             HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
  3100.             HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
  3101.             HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
  3102.   490    CONTINUE
  3103. C
  3104.   500 CONTINUE
  3105. C
  3106.       SI = HI(EN,EN)
  3107.       IF (SI .EQ. 0.0D0) GO TO 540
  3108.       NORM = PYTHAG(HR(EN,EN),SI)
  3109.       SR = HR(EN,EN) / NORM
  3110.       SI = SI / NORM
  3111.       HR(EN,EN) = NORM
  3112.       HI(EN,EN) = 0.0D0
  3113. C     .......... INVERSE OPERATION (COLUMNS) ..........
  3114.   540 DO 600 J = LP1, EN
  3115.          XR = WR(J-1)
  3116.          XI = WI(J-1)
  3117. C
  3118.          DO 580 I = L, J
  3119.             YR = HR(I,J-1)
  3120.             YI = 0.0D0
  3121.             ZZR = HR(I,J)
  3122.             ZZI = HI(I,J)
  3123.             IF (I .EQ. J) GO TO 560
  3124.             YI = HI(I,J-1)
  3125.             HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
  3126.   560       HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
  3127.             HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
  3128.             HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
  3129.   580    CONTINUE
  3130. C
  3131.   600 CONTINUE
  3132. C
  3133.       IF (SI .EQ. 0.0D0) GO TO 240
  3134. C
  3135.       DO 630 I = L, EN
  3136.          YR = HR(I,EN)
  3137.          YI = HI(I,EN)
  3138.          HR(I,EN) = SR * YR - SI * YI
  3139.          HI(I,EN) = SR * YI + SI * YR
  3140.   630 CONTINUE
  3141. C
  3142.       GO TO 240
  3143. C     .......... A ROOT FOUND ..........
  3144.   660 WR(EN) = HR(EN,EN) + TR
  3145.       WI(EN) = HI(EN,EN) + TI
  3146.       EN = ENM1
  3147.       GO TO 220
  3148. C     .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
  3149. C                CONVERGED AFTER 30*N ITERATIONS ..........
  3150.  1000 IERR = EN
  3151.  1001 RETURN
  3152.       END
  3153.       SUBROUTINE COMQR2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
  3154. C
  3155.       INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
  3156.      X        ITN,ITS,LOW,LP1,ENM1,IEND,IERR
  3157.       DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N),
  3158.      X       ORTR(IGH),ORTI(IGH)
  3159.       DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
  3160.      X       PYTHAG
  3161. C
  3162. C     THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
  3163. C     ALGOL PROCEDURE  COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
  3164. C     AND WILKINSON.
  3165. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
  3166. C     THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
  3167. C     (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
  3168. C
  3169. C     THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
  3170. C     OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
  3171. C     METHOD.  THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
  3172. C     CAN ALSO BE FOUND IF  CORTH  HAS BEEN USED TO REDUCE
  3173. C     THIS GENERAL MATRIX TO HESSENBERG FORM.
  3174. C
  3175. C     ON INPUT
  3176. C
  3177. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  3178. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  3179. C          DIMENSION STATEMENT.
  3180. C
  3181. C        N IS THE ORDER OF THE MATRIX.
  3182. C
  3183. C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
  3184. C          SUBROUTINE  CBAL.  IF  CBAL  HAS NOT BEEN USED,
  3185. C          SET LOW=1, IGH=N.
  3186. C
  3187. C        ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
  3188. C          FORMATIONS USED IN THE REDUCTION BY  CORTH, IF PERFORMED.
  3189. C          ONLY ELEMENTS LOW THROUGH IGH ARE USED.  IF THE EIGENVECTORS
  3190. C          OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
  3191. C          ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
  3192. C
  3193. C        HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
  3194. C          RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
  3195. C          THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
  3196. C          INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
  3197. C          REDUCTION BY  CORTH, IF PERFORMED.  IF THE EIGENVECTORS OF
  3198. C          THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
  3199. C          ARBITRARY.
  3200. C
  3201. C     ON OUTPUT
  3202. C
  3203. C        ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
  3204. C          HAVE BEEN DESTROYED.
  3205. C
  3206. C        WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
  3207. C          RESPECTIVELY, OF THE EIGENVALUES.  IF AN ERROR
  3208. C          EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
  3209. C          FOR INDICES IERR+1,...,N.
  3210. C
  3211. C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
  3212. C          RESPECTIVELY, OF THE EIGENVECTORS.  THE EIGENVECTORS
  3213. C          ARE UNNORMALIZED.  IF AN ERROR EXIT IS MADE, NONE OF
  3214. C          THE EIGENVECTORS HAS BEEN FOUND.
  3215. C
  3216. C        IERR IS SET TO
  3217. C          ZERO       FOR NORMAL RETURN,
  3218. C          J          IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
  3219. C                     WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
  3220. C
  3221. C     CALLS CDIV FOR COMPLEX DIVISION.
  3222. C     CALLS CSROOT FOR COMPLEX SQUARE ROOT.
  3223. C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
  3224. C
  3225. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  3226. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  3227. C
  3228. C     THIS VERSION DATED AUGUST 1983.
  3229. C
  3230. C     ------------------------------------------------------------------
  3231. C
  3232.       IERR = 0
  3233. C     .......... INITIALIZE EIGENVECTOR MATRIX ..........
  3234.       DO 101 J = 1, N
  3235. C
  3236.          DO 100 I = 1, N
  3237.             ZR(I,J) = 0.0D0
  3238.             ZI(I,J) = 0.0D0
  3239.   100    CONTINUE
  3240.          ZR(J,J) = 1.0D0
  3241.   101 CONTINUE
  3242. C     .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
  3243. C                FROM THE INFORMATION LEFT BY CORTH ..........
  3244.       IEND = IGH - LOW - 1
  3245.       IF (IEND) 180, 150, 105
  3246. C     .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
  3247.   105 DO 140 II = 1, IEND
  3248.          I = IGH - II
  3249.          IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GO TO 140
  3250.          IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GO TO 140
  3251. C     .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
  3252.          NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
  3253.          IP1 = I + 1
  3254. C
  3255.          DO 110 K = IP1, IGH
  3256.             ORTR(K) = HR(K,I-1)
  3257.             ORTI(K) = HI(K,I-1)
  3258.   110    CONTINUE
  3259. C
  3260.          DO 130 J = I, IGH
  3261.             SR = 0.0D0
  3262.             SI = 0.0D0
  3263. C
  3264.             DO 115 K = I, IGH
  3265.                SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
  3266.                SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
  3267.   115       CONTINUE
  3268. C
  3269.             SR = SR / NORM
  3270.             SI = SI / NORM
  3271. C
  3272.             DO 120 K = I, IGH
  3273.                ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
  3274.                ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
  3275.   120       CONTINUE
  3276. C
  3277.   130    CONTINUE
  3278. C
  3279.   140 CONTINUE
  3280. C     .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
  3281.   150 L = LOW + 1
  3282. C
  3283.       DO 170 I = L, IGH
  3284.          LL = MIN0(I+1,IGH)
  3285.          IF (HI(I,I-1) .EQ. 0.0D0) GO TO 170
  3286.          NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
  3287.          YR = HR(I,I-1) / NORM
  3288.          YI = HI(I,I-1) / NORM
  3289.          HR(I,I-1) = NORM
  3290.          HI(I,I-1) = 0.0D0
  3291. C
  3292.          DO 155 J = I, N
  3293.             SI = YR * HI(I,J) - YI * HR(I,J)
  3294.             HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
  3295.             HI(I,J) = SI
  3296.   155    CONTINUE
  3297. C
  3298.          DO 160 J = 1, LL
  3299.             SI = YR * HI(J,I) + YI * HR(J,I)
  3300.             HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
  3301.             HI(J,I) = SI
  3302.   160    CONTINUE
  3303. C
  3304.          DO 165 J = LOW, IGH
  3305.             SI = YR * ZI(J,I) + YI * ZR(J,I)
  3306.             ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
  3307.             ZI(J,I) = SI
  3308.   165    CONTINUE
  3309. C
  3310.   170 CONTINUE
  3311. C     .......... STORE ROOTS ISOLATED BY CBAL ..........
  3312.   180 DO 200 I = 1, N
  3313.          IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
  3314.          WR(I) = HR(I,I)
  3315.          WI(I) = HI(I,I)
  3316.   200 CONTINUE
  3317. C
  3318.       EN = IGH
  3319.       TR = 0.0D0
  3320.       TI = 0.0D0
  3321.       ITN = 30*N
  3322. C     .......... SEARCH FOR NEXT EIGENVALUE ..........
  3323.   220 IF (EN .LT. LOW) GO TO 680
  3324.       ITS = 0
  3325.       ENM1 = EN - 1
  3326. C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
  3327. C                FOR L=EN STEP -1 UNTIL LOW DO -- ..........
  3328.   240 DO 260 LL = LOW, EN
  3329.          L = EN + LOW - LL
  3330.          IF (L .EQ. LOW) GO TO 300
  3331.          TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
  3332.      X            + DABS(HR(L,L)) + DABS(HI(L,L))
  3333.          TST2 = TST1 + DABS(HR(L,L-1))
  3334.          IF (TST2 .EQ. TST1) GO TO 300
  3335.   260 CONTINUE
  3336. C     .......... FORM SHIFT ..........
  3337.   300 IF (L .EQ. EN) GO TO 660
  3338.       IF (ITN .EQ. 0) GO TO 1000
  3339.       IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320
  3340.       SR = HR(EN,EN)
  3341.       SI = HI(EN,EN)
  3342.       XR = HR(ENM1,EN) * HR(EN,ENM1)
  3343.       XI = HI(ENM1,EN) * HR(EN,ENM1)
  3344.       IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 340
  3345.       YR = (HR(ENM1,ENM1) - SR) / 2.0D0
  3346.       YI = (HI(ENM1,ENM1) - SI) / 2.0D0
  3347.       CALL CSROOT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
  3348.       IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GO TO 310
  3349.       ZZR = -ZZR
  3350.       ZZI = -ZZI
  3351.   310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
  3352.       SR = SR - XR
  3353.       SI = SI - XI
  3354.       GO TO 340
  3355. C     .......... FORM EXCEPTIONAL SHIFT ..........
  3356.   320 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
  3357.       SI = 0.0D0
  3358. C
  3359.   340 DO 360 I = LOW, EN
  3360.          HR(I,I) = HR(I,I) - SR
  3361.          HI(I,I) = HI(I,I) - SI
  3362.   360 CONTINUE
  3363. C
  3364.       TR = TR + SR
  3365.       TI = TI + SI
  3366.       ITS = ITS + 1
  3367.       ITN = ITN - 1
  3368. C     .......... REDUCE TO TRIANGLE (ROWS) ..........
  3369.       LP1 = L + 1
  3370. C
  3371.       DO 500 I = LP1, EN
  3372.          SR = HR(I,I-1)
  3373.          HR(I,I-1) = 0.0D0
  3374.          NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
  3375.          XR = HR(I-1,I-1) / NORM
  3376.          WR(I-1) = XR
  3377.          XI = HI(I-1,I-1) / NORM
  3378.          WI(I-1) = XI
  3379.          HR(I-1,I-1) = NORM
  3380.          HI(I-1,I-1) = 0.0D0
  3381.          HI(I,I-1) = SR / NORM
  3382. C
  3383.          DO 490 J = I, N
  3384.             YR = HR(I-1,J)
  3385.             YI = HI(I-1,J)
  3386.             ZZR = HR(I,J)
  3387.             ZZI = HI(I,J)
  3388.             HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
  3389.             HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
  3390.             HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
  3391.             HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
  3392.   490    CONTINUE
  3393. C
  3394.   500 CONTINUE
  3395. C
  3396.       SI = HI(EN,EN)
  3397.       IF (SI .EQ. 0.0D0) GO TO 540
  3398.       NORM = PYTHAG(HR(EN,EN),SI)
  3399.       SR = HR(EN,EN) / NORM
  3400.       SI = SI / NORM
  3401.       HR(EN,EN) = NORM
  3402.       HI(EN,EN) = 0.0D0
  3403.       IF (EN .EQ. N) GO TO 540
  3404.       IP1 = EN + 1
  3405. C
  3406.       DO 520 J = IP1, N
  3407.          YR = HR(EN,J)
  3408.          YI = HI(EN,J)
  3409.          HR(EN,J) = SR * YR + SI * YI
  3410.          HI(EN,J) = SR * YI - SI * YR
  3411.   520 CONTINUE
  3412. C     .......... INVERSE OPERATION (COLUMNS) ..........
  3413.   540 DO 600 J = LP1, EN
  3414.          XR = WR(J-1)
  3415.          XI = WI(J-1)
  3416. C
  3417.          DO 580 I = 1, J
  3418.             YR = HR(I,J-1)
  3419.             YI = 0.0D0
  3420.             ZZR = HR(I,J)
  3421.             ZZI = HI(I,J)
  3422.             IF (I .EQ. J) GO TO 560
  3423.             YI = HI(I,J-1)
  3424.             HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
  3425.   560       HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
  3426.             HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
  3427.             HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
  3428.   580    CONTINUE
  3429. C
  3430.          DO 590 I = LOW, IGH
  3431.             YR = ZR(I,J-1)
  3432.             YI = ZI(I,J-1)
  3433.             ZZR = ZR(I,J)
  3434.             ZZI = ZI(I,J)
  3435.             ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
  3436.             ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
  3437.             ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
  3438.             ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
  3439.   590    CONTINUE
  3440. C
  3441.   600 CONTINUE
  3442. C
  3443.       IF (SI .EQ. 0.0D0) GO TO 240
  3444. C
  3445.       DO 630 I = 1, EN
  3446.          YR = HR(I,EN)
  3447.          YI = HI(I,EN)
  3448.          HR(I,EN) = SR * YR - SI * YI
  3449.          HI(I,EN) = SR * YI + SI * YR
  3450.   630 CONTINUE
  3451. C
  3452.       DO 640 I = LOW, IGH
  3453.          YR = ZR(I,EN)
  3454.          YI = ZI(I,EN)
  3455.          ZR(I,EN) = SR * YR - SI * YI
  3456.          ZI(I,EN) = SR * YI + SI * YR
  3457.   640 CONTINUE
  3458. C
  3459.       GO TO 240
  3460. C     .......... A ROOT FOUND ..........
  3461.   660 HR(EN,EN) = HR(EN,EN) + TR
  3462.       WR(EN) = HR(EN,EN)
  3463.       HI(EN,EN) = HI(EN,EN) + TI
  3464.       WI(EN) = HI(EN,EN)
  3465.       EN = ENM1
  3466.       GO TO 220
  3467. C     .......... ALL ROOTS FOUND.  BACKSUBSTITUTE TO FIND
  3468. C                VECTORS OF UPPER TRIANGULAR FORM ..........
  3469.   680 NORM = 0.0D0
  3470. C
  3471.       DO 720 I = 1, N
  3472. C
  3473.          DO 720 J = I, N
  3474.             TR = DABS(HR(I,J)) + DABS(HI(I,J))
  3475.             IF (TR .GT. NORM) NORM = TR
  3476.   720 CONTINUE
  3477. C
  3478.       IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GO TO 1001
  3479. C     .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
  3480.       DO 800 NN = 2, N
  3481.          EN = N + 2 - NN
  3482.          XR = WR(EN)
  3483.          XI = WI(EN)
  3484.          HR(EN,EN) = 1.0D0
  3485.          HI(EN,EN) = 0.0D0
  3486.          ENM1 = EN - 1
  3487. C     .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
  3488.          DO 780 II = 1, ENM1
  3489.             I = EN - II
  3490.             ZZR = 0.0D0
  3491.             ZZI = 0.0D0
  3492.             IP1 = I + 1
  3493. C
  3494.             DO 740 J = IP1, EN
  3495.                ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
  3496.                ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
  3497.   740       CONTINUE
  3498. C
  3499.             YR = XR - WR(I)
  3500.             YI = XI - WI(I)
  3501.             IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GO TO 765
  3502.                TST1 = NORM
  3503.                YR = TST1
  3504.   760          YR = 0.01D0 * YR
  3505.                TST2 = NORM + YR
  3506.                IF (TST2 .GT. TST1) GO TO 760
  3507.   765       CONTINUE
  3508.             CALL CDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
  3509. C     .......... OVERFLOW CONTROL ..........
  3510.             TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
  3511.             IF (TR .EQ. 0.0D0) GO TO 780
  3512.             TST1 = TR
  3513.             TST2 = TST1 + 1.0D0/TST1
  3514.             IF (TST2 .GT. TST1) GO TO 780
  3515.             DO 770 J = I, EN
  3516.                HR(J,EN) = HR(J,EN)/TR
  3517.                HI(J,EN) = HI(J,EN)/TR
  3518.   770       CONTINUE
  3519. C
  3520.   780    CONTINUE
  3521. C
  3522.   800 CONTINUE
  3523. C     .......... END BACKSUBSTITUTION ..........
  3524.       ENM1 = N - 1
  3525. C     .......... VECTORS OF ISOLATED ROOTS ..........
  3526.       DO  840 I = 1, ENM1
  3527.          IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840
  3528.          IP1 = I + 1
  3529. C
  3530.          DO 820 J = IP1, N
  3531.             ZR(I,J) = HR(I,J)
  3532.             ZI(I,J) = HI(I,J)
  3533.   820    CONTINUE
  3534. C
  3535.   840 CONTINUE
  3536. C     .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
  3537. C                VECTORS OF ORIGINAL FULL MATRIX.
  3538. C                FOR J=N STEP -1 UNTIL LOW+1 DO -- ..........
  3539.       DO 880 JJ = LOW, ENM1
  3540.          J = N + LOW - JJ
  3541.          M = MIN0(J,IGH)
  3542. C
  3543.          DO 880 I = LOW, IGH
  3544.             ZZR = 0.0D0
  3545.             ZZI = 0.0D0
  3546. C
  3547.             DO 860 K = LOW, M
  3548.                ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
  3549.                ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
  3550.   860       CONTINUE
  3551. C
  3552.             ZR(I,J) = ZZR
  3553.             ZI(I,J) = ZZI
  3554.   880 CONTINUE
  3555. C
  3556.       GO TO 1001
  3557. C     .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
  3558. C                CONVERGED AFTER 30*N ITERATIONS ..........
  3559.  1000 IERR = EN
  3560.  1001 RETURN
  3561.       END
  3562.       SUBROUTINE CORTB(NM,LOW,IGH,AR,AI,ORTR,ORTI,M,ZR,ZI)
  3563. C
  3564.       INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1
  3565.       DOUBLE PRECISION AR(NM,IGH),AI(NM,IGH),ORTR(IGH),ORTI(IGH),
  3566.      X       ZR(NM,M),ZI(NM,M)
  3567.       DOUBLE PRECISION H,GI,GR
  3568. C
  3569. C     THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
  3570. C     THE ALGOL PROCEDURE ORTBAK, NUM. MATH. 12, 349-368(1968)
  3571. C     BY MARTIN AND WILKINSON.
  3572. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
  3573. C
  3574. C     THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
  3575. C     MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
  3576. C     UPPER HESSENBERG MATRIX DETERMINED BY  CORTH.
  3577. C
  3578. C     ON INPUT
  3579. C
  3580. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  3581. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  3582. C          DIMENSION STATEMENT.
  3583. C
  3584. C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
  3585. C          SUBROUTINE  CBAL.  IF  CBAL  HAS NOT BEEN USED,
  3586. C          SET LOW=1 AND IGH EQUAL TO THE ORDER OF THE MATRIX.
  3587. C
  3588. C        AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY
  3589. C          TRANSFORMATIONS USED IN THE REDUCTION BY  CORTH
  3590. C          IN THEIR STRICT LOWER TRIANGLES.
  3591. C
  3592. C        ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
  3593. C          TRANSFORMATIONS USED IN THE REDUCTION BY  CORTH.
  3594. C          ONLY ELEMENTS LOW THROUGH IGH ARE USED.
  3595. C
  3596. C        M IS THE NUMBER OF COLUMNS OF ZR AND ZI TO BE BACK TRANSFORMED.
  3597. C
  3598. C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
  3599. C          RESPECTIVELY, OF THE EIGENVECTORS TO BE
  3600. C          BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
  3601. C
  3602. C     ON OUTPUT
  3603. C
  3604. C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
  3605. C          RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
  3606. C          IN THEIR FIRST M COLUMNS.
  3607. C
  3608. C        ORTR AND ORTI HAVE BEEN ALTERED.
  3609. C
  3610. C     NOTE THAT CORTB PRESERVES VECTOR EUCLIDEAN NORMS.
  3611. C
  3612. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  3613. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  3614. C
  3615. C     THIS VERSION DATED AUGUST 1983.
  3616. C
  3617. C     ------------------------------------------------------------------
  3618. C
  3619.       IF (M .EQ. 0) GO TO 200
  3620.       LA = IGH - 1
  3621.       KP1 = LOW + 1
  3622.       IF (LA .LT. KP1) GO TO 200
  3623. C     .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
  3624.       DO 140 MM = KP1, LA
  3625.          MP = LOW + IGH - MM
  3626.          IF (AR(MP,MP-1) .EQ. 0.0D0 .AND. AI(MP,MP-1) .EQ. 0.0D0)
  3627.      X      GO TO 140
  3628. C     .......... H BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
  3629.          H = AR(MP,MP-1) * ORTR(MP) + AI(MP,MP-1) * ORTI(MP)
  3630.          MP1 = MP + 1
  3631. C
  3632.          DO 100 I = MP1, IGH
  3633.             ORTR(I) = AR(I,MP-1)
  3634.             ORTI(I) = AI(I,MP-1)
  3635.   100    CONTINUE
  3636. C
  3637.          DO 130 J = 1, M
  3638.             GR = 0.0D0
  3639.             GI = 0.0D0
  3640. C
  3641.             DO 110 I = MP, IGH
  3642.                GR = GR + ORTR(I) * ZR(I,J) + ORTI(I) * ZI(I,J)
  3643.                GI = GI + ORTR(I) * ZI(I,J) - ORTI(I) * ZR(I,J)
  3644.   110       CONTINUE
  3645. C
  3646.             GR = GR / H
  3647.             GI = GI / H
  3648. C
  3649.             DO 120 I = MP, IGH
  3650.                ZR(I,J) = ZR(I,J) + GR * ORTR(I) - GI * ORTI(I)
  3651.                ZI(I,J) = ZI(I,J) + GR * ORTI(I) + GI * ORTR(I)
  3652.   120       CONTINUE
  3653. C
  3654.   130    CONTINUE
  3655. C
  3656.   140 CONTINUE
  3657. C
  3658.   200 RETURN
  3659.       END
  3660.       SUBROUTINE CORTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
  3661. C
  3662.       INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
  3663.       DOUBLE PRECISION AR(NM,N),AI(NM,N),ORTR(IGH),ORTI(IGH)
  3664.       DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
  3665. C
  3666. C     THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
  3667. C     THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
  3668. C     BY MARTIN AND WILKINSON.
  3669. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
  3670. C
  3671. C     GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
  3672. C     REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
  3673. C     LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
  3674. C     UNITARY SIMILARITY TRANSFORMATIONS.
  3675. C
  3676. C     ON INPUT
  3677. C
  3678. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  3679. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  3680. C          DIMENSION STATEMENT.
  3681. C
  3682. C        N IS THE ORDER OF THE MATRIX.
  3683. C
  3684. C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
  3685. C          SUBROUTINE  CBAL.  IF  CBAL  HAS NOT BEEN USED,
  3686. C          SET LOW=1, IGH=N.
  3687. C
  3688. C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
  3689. C          RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
  3690. C
  3691. C     ON OUTPUT
  3692. C
  3693. C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
  3694. C          RESPECTIVELY, OF THE HESSENBERG MATRIX.  INFORMATION
  3695. C          ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
  3696. C          IS STORED IN THE REMAINING TRIANGLES UNDER THE
  3697. C          HESSENBERG MATRIX.
  3698. C
  3699. C        ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
  3700. C          TRANSFORMATIONS.  ONLY ELEMENTS LOW THROUGH IGH ARE USED.
  3701. C
  3702. C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
  3703. C
  3704. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  3705. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  3706. C
  3707. C     THIS VERSION DATED AUGUST 1983.
  3708. C
  3709. C     ------------------------------------------------------------------
  3710. C
  3711.       LA = IGH - 1
  3712.       KP1 = LOW + 1
  3713.       IF (LA .LT. KP1) GO TO 200
  3714. C
  3715.       DO 180 M = KP1, LA
  3716.          H = 0.0D0
  3717.          ORTR(M) = 0.0D0
  3718.          ORTI(M) = 0.0D0
  3719.          SCALE = 0.0D0
  3720. C     .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
  3721.          DO 90 I = M, IGH
  3722.    90    SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
  3723. C
  3724.          IF (SCALE .EQ. 0.0D0) GO TO 180
  3725.          MP = M + IGH
  3726. C     .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
  3727.          DO 100 II = M, IGH
  3728.             I = MP - II
  3729.             ORTR(I) = AR(I,M-1) / SCALE
  3730.             ORTI(I) = AI(I,M-1) / SCALE
  3731.             H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
  3732.   100    CONTINUE
  3733. C
  3734.          G = DSQRT(H)
  3735.          F = PYTHAG(ORTR(M),ORTI(M))
  3736.          IF (F .EQ. 0.0D0) GO TO 103
  3737.          H = H + F * G
  3738.          G = G / F
  3739.          ORTR(M) = (1.0D0 + G) * ORTR(M)
  3740.          ORTI(M) = (1.0D0 + G) * ORTI(M)
  3741.          GO TO 105
  3742. C
  3743.   103    ORTR(M) = G
  3744.          AR(M,M-1) = SCALE
  3745. C     .......... FORM (I-(U*UT)/H) * A ..........
  3746.   105    DO 130 J = M, N
  3747.             FR = 0.0D0
  3748.             FI = 0.0D0
  3749. C     .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
  3750.             DO 110 II = M, IGH
  3751.                I = MP - II
  3752.                FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
  3753.                FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
  3754.   110       CONTINUE
  3755. C
  3756.             FR = FR / H
  3757.             FI = FI / H
  3758. C
  3759.             DO 120 I = M, IGH
  3760.                AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
  3761.                AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
  3762.   120       CONTINUE
  3763. C
  3764.   130    CONTINUE
  3765. C     .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
  3766.          DO 160 I = 1, IGH
  3767.             FR = 0.0D0
  3768.             FI = 0.0D0
  3769. C     .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
  3770.             DO 140 JJ = M, IGH
  3771.                J = MP - JJ
  3772.                FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
  3773.                FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
  3774.   140       CONTINUE
  3775. C
  3776.             FR = FR / H
  3777.             FI = FI / H
  3778. C
  3779.             DO 150 J = M, IGH
  3780.                AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
  3781.                AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
  3782.   150       CONTINUE
  3783. C
  3784.   160    CONTINUE
  3785. C
  3786.          ORTR(M) = SCALE * ORTR(M)
  3787.          ORTI(M) = SCALE * ORTI(M)
  3788.          AR(M,M-1) = -G * AR(M,M-1)
  3789.          AI(M,M-1) = -G * AI(M,M-1)
  3790.   180 CONTINUE
  3791. C
  3792.   200 RETURN
  3793.       END
  3794.       SUBROUTINE ELMBAK(NM,LOW,IGH,A,INT,M,Z)
  3795. C
  3796.       INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1
  3797.       DOUBLE PRECISION A(NM,IGH),Z(NM,M)
  3798.       DOUBLE PRECISION X
  3799.       INTEGER INT(IGH)
  3800. C
  3801. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMBAK,
  3802. C     NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON.
  3803. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
  3804. C
  3805. C     THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL GENERAL
  3806. C     MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
  3807. C     UPPER HESSENBERG MATRIX DETERMINED BY  ELMHES.
  3808. C
  3809. C     ON INPUT
  3810. C
  3811. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  3812. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  3813. C          DIMENSION STATEMENT.
  3814. C
  3815. C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
  3816. C          SUBROUTINE  BALANC.  IF  BALANC  HAS NOT BEEN USED,
  3817. C          SET LOW=1 AND IGH EQUAL TO THE ORDER OF THE MATRIX.
  3818. C
  3819. C        A CONTAINS THE MULTIPLIERS WHICH WERE USED IN THE
  3820. C          REDUCTION BY  ELMHES  IN ITS LOWER TRIANGLE
  3821. C          BELOW THE SUBDIAGONAL.
  3822. C
  3823. C        INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS
  3824. C          INTERCHANGED IN THE REDUCTION BY  ELMHES.
  3825. C          ONLY ELEMENTS LOW THROUGH IGH ARE USED.
  3826. C
  3827. C        M IS THE NUMBER OF COLUMNS OF Z TO BE BACK TRANSFORMED.
  3828. C
  3829. C        Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGEN-
  3830. C          VECTORS TO BE BACK TRANSFORMED IN ITS FIRST M COLUMNS.
  3831. C
  3832. C     ON OUTPUT
  3833. C
  3834. C        Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE
  3835. C          TRANSFORMED EIGENVECTORS IN ITS FIRST M COLUMNS.
  3836. C
  3837. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  3838. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  3839. C
  3840. C     THIS VERSION DATED AUGUST 1983.
  3841. C
  3842. C     ------------------------------------------------------------------
  3843. C
  3844.       IF (M .EQ. 0) GO TO 200
  3845.       LA = IGH - 1
  3846.       KP1 = LOW + 1
  3847.       IF (LA .LT. KP1) GO TO 200
  3848. C     .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
  3849.       DO 140 MM = KP1, LA
  3850.          MP = LOW + IGH - MM
  3851.          MP1 = MP + 1
  3852. C
  3853.          DO 110 I = MP1, IGH
  3854.             X = A(I,MP-1)
  3855.             IF (X .EQ. 0.0D0) GO TO 110
  3856. C
  3857.             DO 100 J = 1, M
  3858.   100       Z(I,J) = Z(I,J) + X * Z(MP,J)
  3859. C
  3860.   110    CONTINUE
  3861. C
  3862.          I = INT(MP)
  3863.          IF (I .EQ. MP) GO TO 140
  3864. C
  3865.          DO 130 J = 1, M
  3866.             X = Z(I,J)
  3867.             Z(I,J) = Z(MP,J)
  3868.             Z(MP,J) = X
  3869.   130    CONTINUE
  3870. C
  3871.   140 CONTINUE
  3872. C
  3873.   200 RETURN
  3874.       END
  3875.       SUBROUTINE ELMHES(NM,N,LOW,IGH,A,INT)
  3876. C
  3877.       INTEGER I,J,M,N,LA,NM,IGH,KP1,LOW,MM1,MP1
  3878.       DOUBLE PRECISION A(NM,N)
  3879.       DOUBLE PRECISION X,Y
  3880.       INTEGER INT(IGH)
  3881. C
  3882. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMHES,
  3883. C     NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON.
  3884. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
  3885. C
  3886. C     GIVEN A REAL GENERAL MATRIX, THIS SUBROUTINE
  3887. C     REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
  3888. C     LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
  3889. C     STABILIZED ELEMENTARY SIMILARITY TRANSFORMATIONS.
  3890. C
  3891. C     ON INPUT
  3892. C
  3893. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  3894. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  3895. C          DIMENSION STATEMENT.
  3896. C
  3897. C        N IS THE ORDER OF THE MATRIX.
  3898. C
  3899. C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
  3900. C          SUBROUTINE  BALANC.  IF  BALANC  HAS NOT BEEN USED,
  3901. C          SET LOW=1, IGH=N.
  3902. C
  3903. C        A CONTAINS THE INPUT MATRIX.
  3904. C
  3905. C     ON OUTPUT
  3906. C
  3907. C        A CONTAINS THE HESSENBERG MATRIX.  THE MULTIPLIERS
  3908. C          WHICH WERE USED IN THE REDUCTION ARE STORED IN THE
  3909. C          REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX.
  3910. C
  3911. C        INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS
  3912. C          INTERCHANGED IN THE REDUCTION.
  3913. C          ONLY ELEMENTS LOW THROUGH IGH ARE USED.
  3914. C
  3915. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  3916. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  3917. C
  3918. C     THIS VERSION DATED AUGUST 1983.
  3919. C
  3920. C     ------------------------------------------------------------------
  3921. C
  3922.       LA = IGH - 1
  3923.       KP1 = LOW + 1
  3924.       IF (LA .LT. KP1) GO TO 200
  3925. C
  3926.       DO 180 M = KP1, LA
  3927.          MM1 = M - 1
  3928.          X = 0.0D0
  3929.          I = M
  3930. C
  3931.          DO 100 J = M, IGH
  3932.             IF (DABS(A(J,MM1)) .LE. DABS(X)) GO TO 100
  3933.             X = A(J,MM1)
  3934.             I = J
  3935.   100    CONTINUE
  3936. C
  3937.          INT(M) = I
  3938.          IF (I .EQ. M) GO TO 130
  3939. C     .......... INTERCHANGE ROWS AND COLUMNS OF A ..........
  3940.          DO 110 J = MM1, N
  3941.             Y = A(I,J)
  3942.             A(I,J) = A(M,J)
  3943.             A(M,J) = Y
  3944.   110    CONTINUE
  3945. C
  3946.          DO 120 J = 1, IGH
  3947.             Y = A(J,I)
  3948.             A(J,I) = A(J,M)
  3949.             A(J,M) = Y
  3950.   120    CONTINUE
  3951. C     .......... END INTERCHANGE ..........
  3952.   130    IF (X .EQ. 0.0D0) GO TO 180
  3953.          MP1 = M + 1
  3954. C
  3955.          DO 160 I = MP1, IGH
  3956.             Y = A(I,MM1)
  3957.             IF (Y .EQ. 0.0D0) GO TO 160
  3958.             Y = Y / X
  3959.             A(I,MM1) = Y
  3960. C
  3961.             DO 140 J = M, N
  3962.   140       A(I,J) = A(I,J) - Y * A(M,J)
  3963. C
  3964.             DO 150 J = 1, IGH
  3965.   150       A(J,M) = A(J,M) + Y * A(J,I)
  3966. C
  3967.   160    CONTINUE
  3968. C
  3969.   180 CONTINUE
  3970. C
  3971.   200 RETURN
  3972.       END
  3973.       SUBROUTINE ELTRAN(NM,N,LOW,IGH,A,INT,Z)
  3974. C
  3975.       INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1
  3976.       DOUBLE PRECISION A(NM,IGH),Z(NM,N)
  3977.       INTEGER INT(IGH)
  3978. C
  3979. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMTRANS,
  3980. C     NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON.
  3981. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
  3982. C
  3983. C     THIS SUBROUTINE ACCUMULATES THE STABILIZED ELEMENTARY
  3984. C     SIMILARITY TRANSFORMATIONS USED IN THE REDUCTION OF A
  3985. C     REAL GENERAL MATRIX TO UPPER HESSENBERG FORM BY  ELMHES.
  3986. C
  3987. C     ON INPUT
  3988. C
  3989. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  3990. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  3991. C          DIMENSION STATEMENT.
  3992. C
  3993. C        N IS THE ORDER OF THE MATRIX.
  3994. C
  3995. C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
  3996. C          SUBROUTINE  BALANC.  IF  BALANC  HAS NOT BEEN USED,
  3997. C          SET LOW=1, IGH=N.
  3998. C
  3999. C        A CONTAINS THE MULTIPLIERS WHICH WERE USED IN THE
  4000. C          REDUCTION BY  ELMHES  IN ITS LOWER TRIANGLE
  4001. C          BELOW THE SUBDIAGONAL.
  4002. C
  4003. C        INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS
  4004. C          INTERCHANGED IN THE REDUCTION BY  ELMHES.
  4005. C          ONLY ELEMENTS LOW THROUGH IGH ARE USED.
  4006. C
  4007. C     ON OUTPUT
  4008. C
  4009. C        Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
  4010. C          REDUCTION BY  ELMHES.
  4011. C
  4012. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  4013. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  4014. C
  4015. C     THIS VERSION DATED AUGUST 1983.
  4016. C
  4017. C     ------------------------------------------------------------------
  4018. C
  4019. C     .......... INITIALIZE Z TO IDENTITY MATRIX ..........
  4020.       DO 80 J = 1, N
  4021. C
  4022.          DO 60 I = 1, N
  4023.    60    Z(I,J) = 0.0D0
  4024. C
  4025.          Z(J,J) = 1.0D0
  4026.    80 CONTINUE
  4027. C
  4028.       KL = IGH - LOW - 1
  4029.       IF (KL .LT. 1) GO TO 200
  4030. C     .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
  4031.       DO 140 MM = 1, KL
  4032.          MP = IGH - MM
  4033.          MP1 = MP + 1
  4034. C
  4035.          DO 100 I = MP1, IGH
  4036.   100    Z(I,MP) = A(I,MP-1)
  4037. C
  4038.          I = INT(MP)
  4039.          IF (I .EQ. MP) GO TO 140
  4040. C
  4041.          DO 130 J = MP, IGH
  4042.             Z(MP,J) = Z(I,J)
  4043.             Z(I,J) = 0.0D0
  4044.   130    CONTINUE
  4045. C
  4046.          Z(I,MP) = 1.0D0
  4047.   140 CONTINUE
  4048. C
  4049.   200 RETURN
  4050.       END
  4051.       SUBROUTINE FIGI(NM,N,T,D,E,E2,IERR)
  4052. C
  4053.       INTEGER I,N,NM,IERR
  4054.       DOUBLE PRECISION T(NM,3),D(N),E(N),E2(N)
  4055. C
  4056. C     GIVEN A NONSYMMETRIC TRIDIAGONAL MATRIX SUCH THAT THE PRODUCTS
  4057. C     OF CORRESPONDING PAIRS OF OFF-DIAGONAL ELEMENTS ARE ALL
  4058. C     NON-NEGATIVE, THIS SUBROUTINE REDUCES IT TO A SYMMETRIC
  4059. C     TRIDIAGONAL MATRIX WITH THE SAME EIGENVALUES.  IF, FURTHER,
  4060. C     A ZERO PRODUCT ONLY OCCURS WHEN BOTH FACTORS ARE ZERO,
  4061. C     THE REDUCED MATRIX IS SIMILAR TO THE ORIGINAL MATRIX.
  4062. C
  4063. C     ON INPUT
  4064. C
  4065. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  4066. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  4067. C          DIMENSION STATEMENT.
  4068. C
  4069. C        N IS THE ORDER OF THE MATRIX.
  4070. C
  4071. C        T CONTAINS THE INPUT MATRIX.  ITS SUBDIAGONAL IS
  4072. C          STORED IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN,
  4073. C          ITS DIAGONAL IN THE N POSITIONS OF THE SECOND COLUMN,
  4074. C          AND ITS SUPERDIAGONAL IN THE FIRST N-1 POSITIONS OF
  4075. C          THE THIRD COLUMN.  T(1,1) AND T(N,3) ARE ARBITRARY.
  4076. C
  4077. C     ON OUTPUT
  4078. C
  4079. C        T IS UNALTERED.
  4080. C
  4081. C        D CONTAINS THE DIAGONAL ELEMENTS OF THE SYMMETRIC MATRIX.
  4082. C
  4083. C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE SYMMETRIC
  4084. C          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS NOT SET.
  4085. C
  4086. C        E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
  4087. C          E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
  4088. C
  4089. C        IERR IS SET TO
  4090. C          ZERO       FOR NORMAL RETURN,
  4091. C          N+I        IF T(I,1)*T(I-1,3) IS NEGATIVE,
  4092. C          -(3*N+I)   IF T(I,1)*T(I-1,3) IS ZERO WITH ONE FACTOR
  4093. C                     NON-ZERO.  IN THIS CASE, THE EIGENVECTORS OF
  4094. C                     THE SYMMETRIC MATRIX ARE NOT SIMPLY RELATED
  4095. C                     TO THOSE OF  T  AND SHOULD NOT BE SOUGHT.
  4096. C
  4097. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  4098. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  4099. C
  4100. C     THIS VERSION DATED AUGUST 1983.
  4101. C
  4102. C     ------------------------------------------------------------------
  4103. C
  4104.       IERR = 0
  4105. C
  4106.       DO 100 I = 1, N
  4107.          IF (I .EQ. 1) GO TO 90
  4108.          E2(I) = T(I,1) * T(I-1,3)
  4109.          IF (E2(I)) 1000, 60, 80
  4110.    60    IF (T(I,1) .EQ. 0.0D0 .AND. T(I-1,3) .EQ. 0.0D0) GO TO 80
  4111. C     .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL
  4112. C                ELEMENTS IS ZERO WITH ONE MEMBER NON-ZERO ..........
  4113.          IERR = -(3 * N + I)
  4114.    80    E(I) = DSQRT(E2(I))
  4115.    90    D(I) = T(I,2)
  4116.   100 CONTINUE
  4117. C
  4118.       GO TO 1001
  4119. C     .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL
  4120. C                ELEMENTS IS NEGATIVE ..........
  4121.  1000 IERR = N + I
  4122.  1001 RETURN
  4123.       END
  4124.       SUBROUTINE FIGI2(NM,N,T,D,E,Z,IERR)
  4125. C
  4126.       INTEGER I,J,N,NM,IERR
  4127.       DOUBLE PRECISION T(NM,3),D(N),E(N),Z(NM,N)
  4128.       DOUBLE PRECISION H
  4129. C
  4130. C     GIVEN A NONSYMMETRIC TRIDIAGONAL MATRIX SUCH THAT THE PRODUCTS
  4131. C     OF CORRESPONDING PAIRS OF OFF-DIAGONAL ELEMENTS ARE ALL
  4132. C     NON-NEGATIVE, AND ZERO ONLY WHEN BOTH FACTORS ARE ZERO, THIS
  4133. C     SUBROUTINE REDUCES IT TO A SYMMETRIC TRIDIAGONAL MATRIX
  4134. C     USING AND ACCUMULATING DIAGONAL SIMILARITY TRANSFORMATIONS.
  4135. C
  4136. C     ON INPUT
  4137. C
  4138. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  4139. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  4140. C          DIMENSION STATEMENT.
  4141. C
  4142. C        N IS THE ORDER OF THE MATRIX.
  4143. C
  4144. C        T CONTAINS THE INPUT MATRIX.  ITS SUBDIAGONAL IS
  4145. C          STORED IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN,
  4146. C          ITS DIAGONAL IN THE N POSITIONS OF THE SECOND COLUMN,
  4147. C          AND ITS SUPERDIAGONAL IN THE FIRST N-1 POSITIONS OF
  4148. C          THE THIRD COLUMN.  T(1,1) AND T(N,3) ARE ARBITRARY.
  4149. C
  4150. C     ON OUTPUT
  4151. C
  4152. C        T IS UNALTERED.
  4153. C
  4154. C        D CONTAINS THE DIAGONAL ELEMENTS OF THE SYMMETRIC MATRIX.
  4155. C
  4156. C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE SYMMETRIC
  4157. C          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS NOT SET.
  4158. C
  4159. C        Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN
  4160. C          THE REDUCTION.
  4161. C
  4162. C        IERR IS SET TO
  4163. C          ZERO       FOR NORMAL RETURN,
  4164. C          N+I        IF T(I,1)*T(I-1,3) IS NEGATIVE,
  4165. C          2*N+I      IF T(I,1)*T(I-1,3) IS ZERO WITH
  4166. C                     ONE FACTOR NON-ZERO.
  4167. C
  4168. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  4169. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  4170. C
  4171. C     THIS VERSION DATED AUGUST 1983.
  4172. C
  4173. C     ------------------------------------------------------------------
  4174. C
  4175.       IERR = 0
  4176. C
  4177.       DO 100 I = 1, N
  4178. C
  4179.          DO 50 J = 1, N
  4180.    50    Z(I,J) = 0.0D0
  4181. C
  4182.          IF (I .EQ. 1) GO TO 70
  4183.          H = T(I,1) * T(I-1,3)
  4184.          IF (H) 900, 60, 80
  4185.    60    IF (T(I,1) .NE. 0.0D0 .OR. T(I-1,3) .NE. 0.0D0) GO TO 1000
  4186.          E(I) = 0.0D0
  4187.    70    Z(I,I) = 1.0D0
  4188.          GO TO 90
  4189.    80    E(I) = DSQRT(H)
  4190.          Z(I,I) = Z(I-1,I-1) * E(I) / T(I-1,3)
  4191.    90    D(I) = T(I,2)
  4192.   100 CONTINUE
  4193. C
  4194.       GO TO 1001
  4195. C     .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL
  4196. C                ELEMENTS IS NEGATIVE ..........
  4197.   900 IERR = N + I
  4198.       GO TO 1001
  4199. C     .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL
  4200. C                ELEMENTS IS ZERO WITH ONE MEMBER NON-ZERO ..........
  4201.  1000 IERR = 2 * N + I
  4202.  1001 RETURN
  4203.       END
  4204.       SUBROUTINE HQR(NM,N,LOW,IGH,H,WR,WI,IERR)
  4205. C
  4206.       INTEGER I,J,K,L,M,N,EN,LL,MM,NA,NM,IGH,ITN,ITS,LOW,MP2,ENM2,IERR
  4207.       DOUBLE PRECISION H(NM,N),WR(N),WI(N)
  4208.       DOUBLE PRECISION P,Q,R,S,T,W,X,Y,ZZ,NORM,TST1,TST2
  4209.       LOGICAL NOTLAS
  4210. C
  4211. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR,
  4212. C     NUM. MATH. 14, 219-231(1970) BY MARTIN, PETERS, AND WILKINSON.
  4213. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 359-371(1971).
  4214. C
  4215. C     THIS SUBROUTINE FINDS THE EIGENVALUES OF A REAL
  4216. C     UPPER HESSENBERG MATRIX BY THE QR METHOD.
  4217. C
  4218. C     ON INPUT
  4219. C
  4220. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  4221. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  4222. C          DIMENSION STATEMENT.
  4223. C
  4224. C        N IS THE ORDER OF THE MATRIX.
  4225. C
  4226. C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
  4227. C          SUBROUTINE  BALANC.  IF  BALANC  HAS NOT BEEN USED,
  4228. C          SET LOW=1, IGH=N.
  4229. C
  4230. C        H CONTAINS THE UPPER HESSENBERG MATRIX.  INFORMATION ABOUT
  4231. C          THE TRANSFORMATIONS USED IN THE REDUCTION TO HESSENBERG
  4232. C          FORM BY  ELMHES  OR  ORTHES, IF PERFORMED, IS STORED
  4233. C          IN THE REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX.
  4234. C
  4235. C     ON OUTPUT
  4236. C
  4237. C        H HAS BEEN DESTROYED.  THEREFORE, IT MUST BE SAVED
  4238. C          BEFORE CALLING  HQR  IF SUBSEQUENT CALCULATION AND
  4239. C          BACK TRANSFORMATION OF EIGENVECTORS IS TO BE PERFORMED.
  4240. C
  4241. C        WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
  4242. C          RESPECTIVELY, OF THE EIGENVALUES.  THE EIGENVALUES
  4243. C          ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS
  4244. C          OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE
  4245. C          HAVING THE POSITIVE IMAGINARY PART FIRST.  IF AN
  4246. C          ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
  4247. C          FOR INDICES IERR+1,...,N.
  4248. C
  4249. C        IERR IS SET TO
  4250. C          ZERO       FOR NORMAL RETURN,
  4251. C          J          IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
  4252. C                     WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
  4253. C
  4254. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  4255. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  4256. C
  4257. C     THIS VERSION DATED AUGUST 1983.
  4258. C
  4259. C     ------------------------------------------------------------------
  4260. C
  4261.       IERR = 0
  4262.       NORM = 0.0D0
  4263.       K = 1
  4264. C     .......... STORE ROOTS ISOLATED BY BALANC
  4265. C                AND COMPUTE MATRIX NORM ..........
  4266.       DO 50 I = 1, N
  4267. C
  4268.          DO 40 J = K, N
  4269.    40    NORM = NORM + DABS(H(I,J))
  4270. C
  4271.          K = I
  4272.          IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50
  4273.          WR(I) = H(I,I)
  4274.          WI(I) = 0.0D0
  4275.    50 CONTINUE
  4276. C
  4277.       EN = IGH
  4278.       T = 0.0D0
  4279.       ITN = 30*N
  4280. C     .......... SEARCH FOR NEXT EIGENVALUES ..........
  4281.    60 IF (EN .LT. LOW) GO TO 1001
  4282.       ITS = 0
  4283.       NA = EN - 1
  4284.       ENM2 = NA - 1
  4285. C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
  4286. C                FOR L=EN STEP -1 UNTIL LOW DO -- ..........
  4287.    70 DO 80 LL = LOW, EN
  4288.          L = EN + LOW - LL
  4289.          IF (L .EQ. LOW) GO TO 100
  4290.          S = DABS(H(L-1,L-1)) + DABS(H(L,L))
  4291.          IF (S .EQ. 0.0D0) S = NORM
  4292.          TST1 = S
  4293.          TST2 = TST1 + DABS(H(L,L-1))
  4294.          IF (TST2 .EQ. TST1) GO TO 100
  4295.    80 CONTINUE
  4296. C     .......... FORM SHIFT ..........
  4297.   100 X = H(EN,EN)
  4298.       IF (L .EQ. EN) GO TO 270
  4299.       Y = H(NA,NA)
  4300.       W = H(EN,NA) * H(NA,EN)
  4301.       IF (L .EQ. NA) GO TO 280
  4302.       IF (ITN .EQ. 0) GO TO 1000
  4303.       IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130
  4304. C     .......... FORM EXCEPTIONAL SHIFT ..........
  4305.       T = T + X
  4306. C
  4307.       DO 120 I = LOW, EN
  4308.   120 H(I,I) = H(I,I) - X
  4309. C
  4310.       S = DABS(H(EN,NA)) + DABS(H(NA,ENM2))
  4311.       X = 0.75D0 * S
  4312.       Y = X
  4313.       W = -0.4375D0 * S * S
  4314.   130 ITS = ITS + 1
  4315.       ITN = ITN - 1
  4316. C     .......... LOOK FOR TWO CONSECUTIVE SMALL
  4317. C                SUB-DIAGONAL ELEMENTS.
  4318. C                FOR M=EN-2 STEP -1 UNTIL L DO -- ..........
  4319.       DO 140 MM = L, ENM2
  4320.          M = ENM2 + L - MM
  4321.          ZZ = H(M,M)
  4322.          R = X - ZZ
  4323.          S = Y - ZZ
  4324.          P = (R * S - W) / H(M+1,M) + H(M,M+1)
  4325.          Q = H(M+1,M+1) - ZZ - R - S
  4326.          R = H(M+2,M+1)
  4327.          S = DABS(P) + DABS(Q) + DABS(R)
  4328.          P = P / S
  4329.          Q = Q / S
  4330.          R = R / S
  4331.          IF (M .EQ. L) GO TO 150
  4332.          TST1 = DABS(P)*(DABS(H(M-1,M-1)) + DABS(ZZ) + DABS(H(M+1,M+1)))
  4333.          TST2 = TST1 + DABS(H(M,M-1))*(DABS(Q) + DABS(R))
  4334.          IF (TST2 .EQ. TST1) GO TO 150
  4335.   140 CONTINUE
  4336. C
  4337.   150 MP2 = M + 2
  4338. C
  4339.       DO 160 I = MP2, EN
  4340.          H(I,I-2) = 0.0D0
  4341.          IF (I .EQ. MP2) GO TO 160
  4342.          H(I,I-3) = 0.0D0
  4343.   160 CONTINUE
  4344. C     .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND
  4345. C                COLUMNS M TO EN ..........
  4346.       DO 260 K = M, NA
  4347.          NOTLAS = K .NE. NA
  4348.          IF (K .EQ. M) GO TO 170
  4349.          P = H(K,K-1)
  4350.          Q = H(K+1,K-1)
  4351.          R = 0.0D0
  4352.          IF (NOTLAS) R = H(K+2,K-1)
  4353.          X = DABS(P) + DABS(Q) + DABS(R)
  4354.          IF (X .EQ. 0.0D0) GO TO 260
  4355.          P = P / X
  4356.          Q = Q / X
  4357.          R = R / X
  4358.   170    S = DSIGN(DSQRT(P*P+Q*Q+R*R),P)
  4359.          IF (K .EQ. M) GO TO 180
  4360.          H(K,K-1) = -S * X
  4361.          GO TO 190
  4362.   180    IF (L .NE. M) H(K,K-1) = -H(K,K-1)
  4363.   190    P = P + S
  4364.          X = P / S
  4365.          Y = Q / S
  4366.          ZZ = R / S
  4367.          Q = Q / P
  4368.          R = R / P
  4369.          IF (NOTLAS) GO TO 225
  4370. C     .......... ROW MODIFICATION ..........
  4371.          DO 200 J = K, N
  4372.             P = H(K,J) + Q * H(K+1,J)
  4373.             H(K,J) = H(K,J) - P * X
  4374.             H(K+1,J) = H(K+1,J) - P * Y
  4375.   200    CONTINUE
  4376. C
  4377.          J = MIN0(EN,K+3)
  4378. C     .......... COLUMN MODIFICATION ..........
  4379.          DO 210 I = 1, J
  4380.             P = X * H(I,K) + Y * H(I,K+1)
  4381.             H(I,K) = H(I,K) - P
  4382.             H(I,K+1) = H(I,K+1) - P * Q
  4383.   210    CONTINUE
  4384.          GO TO 255
  4385.   225    CONTINUE
  4386. C     .......... ROW MODIFICATION ..........
  4387.          DO 230 J = K, N
  4388.             P = H(K,J) + Q * H(K+1,J) + R * H(K+2,J)
  4389.             H(K,J) = H(K,J) - P * X
  4390.             H(K+1,J) = H(K+1,J) - P * Y
  4391.             H(K+2,J) = H(K+2,J) - P * ZZ
  4392.   230    CONTINUE
  4393. C
  4394.          J = MIN0(EN,K+3)
  4395. C     .......... COLUMN MODIFICATION ..........
  4396.          DO 240 I = 1, J
  4397.             P = X * H(I,K) + Y * H(I,K+1) + ZZ * H(I,K+2)
  4398.             H(I,K) = H(I,K) - P
  4399.             H(I,K+1) = H(I,K+1) - P * Q
  4400.             H(I,K+2) = H(I,K+2) - P * R
  4401.   240    CONTINUE
  4402.   255    CONTINUE
  4403. C
  4404.   260 CONTINUE
  4405. C
  4406.       GO TO 70
  4407. C     .......... ONE ROOT FOUND ..........
  4408.   270 WR(EN) = X + T
  4409.       WI(EN) = 0.0D0
  4410.       EN = NA
  4411.       GO TO 60
  4412. C     .......... TWO ROOTS FOUND ..........
  4413.   280 P = (Y - X) / 2.0D0
  4414.       Q = P * P + W
  4415.       ZZ = DSQRT(DABS(Q))
  4416.       X = X + T
  4417.       IF (Q .LT. 0.0D0) GO TO 320
  4418. C     .......... REAL PAIR ..........
  4419.       ZZ = P + DSIGN(ZZ,P)
  4420.       WR(NA) = X + ZZ
  4421.       WR(EN) = WR(NA)
  4422.       IF (ZZ .NE. 0.0D0) WR(EN) = X - W / ZZ
  4423.       WI(NA) = 0.0D0
  4424.       WI(EN) = 0.0D0
  4425.       GO TO 330
  4426. C     .......... COMPLEX PAIR ..........
  4427.   320 WR(NA) = X + P
  4428.       WR(EN) = X + P
  4429.       WI(NA) = ZZ
  4430.       WI(EN) = -ZZ
  4431.   330 EN = ENM2
  4432.       GO TO 60
  4433. C     .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
  4434. C                CONVERGED AFTER 30*N ITERATIONS ..........
  4435.  1000 IERR = EN
  4436.  1001 RETURN
  4437.       END
  4438.       SUBROUTINE HQR2(NM,N,LOW,IGH,H,WR,WI,Z,IERR)
  4439. C
  4440.       INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NA,NM,NN,
  4441.      X        IGH,ITN,ITS,LOW,MP2,ENM2,IERR
  4442.       DOUBLE PRECISION H(NM,N),WR(N),WI(N),Z(NM,N)
  4443.       DOUBLE PRECISION P,Q,R,S,T,W,X,Y,RA,SA,VI,VR,ZZ,NORM,TST1,TST2
  4444.       LOGICAL NOTLAS
  4445. C
  4446. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR2,
  4447. C     NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON.
  4448. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
  4449. C
  4450. C     THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
  4451. C     OF A REAL UPPER HESSENBERG MATRIX BY THE QR METHOD.  THE
  4452. C     EIGENVECTORS OF A REAL GENERAL MATRIX CAN ALSO BE FOUND
  4453. C     IF  ELMHES  AND  ELTRAN  OR  ORTHES  AND  ORTRAN  HAVE
  4454. C     BEEN USED TO REDUCE THIS GENERAL MATRIX TO HESSENBERG FORM
  4455. C     AND TO ACCUMULATE THE SIMILARITY TRANSFORMATIONS.
  4456. C
  4457. C     ON INPUT
  4458. C
  4459. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  4460. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  4461. C          DIMENSION STATEMENT.
  4462. C
  4463. C        N IS THE ORDER OF THE MATRIX.
  4464. C
  4465. C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
  4466. C          SUBROUTINE  BALANC.  IF  BALANC  HAS NOT BEEN USED,
  4467. C          SET LOW=1, IGH=N.
  4468. C
  4469. C        H CONTAINS THE UPPER HESSENBERG MATRIX.
  4470. C
  4471. C        Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED BY  ELTRAN
  4472. C          AFTER THE REDUCTION BY  ELMHES, OR BY  ORTRAN  AFTER THE
  4473. C          REDUCTION BY  ORTHES, IF PERFORMED.  IF THE EIGENVECTORS
  4474. C          OF THE HESSENBERG MATRIX ARE DESIRED, Z MUST CONTAIN THE
  4475. C          IDENTITY MATRIX.
  4476. C
  4477. C     ON OUTPUT
  4478. C
  4479. C        H HAS BEEN DESTROYED.
  4480. C
  4481. C        WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
  4482. C          RESPECTIVELY, OF THE EIGENVALUES.  THE EIGENVALUES
  4483. C          ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS
  4484. C          OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE
  4485. C          HAVING THE POSITIVE IMAGINARY PART FIRST.  IF AN
  4486. C          ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
  4487. C          FOR INDICES IERR+1,...,N.
  4488. C
  4489. C        Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS.
  4490. C          IF THE I-TH EIGENVALUE IS REAL, THE I-TH COLUMN OF Z
  4491. C          CONTAINS ITS EIGENVECTOR.  IF THE I-TH EIGENVALUE IS COMPLEX
  4492. C          WITH POSITIVE IMAGINARY PART, THE I-TH AND (I+1)-TH
  4493. C          COLUMNS OF Z CONTAIN THE REAL AND IMAGINARY PARTS OF ITS
  4494. C          EIGENVECTOR.  THE EIGENVECTORS ARE UNNORMALIZED.  IF AN
  4495. C          ERROR EXIT IS MADE, NONE OF THE EIGENVECTORS HAS BEEN FOUND.
  4496. C
  4497. C        IERR IS SET TO
  4498. C          ZERO       FOR NORMAL RETURN,
  4499. C          J          IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
  4500. C                     WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
  4501. C
  4502. C     CALLS CDIV FOR COMPLEX DIVISION.
  4503. C
  4504. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  4505. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  4506. C
  4507. C     THIS VERSION DATED AUGUST 1983.
  4508. C
  4509. C     ------------------------------------------------------------------
  4510. C
  4511.       IERR = 0
  4512.       NORM = 0.0D0
  4513.       K = 1
  4514. C     .......... STORE ROOTS ISOLATED BY BALANC
  4515. C                AND COMPUTE MATRIX NORM ..........
  4516.       DO 50 I = 1, N
  4517. C
  4518.          DO 40 J = K, N
  4519.    40    NORM = NORM + DABS(H(I,J))
  4520. C
  4521.          K = I
  4522.          IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50
  4523.          WR(I) = H(I,I)
  4524.          WI(I) = 0.0D0
  4525.    50 CONTINUE
  4526. C
  4527.       EN = IGH
  4528.       T = 0.0D0
  4529.       ITN = 30*N
  4530. C     .......... SEARCH FOR NEXT EIGENVALUES ..........
  4531.    60 IF (EN .LT. LOW) GO TO 340
  4532.       ITS = 0
  4533.       NA = EN - 1
  4534.       ENM2 = NA - 1
  4535. C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
  4536. C                FOR L=EN STEP -1 UNTIL LOW DO -- ..........
  4537.    70 DO 80 LL = LOW, EN
  4538.          L = EN + LOW - LL
  4539.          IF (L .EQ. LOW) GO TO 100
  4540.          S = DABS(H(L-1,L-1)) + DABS(H(L,L))
  4541.          IF (S .EQ. 0.0D0) S = NORM
  4542.          TST1 = S
  4543.          TST2 = TST1 + DABS(H(L,L-1))
  4544.          IF (TST2 .EQ. TST1) GO TO 100
  4545.    80 CONTINUE
  4546. C     .......... FORM SHIFT ..........
  4547.   100 X = H(EN,EN)
  4548.       IF (L .EQ. EN) GO TO 270
  4549.       Y = H(NA,NA)
  4550.       W = H(EN,NA) * H(NA,EN)
  4551.       IF (L .EQ. NA) GO TO 280
  4552.       IF (ITN .EQ. 0) GO TO 1000
  4553.       IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130
  4554. C     .......... FORM EXCEPTIONAL SHIFT ..........
  4555.       T = T + X
  4556. C
  4557.       DO 120 I = LOW, EN
  4558.   120 H(I,I) = H(I,I) - X
  4559. C
  4560.       S = DABS(H(EN,NA)) + DABS(H(NA,ENM2))
  4561.       X = 0.75D0 * S
  4562.       Y = X
  4563.       W = -0.4375D0 * S * S
  4564.   130 ITS = ITS + 1
  4565.       ITN = ITN - 1
  4566. C     .......... LOOK FOR TWO CONSECUTIVE SMALL
  4567. C                SUB-DIAGONAL ELEMENTS.
  4568. C                FOR M=EN-2 STEP -1 UNTIL L DO -- ..........
  4569.       DO 140 MM = L, ENM2
  4570.          M = ENM2 + L - MM
  4571.          ZZ = H(M,M)
  4572.          R = X - ZZ
  4573.          S = Y - ZZ
  4574.          P = (R * S - W) / H(M+1,M) + H(M,M+1)
  4575.          Q = H(M+1,M+1) - ZZ - R - S
  4576.          R = H(M+2,M+1)
  4577.          S = DABS(P) + DABS(Q) + DABS(R)
  4578.          P = P / S
  4579.          Q = Q / S
  4580.          R = R / S
  4581.          IF (M .EQ. L) GO TO 150
  4582.          TST1 = DABS(P)*(DABS(H(M-1,M-1)) + DABS(ZZ) + DABS(H(M+1,M+1)))
  4583.          TST2 = TST1 + DABS(H(M,M-1))*(DABS(Q) + DABS(R))
  4584.          IF (TST2 .EQ. TST1) GO TO 150
  4585.   140 CONTINUE
  4586. C
  4587.   150 MP2 = M + 2
  4588. C
  4589.       DO 160 I = MP2, EN
  4590.          H(I,I-2) = 0.0D0
  4591.          IF (I .EQ. MP2) GO TO 160
  4592.          H(I,I-3) = 0.0D0
  4593.   160 CONTINUE
  4594. C     .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND
  4595. C                COLUMNS M TO EN ..........
  4596.       DO 260 K = M, NA
  4597.          NOTLAS = K .NE. NA
  4598.          IF (K .EQ. M) GO TO 170
  4599.          P = H(K,K-1)
  4600.          Q = H(K+1,K-1)
  4601.          R = 0.0D0
  4602.          IF (NOTLAS) R = H(K+2,K-1)
  4603.          X = DABS(P) + DABS(Q) + DABS(R)
  4604.          IF (X .EQ. 0.0D0) GO TO 260
  4605.          P = P / X
  4606.          Q = Q / X
  4607.          R = R / X
  4608.   170    S = DSIGN(DSQRT(P*P+Q*Q+R*R),P)
  4609.          IF (K .EQ. M) GO TO 180
  4610.          H(K,K-1) = -S * X
  4611.          GO TO 190
  4612.   180    IF (L .NE. M) H(K,K-1) = -H(K,K-1)
  4613.   190    P = P + S
  4614.          X = P / S
  4615.          Y = Q / S
  4616.          ZZ = R / S
  4617.          Q = Q / P
  4618.          R = R / P
  4619.          IF (NOTLAS) GO TO 225
  4620. C     .......... ROW MODIFICATION ..........
  4621.          DO 200 J = K, N
  4622.             P = H(K,J) + Q * H(K+1,J)
  4623.             H(K,J) = H(K,J) - P * X
  4624.             H(K+1,J) = H(K+1,J) - P * Y
  4625.   200    CONTINUE
  4626. C
  4627.          J = MIN0(EN,K+3)
  4628. C     .......... COLUMN MODIFICATION ..........
  4629.          DO 210 I = 1, J
  4630.             P = X * H(I,K) + Y * H(I,K+1)
  4631.             H(I,K) = H(I,K) - P
  4632.             H(I,K+1) = H(I,K+1) - P * Q
  4633.   210    CONTINUE
  4634. C     .......... ACCUMULATE TRANSFORMATIONS ..........
  4635.          DO 220 I = LOW, IGH
  4636.             P = X * Z(I,K) + Y * Z(I,K+1)
  4637.             Z(I,K) = Z(I,K) - P
  4638.             Z(I,K+1) = Z(I,K+1) - P * Q
  4639.   220    CONTINUE
  4640.          GO TO 255
  4641.   225    CONTINUE
  4642. C     .......... ROW MODIFICATION ..........
  4643.          DO 230 J = K, N
  4644.             P = H(K,J) + Q * H(K+1,J) + R * H(K+2,J)
  4645.             H(K,J) = H(K,J) - P * X
  4646.             H(K+1,J) = H(K+1,J) - P * Y
  4647.             H(K+2,J) = H(K+2,J) - P * ZZ
  4648.   230    CONTINUE
  4649. C
  4650.          J = MIN0(EN,K+3)
  4651. C     .......... COLUMN MODIFICATION ..........
  4652.          DO 240 I = 1, J
  4653.             P = X * H(I,K) + Y * H(I,K+1) + ZZ * H(I,K+2)
  4654.             H(I,K) = H(I,K) - P
  4655.             H(I,K+1) = H(I,K+1) - P * Q
  4656.             H(I,K+2) = H(I,K+2) - P * R
  4657.   240    CONTINUE
  4658. C     .......... ACCUMULATE TRANSFORMATIONS ..........
  4659.          DO 250 I = LOW, IGH
  4660.             P = X * Z(I,K) + Y * Z(I,K+1) + ZZ * Z(I,K+2)
  4661.             Z(I,K) = Z(I,K) - P
  4662.             Z(I,K+1) = Z(I,K+1) - P * Q
  4663.             Z(I,K+2) = Z(I,K+2) - P * R
  4664.   250    CONTINUE
  4665.   255    CONTINUE
  4666. C
  4667.   260 CONTINUE
  4668. C
  4669.       GO TO 70
  4670. C     .......... ONE ROOT FOUND ..........
  4671.   270 H(EN,EN) = X + T
  4672.       WR(EN) = H(EN,EN)
  4673.       WI(EN) = 0.0D0
  4674.       EN = NA
  4675.       GO TO 60
  4676. C     .......... TWO ROOTS FOUND ..........
  4677.   280 P = (Y - X) / 2.0D0
  4678.       Q = P * P + W
  4679.       ZZ = DSQRT(DABS(Q))
  4680.       H(EN,EN) = X + T
  4681.       X = H(EN,EN)
  4682.       H(NA,NA) = Y + T
  4683.       IF (Q .LT. 0.0D0) GO TO 320
  4684. C     .......... REAL PAIR ..........
  4685.       ZZ = P + DSIGN(ZZ,P)
  4686.       WR(NA) = X + ZZ
  4687.       WR(EN) = WR(NA)
  4688.       IF (ZZ .NE. 0.0D0) WR(EN) = X - W / ZZ
  4689.       WI(NA) = 0.0D0
  4690.       WI(EN) = 0.0D0
  4691.       X = H(EN,NA)
  4692.       S = DABS(X) + DABS(ZZ)
  4693.       P = X / S
  4694.       Q = ZZ / S
  4695.       R = DSQRT(P*P+Q*Q)
  4696.       P = P / R
  4697.       Q = Q / R
  4698. C     .......... ROW MODIFICATION ..........
  4699.       DO 290 J = NA, N
  4700.          ZZ = H(NA,J)
  4701.          H(NA,J) = Q * ZZ + P * H(EN,J)
  4702.          H(EN,J) = Q * H(EN,J) - P * ZZ
  4703.   290 CONTINUE
  4704. C     .......... COLUMN MODIFICATION ..........
  4705.       DO 300 I = 1, EN
  4706.          ZZ = H(I,NA)
  4707.          H(I,NA) = Q * ZZ + P * H(I,EN)
  4708.          H(I,EN) = Q * H(I,EN) - P * ZZ
  4709.   300 CONTINUE
  4710. C     .......... ACCUMULATE TRANSFORMATIONS ..........
  4711.       DO 310 I = LOW, IGH
  4712.          ZZ = Z(I,NA)
  4713.          Z(I,NA) = Q * ZZ + P * Z(I,EN)
  4714.          Z(I,EN) = Q * Z(I,EN) - P * ZZ
  4715.   310 CONTINUE
  4716. C
  4717.       GO TO 330
  4718. C     .......... COMPLEX PAIR ..........
  4719.   320 WR(NA) = X + P
  4720.       WR(EN) = X + P
  4721.       WI(NA) = ZZ
  4722.       WI(EN) = -ZZ
  4723.   330 EN = ENM2
  4724.       GO TO 60
  4725. C     .......... ALL ROOTS FOUND.  BACKSUBSTITUTE TO FIND
  4726. C                VECTORS OF UPPER TRIANGULAR FORM ..........
  4727.   340 IF (NORM .EQ. 0.0D0) GO TO 1001
  4728. C     .......... FOR EN=N STEP -1 UNTIL 1 DO -- ..........
  4729.       DO 800 NN = 1, N
  4730.          EN = N + 1 - NN
  4731.          P = WR(EN)
  4732.          Q = WI(EN)
  4733.          NA = EN - 1
  4734.          IF (Q) 710, 600, 800
  4735. C     .......... REAL VECTOR ..........
  4736.   600    M = EN
  4737.          H(EN,EN) = 1.0D0
  4738.          IF (NA .EQ. 0) GO TO 800
  4739. C     .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
  4740.          DO 700 II = 1, NA
  4741.             I = EN - II
  4742.             W = H(I,I) - P
  4743.             R = 0.0D0
  4744. C
  4745.             DO 610 J = M, EN
  4746.   610       R = R + H(I,J) * H(J,EN)
  4747. C
  4748.             IF (WI(I) .GE. 0.0D0) GO TO 630
  4749.             ZZ = W
  4750.             S = R
  4751.             GO TO 700
  4752.   630       M = I
  4753.             IF (WI(I) .NE. 0.0D0) GO TO 640
  4754.             T = W
  4755.             IF (T .NE. 0.0D0) GO TO 635
  4756.                TST1 = NORM
  4757.                T = TST1
  4758.   632          T = 0.01D0 * T
  4759.                TST2 = NORM + T
  4760.                IF (TST2 .GT. TST1) GO TO 632
  4761.   635       H(I,EN) = -R / T
  4762.             GO TO 680
  4763. C     .......... SOLVE REAL EQUATIONS ..........
  4764.   640       X = H(I,I+1)
  4765.             Y = H(I+1,I)
  4766.             Q = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I)
  4767.             T = (X * S - ZZ * R) / Q
  4768.             H(I,EN) = T
  4769.             IF (DABS(X) .LE. DABS(ZZ)) GO TO 650
  4770.             H(I+1,EN) = (-R - W * T) / X
  4771.             GO TO 680
  4772.   650       H(I+1,EN) = (-S - Y * T) / ZZ
  4773. C
  4774. C     .......... OVERFLOW CONTROL ..........
  4775.   680       T = DABS(H(I,EN))
  4776.             IF (T .EQ. 0.0D0) GO TO 700
  4777.             TST1 = T
  4778.             TST2 = TST1 + 1.0D0/TST1
  4779.             IF (TST2 .GT. TST1) GO TO 700
  4780.             DO 690 J = I, EN
  4781.                H(J,EN) = H(J,EN)/T
  4782.   690       CONTINUE
  4783. C
  4784.   700    CONTINUE
  4785. C     .......... END REAL VECTOR ..........
  4786.          GO TO 800
  4787. C     .......... COMPLEX VECTOR ..........
  4788.   710    M = NA
  4789. C     .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT
  4790. C                EIGENVECTOR MATRIX IS TRIANGULAR ..........
  4791.          IF (DABS(H(EN,NA)) .LE. DABS(H(NA,EN))) GO TO 720
  4792.          H(NA,NA) = Q / H(EN,NA)
  4793.          H(NA,EN) = -(H(EN,EN) - P) / H(EN,NA)
  4794.          GO TO 730
  4795.   720    CALL CDIV(0.0D0,-H(NA,EN),H(NA,NA)-P,Q,H(NA,NA),H(NA,EN))
  4796.   730    H(EN,NA) = 0.0D0
  4797.          H(EN,EN) = 1.0D0
  4798.          ENM2 = NA - 1
  4799.          IF (ENM2 .EQ. 0) GO TO 800
  4800. C     .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- ..........
  4801.          DO 795 II = 1, ENM2
  4802.             I = NA - II
  4803.             W = H(I,I) - P
  4804.             RA = 0.0D0
  4805.             SA = 0.0D0
  4806. C
  4807.             DO 760 J = M, EN
  4808.                RA = RA + H(I,J) * H(J,NA)
  4809.                SA = SA + H(I,J) * H(J,EN)
  4810.   760       CONTINUE
  4811. C
  4812.             IF (WI(I) .GE. 0.0D0) GO TO 770
  4813.             ZZ = W
  4814.             R = RA
  4815.             S = SA
  4816.             GO TO 795
  4817.   770       M = I
  4818.             IF (WI(I) .NE. 0.0D0) GO TO 780
  4819.             CALL CDIV(-RA,-SA,W,Q,H(I,NA),H(I,EN))
  4820.             GO TO 790
  4821. C     .......... SOLVE COMPLEX EQUATIONS ..........
  4822.   780       X = H(I,I+1)
  4823.             Y = H(I+1,I)
  4824.             VR = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) - Q * Q
  4825.             VI = (WR(I) - P) * 2.0D0 * Q
  4826.             IF (VR .NE. 0.0D0 .OR. VI .NE. 0.0D0) GO TO 784
  4827.                TST1 = NORM * (DABS(W) + DABS(Q) + DABS(X)
  4828.      X                      + DABS(Y) + DABS(ZZ))
  4829.                VR = TST1
  4830.   783          VR = 0.01D0 * VR
  4831.                TST2 = TST1 + VR
  4832.                IF (TST2 .GT. TST1) GO TO 783
  4833.   784       CALL CDIV(X*R-ZZ*RA+Q*SA,X*S-ZZ*SA-Q*RA,VR,VI,
  4834.      X                H(I,NA),H(I,EN))
  4835.             IF (DABS(X) .LE. DABS(ZZ) + DABS(Q)) GO TO 785
  4836.             H(I+1,NA) = (-RA - W * H(I,NA) + Q * H(I,EN)) / X
  4837.             H(I+1,EN) = (-SA - W * H(I,EN) - Q * H(I,NA)) / X
  4838.             GO TO 790
  4839.   785       CALL CDIV(-R-Y*H(I,NA),-S-Y*H(I,EN),ZZ,Q,
  4840.      X                H(I+1,NA),H(I+1,EN))
  4841. C
  4842. C     .......... OVERFLOW CONTROL ..........
  4843.   790       T = DMAX1(DABS(H(I,NA)), DABS(H(I,EN)))
  4844.             IF (T .EQ. 0.0D0) GO TO 795
  4845.             TST1 = T
  4846.             TST2 = TST1 + 1.0D0/TST1
  4847.             IF (TST2 .GT. TST1) GO TO 795
  4848.             DO 792 J = I, EN
  4849.                H(J,NA) = H(J,NA)/T
  4850.                H(J,EN) = H(J,EN)/T
  4851.   792       CONTINUE
  4852. C
  4853.   795    CONTINUE
  4854. C     .......... END COMPLEX VECTOR ..........
  4855.   800 CONTINUE
  4856. C     .......... END BACK SUBSTITUTION.
  4857. C                VECTORS OF ISOLATED ROOTS ..........
  4858.       DO 840 I = 1, N
  4859.          IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840
  4860. C
  4861.          DO 820 J = I, N
  4862.   820    Z(I,J) = H(I,J)
  4863. C
  4864.   840 CONTINUE
  4865. C     .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
  4866. C                VECTORS OF ORIGINAL FULL MATRIX.
  4867. C                FOR J=N STEP -1 UNTIL LOW DO -- ..........
  4868.       DO 880 JJ = LOW, N
  4869.          J = N + LOW - JJ
  4870.          M = MIN0(J,IGH)
  4871. C
  4872.          DO 880 I = LOW, IGH
  4873.             ZZ = 0.0D0
  4874. C
  4875.             DO 860 K = LOW, M
  4876.   860       ZZ = ZZ + Z(I,K) * H(K,J)
  4877. C
  4878.             Z(I,J) = ZZ
  4879.   880 CONTINUE
  4880. C
  4881.       GO TO 1001
  4882. C     .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
  4883. C                CONVERGED AFTER 30*N ITERATIONS ..........
  4884.  1000 IERR = EN
  4885.  1001 RETURN
  4886.       END
  4887.       SUBROUTINE HTRIB3(NM,N,A,TAU,M,ZR,ZI)
  4888. C
  4889.       INTEGER I,J,K,L,M,N,NM
  4890.       DOUBLE PRECISION A(NM,N),TAU(2,N),ZR(NM,M),ZI(NM,M)
  4891.       DOUBLE PRECISION H,S,SI
  4892. C
  4893. C     THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
  4894. C     THE ALGOL PROCEDURE TRBAK3, NUM. MATH. 11, 181-195(1968)
  4895. C     BY MARTIN, REINSCH, AND WILKINSON.
  4896. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
  4897. C
  4898. C     THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX HERMITIAN
  4899. C     MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
  4900. C     REAL SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY  HTRID3.
  4901. C
  4902. C     ON INPUT
  4903. C
  4904. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  4905. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  4906. C          DIMENSION STATEMENT.
  4907. C
  4908. C        N IS THE ORDER OF THE MATRIX.
  4909. C
  4910. C        A CONTAINS INFORMATION ABOUT THE UNITARY TRANSFORMATIONS
  4911. C          USED IN THE REDUCTION BY  HTRID3.
  4912. C
  4913. C        TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS.
  4914. C
  4915. C        M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
  4916. C
  4917. C        ZR CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED
  4918. C          IN ITS FIRST M COLUMNS.
  4919. C
  4920. C     ON OUTPUT
  4921. C
  4922. C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
  4923. C          RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
  4924. C          IN THEIR FIRST M COLUMNS.
  4925. C
  4926. C     NOTE THAT THE LAST COMPONENT OF EACH RETURNED VECTOR
  4927. C     IS REAL AND THAT VECTOR EUCLIDEAN NORMS ARE PRESERVED.
  4928. C
  4929. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  4930. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  4931. C
  4932. C     THIS VERSION DATED AUGUST 1983.
  4933. C
  4934. C     ------------------------------------------------------------------
  4935. C
  4936.       IF (M .EQ. 0) GO TO 200
  4937. C     .......... TRANSFORM THE EIGENVECTORS OF THE REAL SYMMETRIC
  4938. C                TRIDIAGONAL MATRIX TO THOSE OF THE HERMITIAN
  4939. C                TRIDIAGONAL MATRIX. ..........
  4940.       DO 50 K = 1, N
  4941. C
  4942.          DO 50 J = 1, M
  4943.             ZI(K,J) = -ZR(K,J) * TAU(2,K)
  4944.             ZR(K,J) = ZR(K,J) * TAU(1,K)
  4945.    50 CONTINUE
  4946. C
  4947.       IF (N .EQ. 1) GO TO 200
  4948. C     .......... RECOVER AND APPLY THE HOUSEHOLDER MATRICES ..........
  4949.       DO 140 I = 2, N
  4950.          L = I - 1
  4951.          H = A(I,I)
  4952.          IF (H .EQ. 0.0D0) GO TO 140
  4953. C
  4954.          DO 130 J = 1, M
  4955.             S = 0.0D0
  4956.             SI = 0.0D0
  4957. C
  4958.             DO 110 K = 1, L
  4959.                S = S + A(I,K) * ZR(K,J) - A(K,I) * ZI(K,J)
  4960.                SI = SI + A(I,K) * ZI(K,J) + A(K,I) * ZR(K,J)
  4961.   110       CONTINUE
  4962. C     .......... DOUBLE DIVISIONS AVOID POSSIBLE UNDERFLOW ..........
  4963.             S = (S / H) / H
  4964.             SI = (SI / H) / H
  4965. C
  4966.             DO 120 K = 1, L
  4967.                ZR(K,J) = ZR(K,J) - S * A(I,K) - SI * A(K,I)
  4968.                ZI(K,J) = ZI(K,J) - SI * A(I,K) + S * A(K,I)
  4969.   120       CONTINUE
  4970. C
  4971.   130    CONTINUE
  4972. C
  4973.   140 CONTINUE
  4974. C
  4975.   200 RETURN
  4976.       END
  4977.       SUBROUTINE HTRIBK(NM,N,AR,AI,TAU,M,ZR,ZI)
  4978. C
  4979.       INTEGER I,J,K,L,M,N,NM
  4980.       DOUBLE PRECISION AR(NM,N),AI(NM,N),TAU(2,N),ZR(NM,M),ZI(NM,M)
  4981.       DOUBLE PRECISION H,S,SI
  4982. C
  4983. C     THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
  4984. C     THE ALGOL PROCEDURE TRBAK1, NUM. MATH. 11, 181-195(1968)
  4985. C     BY MARTIN, REINSCH, AND WILKINSON.
  4986. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
  4987. C
  4988. C     THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX HERMITIAN
  4989. C     MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
  4990. C     REAL SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY  HTRIDI.
  4991. C
  4992. C     ON INPUT
  4993. C
  4994. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  4995. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  4996. C          DIMENSION STATEMENT.
  4997. C
  4998. C        N IS THE ORDER OF THE MATRIX.
  4999. C
  5000. C        AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
  5001. C          FORMATIONS USED IN THE REDUCTION BY  HTRIDI  IN THEIR
  5002. C          FULL LOWER TRIANGLES EXCEPT FOR THE DIAGONAL OF AR.
  5003. C
  5004. C        TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS.
  5005. C
  5006. C        M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
  5007. C
  5008. C        ZR CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED
  5009. C          IN ITS FIRST M COLUMNS.
  5010. C
  5011. C     ON OUTPUT
  5012. C
  5013. C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
  5014. C          RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
  5015. C          IN THEIR FIRST M COLUMNS.
  5016. C
  5017. C     NOTE THAT THE LAST COMPONENT OF EACH RETURNED VECTOR
  5018. C     IS REAL AND THAT VECTOR EUCLIDEAN NORMS ARE PRESERVED.
  5019. C
  5020. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  5021. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  5022. C
  5023. C     THIS VERSION DATED AUGUST 1983.
  5024. C
  5025. C     ------------------------------------------------------------------
  5026. C
  5027.       IF (M .EQ. 0) GO TO 200
  5028. C     .......... TRANSFORM THE EIGENVECTORS OF THE REAL SYMMETRIC
  5029. C                TRIDIAGONAL MATRIX TO THOSE OF THE HERMITIAN
  5030. C                TRIDIAGONAL MATRIX. ..........
  5031.       DO 50 K = 1, N
  5032. C
  5033.          DO 50 J = 1, M
  5034.             ZI(K,J) = -ZR(K,J) * TAU(2,K)
  5035.             ZR(K,J) = ZR(K,J) * TAU(1,K)
  5036.    50 CONTINUE
  5037. C
  5038.       IF (N .EQ. 1) GO TO 200
  5039. C     .......... RECOVER AND APPLY THE HOUSEHOLDER MATRICES ..........
  5040.       DO 140 I = 2, N
  5041.          L = I - 1
  5042.          H = AI(I,I)
  5043.          IF (H .EQ. 0.0D0) GO TO 140
  5044. C
  5045.          DO 130 J = 1, M
  5046.             S = 0.0D0
  5047.             SI = 0.0D0
  5048. C
  5049.             DO 110 K = 1, L
  5050.                S = S + AR(I,K) * ZR(K,J) - AI(I,K) * ZI(K,J)
  5051.                SI = SI + AR(I,K) * ZI(K,J) + AI(I,K) * ZR(K,J)
  5052.   110       CONTINUE
  5053. C     .......... DOUBLE DIVISIONS AVOID POSSIBLE UNDERFLOW ..........
  5054.             S = (S / H) / H
  5055.             SI = (SI / H) / H
  5056. C
  5057.             DO 120 K = 1, L
  5058.                ZR(K,J) = ZR(K,J) - S * AR(I,K) - SI * AI(I,K)
  5059.                ZI(K,J) = ZI(K,J) - SI * AR(I,K) + S * AI(I,K)
  5060.   120       CONTINUE
  5061. C
  5062.   130    CONTINUE
  5063. C
  5064.   140 CONTINUE
  5065. C
  5066.   200 RETURN
  5067.       END
  5068.       SUBROUTINE HTRID3(NM,N,A,D,E,E2,TAU)
  5069. C
  5070.       INTEGER I,J,K,L,N,II,NM,JM1,JP1
  5071.       DOUBLE PRECISION A(NM,N),D(N),E(N),E2(N),TAU(2,N)
  5072.       DOUBLE PRECISION F,G,H,FI,GI,HH,SI,SCALE,PYTHAG
  5073. C
  5074. C     THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
  5075. C     THE ALGOL PROCEDURE TRED3, NUM. MATH. 11, 181-195(1968)
  5076. C     BY MARTIN, REINSCH, AND WILKINSON.
  5077. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
  5078. C
  5079. C     THIS SUBROUTINE REDUCES A COMPLEX HERMITIAN MATRIX, STORED AS
  5080. C     A SINGLE SQUARE ARRAY, TO A REAL SYMMETRIC TRIDIAGONAL MATRIX
  5081. C     USING UNITARY SIMILARITY TRANSFORMATIONS.
  5082. C
  5083. C     ON INPUT
  5084. C
  5085. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  5086. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  5087. C          DIMENSION STATEMENT.
  5088. C
  5089. C        N IS THE ORDER OF THE MATRIX.
  5090. C
  5091. C        A CONTAINS THE LOWER TRIANGLE OF THE COMPLEX HERMITIAN INPUT
  5092. C          MATRIX.  THE REAL PARTS OF THE MATRIX ELEMENTS ARE STORED
  5093. C          IN THE FULL LOWER TRIANGLE OF A, AND THE IMAGINARY PARTS
  5094. C          ARE STORED IN THE TRANSPOSED POSITIONS OF THE STRICT UPPER
  5095. C          TRIANGLE OF A.  NO STORAGE IS REQUIRED FOR THE ZERO
  5096. C          IMAGINARY PARTS OF THE DIAGONAL ELEMENTS.
  5097. C
  5098. C     ON OUTPUT
  5099. C
  5100. C        A CONTAINS INFORMATION ABOUT THE UNITARY TRANSFORMATIONS
  5101. C          USED IN THE REDUCTION.
  5102. C
  5103. C        D CONTAINS THE DIAGONAL ELEMENTS OF THE THE TRIDIAGONAL MATRIX.
  5104. C
  5105. C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
  5106. C          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS SET TO ZERO.
  5107. C
  5108. C        E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
  5109. C          E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
  5110. C
  5111. C        TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS.
  5112. C
  5113. C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
  5114. C
  5115. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  5116. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  5117. C
  5118. C     THIS VERSION DATED AUGUST 1983.
  5119. C
  5120. C     ------------------------------------------------------------------
  5121. C
  5122.       TAU(1,N) = 1.0D0
  5123.       TAU(2,N) = 0.0D0
  5124. C     .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
  5125.       DO 300 II = 1, N
  5126.          I = N + 1 - II
  5127.          L = I - 1
  5128.          H = 0.0D0
  5129.          SCALE = 0.0D0
  5130.          IF (L .LT. 1) GO TO 130
  5131. C     .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) ..........
  5132.          DO 120 K = 1, L
  5133.   120    SCALE = SCALE + DABS(A(I,K)) + DABS(A(K,I))
  5134. C
  5135.          IF (SCALE .NE. 0.0D0) GO TO 140
  5136.          TAU(1,L) = 1.0D0
  5137.          TAU(2,L) = 0.0D0
  5138.   130    E(I) = 0.0D0
  5139.          E2(I) = 0.0D0
  5140.          GO TO 290
  5141. C
  5142.   140    DO 150 K = 1, L
  5143.             A(I,K) = A(I,K) / SCALE
  5144.             A(K,I) = A(K,I) / SCALE
  5145.             H = H + A(I,K) * A(I,K) + A(K,I) * A(K,I)
  5146.   150    CONTINUE
  5147. C
  5148.          E2(I) = SCALE * SCALE * H
  5149.          G = DSQRT(H)
  5150.          E(I) = SCALE * G
  5151.          F = PYTHAG(A(I,L),A(L,I))
  5152. C     .......... FORM NEXT DIAGONAL ELEMENT OF MATRIX T ..........
  5153.          IF (F .EQ. 0.0D0) GO TO 160
  5154.          TAU(1,L) = (A(L,I) * TAU(2,I) - A(I,L) * TAU(1,I)) / F
  5155.          SI = (A(I,L) * TAU(2,I) + A(L,I) * TAU(1,I)) / F
  5156.          H = H + F * G
  5157.          G = 1.0D0 + G / F
  5158.          A(I,L) = G * A(I,L)
  5159.          A(L,I) = G * A(L,I)
  5160.          IF (L .EQ. 1) GO TO 270
  5161.          GO TO 170
  5162.   160    TAU(1,L) = -TAU(1,I)
  5163.          SI = TAU(2,I)
  5164.          A(I,L) = G
  5165.   170    F = 0.0D0
  5166. C
  5167.          DO 240 J = 1, L
  5168.             G = 0.0D0
  5169.             GI = 0.0D0
  5170.             IF (J .EQ. 1) GO TO 190
  5171.             JM1 = J - 1
  5172. C     .......... FORM ELEMENT OF A*U ..........
  5173.             DO 180 K = 1, JM1
  5174.                G = G + A(J,K) * A(I,K) + A(K,J) * A(K,I)
  5175.                GI = GI - A(J,K) * A(K,I) + A(K,J) * A(I,K)
  5176.   180       CONTINUE
  5177. C
  5178.   190       G = G + A(J,J) * A(I,J)
  5179.             GI = GI - A(J,J) * A(J,I)
  5180.             JP1 = J + 1
  5181.             IF (L .LT. JP1) GO TO 220
  5182. C
  5183.             DO 200 K = JP1, L
  5184.                G = G + A(K,J) * A(I,K) - A(J,K) * A(K,I)
  5185.                GI = GI - A(K,J) * A(K,I) - A(J,K) * A(I,K)
  5186.   200       CONTINUE
  5187. C     .......... FORM ELEMENT OF P ..........
  5188.   220       E(J) = G / H
  5189.             TAU(2,J) = GI / H
  5190.             F = F + E(J) * A(I,J) - TAU(2,J) * A(J,I)
  5191.   240    CONTINUE
  5192. C
  5193.          HH = F / (H + H)
  5194. C     .......... FORM REDUCED A ..........
  5195.          DO 260 J = 1, L
  5196.             F = A(I,J)
  5197.             G = E(J) - HH * F
  5198.             E(J) = G
  5199.             FI = -A(J,I)
  5200.             GI = TAU(2,J) - HH * FI
  5201.             TAU(2,J) = -GI
  5202.             A(J,J) = A(J,J) - 2.0D0 * (F * G + FI * GI)
  5203.             IF (J .EQ. 1) GO TO 260
  5204.             JM1 = J - 1
  5205. C
  5206.             DO 250 K = 1, JM1
  5207.                A(J,K) = A(J,K) - F * E(K) - G * A(I,K)
  5208.      X                         + FI * TAU(2,K) + GI * A(K,I)
  5209.                A(K,J) = A(K,J) - F * TAU(2,K) - G * A(K,I)
  5210.      X                         - FI * E(K) - GI * A(I,K)
  5211.   250       CONTINUE
  5212. C
  5213.   260    CONTINUE
  5214. C
  5215.   270    DO 280 K = 1, L
  5216.             A(I,K) = SCALE * A(I,K)
  5217.             A(K,I) = SCALE * A(K,I)
  5218.   280    CONTINUE
  5219. C
  5220.          TAU(2,L) = -SI
  5221.   290    D(I) = A(I,I)
  5222.          A(I,I) = SCALE * DSQRT(H)
  5223.   300 CONTINUE
  5224. C
  5225.       RETURN
  5226.       END
  5227.       SUBROUTINE HTRIDI(NM,N,AR,AI,D,E,E2,TAU)
  5228. C
  5229.       INTEGER I,J,K,L,N,II,NM,JP1
  5230.       DOUBLE PRECISION AR(NM,N),AI(NM,N),D(N),E(N),E2(N),TAU(2,N)
  5231.       DOUBLE PRECISION F,G,H,FI,GI,HH,SI,SCALE,PYTHAG
  5232. C
  5233. C     THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
  5234. C     THE ALGOL PROCEDURE TRED1, NUM. MATH. 11, 181-195(1968)
  5235. C     BY MARTIN, REINSCH, AND WILKINSON.
  5236. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
  5237. C
  5238. C     THIS SUBROUTINE REDUCES A COMPLEX HERMITIAN MATRIX
  5239. C     TO A REAL SYMMETRIC TRIDIAGONAL MATRIX USING
  5240. C     UNITARY SIMILARITY TRANSFORMATIONS.
  5241. C
  5242. C     ON INPUT
  5243. C
  5244. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  5245. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  5246. C          DIMENSION STATEMENT.
  5247. C
  5248. C        N IS THE ORDER OF THE MATRIX.
  5249. C
  5250. C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
  5251. C          RESPECTIVELY, OF THE COMPLEX HERMITIAN INPUT MATRIX.
  5252. C          ONLY THE LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED.
  5253. C
  5254. C     ON OUTPUT
  5255. C
  5256. C        AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
  5257. C          FORMATIONS USED IN THE REDUCTION IN THEIR FULL LOWER
  5258. C          TRIANGLES.  THEIR STRICT UPPER TRIANGLES AND THE
  5259. C          DIAGONAL OF AR ARE UNALTERED.
  5260. C
  5261. C        D CONTAINS THE DIAGONAL ELEMENTS OF THE THE TRIDIAGONAL MATRIX.
  5262. C
  5263. C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
  5264. C          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS SET TO ZERO.
  5265. C
  5266. C        E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
  5267. C          E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
  5268. C
  5269. C        TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS.
  5270. C
  5271. C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
  5272. C
  5273. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  5274. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  5275. C
  5276. C     THIS VERSION DATED AUGUST 1983.
  5277. C
  5278. C     ------------------------------------------------------------------
  5279. C
  5280.       TAU(1,N) = 1.0D0
  5281.       TAU(2,N) = 0.0D0
  5282. C
  5283.       DO 100 I = 1, N
  5284.   100 D(I) = AR(I,I)
  5285. C     .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
  5286.       DO 300 II = 1, N
  5287.          I = N + 1 - II
  5288.          L = I - 1
  5289.          H = 0.0D0
  5290.          SCALE = 0.0D0
  5291.          IF (L .LT. 1) GO TO 130
  5292. C     .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) ..........
  5293.          DO 120 K = 1, L
  5294.   120    SCALE = SCALE + DABS(AR(I,K)) + DABS(AI(I,K))
  5295. C
  5296.          IF (SCALE .NE. 0.0D0) GO TO 140
  5297.          TAU(1,L) = 1.0D0
  5298.          TAU(2,L) = 0.0D0
  5299.   130    E(I) = 0.0D0
  5300.          E2(I) = 0.0D0
  5301.          GO TO 290
  5302. C
  5303.   140    DO 150 K = 1, L
  5304.             AR(I,K) = AR(I,K) / SCALE
  5305.             AI(I,K) = AI(I,K) / SCALE
  5306.             H = H + AR(I,K) * AR(I,K) + AI(I,K) * AI(I,K)
  5307.   150    CONTINUE
  5308. C
  5309.          E2(I) = SCALE * SCALE * H
  5310.          G = DSQRT(H)
  5311.          E(I) = SCALE * G
  5312.          F = PYTHAG(AR(I,L),AI(I,L))
  5313. C     .......... FORM NEXT DIAGONAL ELEMENT OF MATRIX T ..........
  5314.          IF (F .EQ. 0.0D0) GO TO 160
  5315.          TAU(1,L) = (AI(I,L) * TAU(2,I) - AR(I,L) * TAU(1,I)) / F
  5316.          SI = (AR(I,L) * TAU(2,I) + AI(I,L) * TAU(1,I)) / F
  5317.          H = H + F * G
  5318.          G = 1.0D0 + G / F
  5319.          AR(I,L) = G * AR(I,L)
  5320.          AI(I,L) = G * AI(I,L)
  5321.          IF (L .EQ. 1) GO TO 270
  5322.          GO TO 170
  5323.   160    TAU(1,L) = -TAU(1,I)
  5324.          SI = TAU(2,I)
  5325.          AR(I,L) = G
  5326.   170    F = 0.0D0
  5327. C
  5328.          DO 240 J = 1, L
  5329.             G = 0.0D0
  5330.             GI = 0.0D0
  5331. C     .......... FORM ELEMENT OF A*U ..........
  5332.             DO 180 K = 1, J
  5333.                G = G + AR(J,K) * AR(I,K) + AI(J,K) * AI(I,K)
  5334.                GI = GI - AR(J,K) * AI(I,K) + AI(J,K) * AR(I,K)
  5335.   180       CONTINUE
  5336. C
  5337.             JP1 = J + 1
  5338.             IF (L .LT. JP1) GO TO 220
  5339. C
  5340.             DO 200 K = JP1, L
  5341.                G = G + AR(K,J) * AR(I,K) - AI(K,J) * AI(I,K)
  5342.                GI = GI - AR(K,J) * AI(I,K) - AI(K,J) * AR(I,K)
  5343.   200       CONTINUE
  5344. C     .......... FORM ELEMENT OF P ..........
  5345.   220       E(J) = G / H
  5346.             TAU(2,J) = GI / H
  5347.             F = F + E(J) * AR(I,J) - TAU(2,J) * AI(I,J)
  5348.   240    CONTINUE
  5349. C
  5350.          HH = F / (H + H)
  5351. C     .......... FORM REDUCED A ..........
  5352.          DO 260 J = 1, L
  5353.             F = AR(I,J)
  5354.             G = E(J) - HH * F
  5355.             E(J) = G
  5356.             FI = -AI(I,J)
  5357.             GI = TAU(2,J) - HH * FI
  5358.             TAU(2,J) = -GI
  5359. C
  5360.             DO 260 K = 1, J
  5361.                AR(J,K) = AR(J,K) - F * E(K) - G * AR(I,K)
  5362.      X                           + FI * TAU(2,K) + GI * AI(I,K)
  5363.                AI(J,K) = AI(J,K) - F * TAU(2,K) - G * AI(I,K)
  5364.      X                           - FI * E(K) - GI * AR(I,K)
  5365.   260    CONTINUE
  5366. C
  5367.   270    DO 280 K = 1, L
  5368.             AR(I,K) = SCALE * AR(I,K)
  5369.             AI(I,K) = SCALE * AI(I,K)
  5370.   280    CONTINUE
  5371. C
  5372.          TAU(2,L) = -SI
  5373.   290    HH = D(I)
  5374.          D(I) = AR(I,I)
  5375.          AR(I,I) = HH
  5376.          AI(I,I) = SCALE * DSQRT(H)
  5377.   300 CONTINUE
  5378. C
  5379.       RETURN
  5380.       END
  5381.       SUBROUTINE IMTQL1(N,D,E,IERR)
  5382. C
  5383.       INTEGER I,J,L,M,N,II,MML,IERR
  5384.       DOUBLE PRECISION D(N),E(N)
  5385.       DOUBLE PRECISION B,C,F,G,P,R,S,TST1,TST2,PYTHAG
  5386. C
  5387. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE IMTQL1,
  5388. C     NUM. MATH. 12, 377-383(1968) BY MARTIN AND WILKINSON,
  5389. C     AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE.
  5390. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971).
  5391. C
  5392. C     THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC
  5393. C     TRIDIAGONAL MATRIX BY THE IMPLICIT QL METHOD.
  5394. C
  5395. C     ON INPUT
  5396. C
  5397. C        N IS THE ORDER OF THE MATRIX.
  5398. C
  5399. C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
  5400. C
  5401. C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
  5402. C          IN ITS LAST N-1 POSITIONS.  E(1) IS ARBITRARY.
  5403. C
  5404. C      ON OUTPUT
  5405. C
  5406. C        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
  5407. C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND
  5408. C          ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE
  5409. C          THE SMALLEST EIGENVALUES.
  5410. C
  5411. C        E HAS BEEN DESTROYED.
  5412. C
  5413. C        IERR IS SET TO
  5414. C          ZERO       FOR NORMAL RETURN,
  5415. C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
  5416. C                     DETERMINED AFTER 30 ITERATIONS.
  5417. C
  5418. C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
  5419. C
  5420. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  5421. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  5422. C
  5423. C     THIS VERSION DATED AUGUST 1983.
  5424. C
  5425. C     ------------------------------------------------------------------
  5426. C
  5427.       IERR = 0
  5428.       IF (N .EQ. 1) GO TO 1001
  5429. C
  5430.       DO 100 I = 2, N
  5431.   100 E(I-1) = E(I)
  5432. C
  5433.       E(N) = 0.0D0
  5434. C
  5435.       DO 290 L = 1, N
  5436.          J = 0
  5437. C     .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT ..........
  5438.   105    DO 110 M = L, N
  5439.             IF (M .EQ. N) GO TO 120
  5440.             TST1 = DABS(D(M)) + DABS(D(M+1))
  5441.             TST2 = TST1 + DABS(E(M))
  5442.             IF (TST2 .EQ. TST1) GO TO 120
  5443.   110    CONTINUE
  5444. C
  5445.   120    P = D(L)
  5446.          IF (M .EQ. L) GO TO 215
  5447.          IF (J .EQ. 30) GO TO 1000
  5448.          J = J + 1
  5449. C     .......... FORM SHIFT ..........
  5450.          G = (D(L+1) - P) / (2.0D0 * E(L))
  5451.          R = PYTHAG(G,1.0D0)
  5452.          G = D(M) - P + E(L) / (G + DSIGN(R,G))
  5453.          S = 1.0D0
  5454.          C = 1.0D0
  5455.          P = 0.0D0
  5456.          MML = M - L
  5457. C     .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
  5458.          DO 200 II = 1, MML
  5459.             I = M - II
  5460.             F = S * E(I)
  5461.             B = C * E(I)
  5462.             R = PYTHAG(F,G)
  5463.             E(I+1) = R
  5464.             IF (R .EQ. 0.0D0) GO TO 210
  5465.             S = F / R
  5466.             C = G / R
  5467.             G = D(I+1) - P
  5468.             R = (D(I) - G) * S + 2.0D0 * C * B
  5469.             P = S * R
  5470.             D(I+1) = G + P
  5471.             G = C * R - B
  5472.   200    CONTINUE
  5473. C
  5474.          D(L) = D(L) - P
  5475.          E(L) = G
  5476.          E(M) = 0.0D0
  5477.          GO TO 105
  5478. C     .......... RECOVER FROM UNDERFLOW ..........
  5479.   210    D(I+1) = D(I+1) - P
  5480.          E(M) = 0.0D0
  5481.          GO TO 105
  5482. C     .......... ORDER EIGENVALUES ..........
  5483.   215    IF (L .EQ. 1) GO TO 250
  5484. C     .......... FOR I=L STEP -1 UNTIL 2 DO -- ..........
  5485.          DO 230 II = 2, L
  5486.             I = L + 2 - II
  5487.             IF (P .GE. D(I-1)) GO TO 270
  5488.             D(I) = D(I-1)
  5489.   230    CONTINUE
  5490. C
  5491.   250    I = 1
  5492.   270    D(I) = P
  5493.   290 CONTINUE
  5494. C
  5495.       GO TO 1001
  5496. C     .......... SET ERROR -- NO CONVERGENCE TO AN
  5497. C                EIGENVALUE AFTER 30 ITERATIONS ..........
  5498.  1000 IERR = L
  5499.  1001 RETURN
  5500.       END
  5501.       SUBROUTINE IMTQL2(NM,N,D,E,Z,IERR)
  5502. C
  5503.       INTEGER I,J,K,L,M,N,II,NM,MML,IERR
  5504.       DOUBLE PRECISION D(N),E(N),Z(NM,N)
  5505.       DOUBLE PRECISION B,C,F,G,P,R,S,TST1,TST2,PYTHAG
  5506. C
  5507. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE IMTQL2,
  5508. C     NUM. MATH. 12, 377-383(1968) BY MARTIN AND WILKINSON,
  5509. C     AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE.
  5510. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971).
  5511. C
  5512. C     THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
  5513. C     OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE IMPLICIT QL METHOD.
  5514. C     THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO
  5515. C     BE FOUND IF  TRED2  HAS BEEN USED TO REDUCE THIS
  5516. C     FULL MATRIX TO TRIDIAGONAL FORM.
  5517. C
  5518. C     ON INPUT
  5519. C
  5520. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  5521. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  5522. C          DIMENSION STATEMENT.
  5523. C
  5524. C        N IS THE ORDER OF THE MATRIX.
  5525. C
  5526. C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
  5527. C
  5528. C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
  5529. C          IN ITS LAST N-1 POSITIONS.  E(1) IS ARBITRARY.
  5530. C
  5531. C        Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
  5532. C          REDUCTION BY  TRED2, IF PERFORMED.  IF THE EIGENVECTORS
  5533. C          OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN
  5534. C          THE IDENTITY MATRIX.
  5535. C
  5536. C      ON OUTPUT
  5537. C
  5538. C        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
  5539. C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT
  5540. C          UNORDERED FOR INDICES 1,2,...,IERR-1.
  5541. C
  5542. C        E HAS BEEN DESTROYED.
  5543. C
  5544. C        Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC
  5545. C          TRIDIAGONAL (OR FULL) MATRIX.  IF AN ERROR EXIT IS MADE,
  5546. C          Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED
  5547. C          EIGENVALUES.
  5548. C
  5549. C        IERR IS SET TO
  5550. C          ZERO       FOR NORMAL RETURN,
  5551. C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
  5552. C                     DETERMINED AFTER 30 ITERATIONS.
  5553. C
  5554. C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
  5555. C
  5556. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  5557. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  5558. C
  5559. C     THIS VERSION DATED AUGUST 1983.
  5560. C
  5561. C     ------------------------------------------------------------------
  5562. C
  5563.       IERR = 0
  5564.       IF (N .EQ. 1) GO TO 1001
  5565. C
  5566.       DO 100 I = 2, N
  5567.   100 E(I-1) = E(I)
  5568. C
  5569.       E(N) = 0.0D0
  5570. C
  5571.       DO 240 L = 1, N
  5572.          J = 0
  5573. C     .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT ..........
  5574.   105    DO 110 M = L, N
  5575.             IF (M .EQ. N) GO TO 120
  5576.             TST1 = DABS(D(M)) + DABS(D(M+1))
  5577.             TST2 = TST1 + DABS(E(M))
  5578.             IF (TST2 .EQ. TST1) GO TO 120
  5579.   110    CONTINUE
  5580. C
  5581.   120    P = D(L)
  5582.          IF (M .EQ. L) GO TO 240
  5583.          IF (J .EQ. 30) GO TO 1000
  5584.          J = J + 1
  5585. C     .......... FORM SHIFT ..........
  5586.          G = (D(L+1) - P) / (2.0D0 * E(L))
  5587.          R = PYTHAG(G,1.0D0)
  5588.          G = D(M) - P + E(L) / (G + DSIGN(R,G))
  5589.          S = 1.0D0
  5590.          C = 1.0D0
  5591.          P = 0.0D0
  5592.          MML = M - L
  5593. C     .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
  5594.          DO 200 II = 1, MML
  5595.             I = M - II
  5596.             F = S * E(I)
  5597.             B = C * E(I)
  5598.             R = PYTHAG(F,G)
  5599.             E(I+1) = R
  5600.             IF (R .EQ. 0.0D0) GO TO 210
  5601.             S = F / R
  5602.             C = G / R
  5603.             G = D(I+1) - P
  5604.             R = (D(I) - G) * S + 2.0D0 * C * B
  5605.             P = S * R
  5606.             D(I+1) = G + P
  5607.             G = C * R - B
  5608. C     .......... FORM VECTOR ..........
  5609.             DO 180 K = 1, N
  5610.                F = Z(K,I+1)
  5611.                Z(K,I+1) = S * Z(K,I) + C * F
  5612.                Z(K,I) = C * Z(K,I) - S * F
  5613.   180       CONTINUE
  5614. C
  5615.   200    CONTINUE
  5616. C
  5617.          D(L) = D(L) - P
  5618.          E(L) = G
  5619.          E(M) = 0.0D0
  5620.          GO TO 105
  5621. C     .......... RECOVER FROM UNDERFLOW ..........
  5622.   210    D(I+1) = D(I+1) - P
  5623.          E(M) = 0.0D0
  5624.          GO TO 105
  5625.   240 CONTINUE
  5626. C     .......... ORDER EIGENVALUES AND EIGENVECTORS ..........
  5627.       DO 300 II = 2, N
  5628.          I = II - 1
  5629.          K = I
  5630.          P = D(I)
  5631. C
  5632.          DO 260 J = II, N
  5633.             IF (D(J) .GE. P) GO TO 260
  5634.             K = J
  5635.             P = D(J)
  5636.   260    CONTINUE
  5637. C
  5638.          IF (K .EQ. I) GO TO 300
  5639.          D(K) = D(I)
  5640.          D(I) = P
  5641. C
  5642.          DO 280 J = 1, N
  5643.             P = Z(J,I)
  5644.             Z(J,I) = Z(J,K)
  5645.             Z(J,K) = P
  5646.   280    CONTINUE
  5647. C
  5648.   300 CONTINUE
  5649. C
  5650.       GO TO 1001
  5651. C     .......... SET ERROR -- NO CONVERGENCE TO AN
  5652. C                EIGENVALUE AFTER 30 ITERATIONS ..........
  5653.  1000 IERR = L
  5654.  1001 RETURN
  5655.       END
  5656.       SUBROUTINE IMTQLV(N,D,E,E2,W,IND,IERR,RV1)
  5657. C
  5658.       INTEGER I,J,K,L,M,N,II,MML,TAG,IERR
  5659.       DOUBLE PRECISION D(N),E(N),E2(N),W(N),RV1(N)
  5660.       DOUBLE PRECISION B,C,F,G,P,R,S,TST1,TST2,PYTHAG
  5661.       INTEGER IND(N)
  5662. C
  5663. C     THIS SUBROUTINE IS A VARIANT OF  IMTQL1  WHICH IS A TRANSLATION OF
  5664. C     ALGOL PROCEDURE IMTQL1, NUM. MATH. 12, 377-383(1968) BY MARTIN AND
  5665. C     WILKINSON, AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE.
  5666. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971).
  5667. C
  5668. C     THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC TRIDIAGONAL
  5669. C     MATRIX BY THE IMPLICIT QL METHOD AND ASSOCIATES WITH THEM
  5670. C     THEIR CORRESPONDING SUBMATRIX INDICES.
  5671. C
  5672. C     ON INPUT
  5673. C
  5674. C        N IS THE ORDER OF THE MATRIX.
  5675. C
  5676. C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
  5677. C
  5678. C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
  5679. C          IN ITS LAST N-1 POSITIONS.  E(1) IS ARBITRARY.
  5680. C
  5681. C        E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
  5682. C          E2(1) IS ARBITRARY.
  5683. C
  5684. C     ON OUTPUT
  5685. C
  5686. C        D AND E ARE UNALTERED.
  5687. C
  5688. C        ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED
  5689. C          AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE
  5690. C          MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES.
  5691. C          E2(1) IS ALSO SET TO ZERO.
  5692. C
  5693. C        W CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
  5694. C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND
  5695. C          ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE
  5696. C          THE SMALLEST EIGENVALUES.
  5697. C
  5698. C        IND CONTAINS THE SUBMATRIX INDICES ASSOCIATED WITH THE
  5699. C          CORRESPONDING EIGENVALUES IN W -- 1 FOR EIGENVALUES
  5700. C          BELONGING TO THE FIRST SUBMATRIX FROM THE TOP,
  5701. C          2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC..
  5702. C
  5703. C        IERR IS SET TO
  5704. C          ZERO       FOR NORMAL RETURN,
  5705. C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
  5706. C                     DETERMINED AFTER 30 ITERATIONS.
  5707. C
  5708. C        RV1 IS A TEMPORARY STORAGE ARRAY.
  5709. C
  5710. C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
  5711. C
  5712. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  5713. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  5714. C
  5715. C     THIS VERSION DATED AUGUST 1983.
  5716. C
  5717. C     ------------------------------------------------------------------
  5718. C
  5719.       IERR = 0
  5720.       K = 0
  5721.       TAG = 0
  5722. C
  5723.       DO 100 I = 1, N
  5724.          W(I) = D(I)
  5725.          IF (I .NE. 1) RV1(I-1) = E(I)
  5726.   100 CONTINUE
  5727. C
  5728.       E2(1) = 0.0D0
  5729.       RV1(N) = 0.0D0
  5730. C
  5731.       DO 290 L = 1, N
  5732.          J = 0
  5733. C     .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT ..........
  5734.   105    DO 110 M = L, N
  5735.             IF (M .EQ. N) GO TO 120
  5736.             TST1 = DABS(W(M)) + DABS(W(M+1))
  5737.             TST2 = TST1 + DABS(RV1(M))
  5738.             IF (TST2 .EQ. TST1) GO TO 120
  5739. C     .......... GUARD AGAINST UNDERFLOWED ELEMENT OF E2 ..........
  5740.             IF (E2(M+1) .EQ. 0.0D0) GO TO 125
  5741.   110    CONTINUE
  5742. C
  5743.   120    IF (M .LE. K) GO TO 130
  5744.          IF (M .NE. N) E2(M+1) = 0.0D0
  5745.   125    K = M
  5746.          TAG = TAG + 1
  5747.   130    P = W(L)
  5748.          IF (M .EQ. L) GO TO 215
  5749.          IF (J .EQ. 30) GO TO 1000
  5750.          J = J + 1
  5751. C     .......... FORM SHIFT ..........
  5752.          G = (W(L+1) - P) / (2.0D0 * RV1(L))
  5753.          R = PYTHAG(G,1.0D0)
  5754.          G = W(M) - P + RV1(L) / (G + DSIGN(R,G))
  5755.          S = 1.0D0
  5756.          C = 1.0D0
  5757.          P = 0.0D0
  5758.          MML = M - L
  5759. C     .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
  5760.          DO 200 II = 1, MML
  5761.             I = M - II
  5762.             F = S * RV1(I)
  5763.             B = C * RV1(I)
  5764.             R = PYTHAG(F,G)
  5765.             RV1(I+1) = R
  5766.             IF (R .EQ. 0.0D0) GO TO 210
  5767.             S = F / R
  5768.             C = G / R
  5769.             G = W(I+1) - P
  5770.             R = (W(I) - G) * S + 2.0D0 * C * B
  5771.             P = S * R
  5772.             W(I+1) = G + P
  5773.             G = C * R - B
  5774.   200    CONTINUE
  5775. C
  5776.          W(L) = W(L) - P
  5777.          RV1(L) = G
  5778.          RV1(M) = 0.0D0
  5779.          GO TO 105
  5780. C     .......... RECOVER FROM UNDERFLOW ..........
  5781.   210    W(I+1) = W(I+1) - P
  5782.          RV1(M) = 0.0D0
  5783.          GO TO 105
  5784. C     .......... ORDER EIGENVALUES ..........
  5785.   215    IF (L .EQ. 1) GO TO 250
  5786. C     .......... FOR I=L STEP -1 UNTIL 2 DO -- ..........
  5787.          DO 230 II = 2, L
  5788.             I = L + 2 - II
  5789.             IF (P .GE. W(I-1)) GO TO 270
  5790.             W(I) = W(I-1)
  5791.             IND(I) = IND(I-1)
  5792.   230    CONTINUE
  5793. C
  5794.   250    I = 1
  5795.   270    W(I) = P
  5796.          IND(I) = TAG
  5797.   290 CONTINUE
  5798. C
  5799.       GO TO 1001
  5800. C     .......... SET ERROR -- NO CONVERGENCE TO AN
  5801. C                EIGENVALUE AFTER 30 ITERATIONS ..........
  5802.  1000 IERR = L
  5803.  1001 RETURN
  5804.       END
  5805.       SUBROUTINE INVIT(NM,N,A,WR,WI,SELECT,MM,M,Z,IERR,RM1,RV1,RV2)
  5806. C
  5807.       INTEGER I,J,K,L,M,N,S,II,IP,MM,MP,NM,NS,N1,UK,IP1,ITS,KM1,IERR
  5808.       DOUBLE PRECISION A(NM,N),WR(N),WI(N),Z(NM,MM),RM1(N,N),
  5809.      X       RV1(N),RV2(N)
  5810.       DOUBLE PRECISION T,W,X,Y,EPS3,NORM,NORMV,EPSLON,GROWTO,ILAMBD,
  5811.      X       PYTHAG,RLAMBD,UKROOT
  5812.       LOGICAL SELECT(N)
  5813. C
  5814. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE INVIT
  5815. C     BY PETERS AND WILKINSON.
  5816. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971).
  5817. C
  5818. C     THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A REAL UPPER
  5819. C     HESSENBERG MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES,
  5820. C     USING INVERSE ITERATION.
  5821. C
  5822. C     ON INPUT
  5823. C
  5824. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  5825. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  5826. C          DIMENSION STATEMENT.
  5827. C
  5828. C        N IS THE ORDER OF THE MATRIX.
  5829. C
  5830. C        A CONTAINS THE HESSENBERG MATRIX.
  5831. C
  5832. C        WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, RESPECTIVELY,
  5833. C          OF THE EIGENVALUES OF THE MATRIX.  THE EIGENVALUES MUST BE
  5834. C          STORED IN A MANNER IDENTICAL TO THAT OF SUBROUTINE  HQR,
  5835. C          WHICH RECOGNIZES POSSIBLE SPLITTING OF THE MATRIX.
  5836. C
  5837. C        SELECT SPECIFIES THE EIGENVECTORS TO BE FOUND. THE
  5838. C          EIGENVECTOR CORRESPONDING TO THE J-TH EIGENVALUE IS
  5839. C          SPECIFIED BY SETTING SELECT(J) TO .TRUE..
  5840. C
  5841. C        MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF
  5842. C          COLUMNS REQUIRED TO STORE THE EIGENVECTORS TO BE FOUND.
  5843. C          NOTE THAT TWO COLUMNS ARE REQUIRED TO STORE THE
  5844. C          EIGENVECTOR CORRESPONDING TO A COMPLEX EIGENVALUE.
  5845. C
  5846. C     ON OUTPUT
  5847. C
  5848. C        A AND WI ARE UNALTERED.
  5849. C
  5850. C        WR MAY HAVE BEEN ALTERED SINCE CLOSE EIGENVALUES ARE PERTURBED
  5851. C          SLIGHTLY IN SEARCHING FOR INDEPENDENT EIGENVECTORS.
  5852. C
  5853. C        SELECT MAY HAVE BEEN ALTERED.  IF THE ELEMENTS CORRESPONDING
  5854. C          TO A PAIR OF CONJUGATE COMPLEX EIGENVALUES WERE EACH
  5855. C          INITIALLY SET TO .TRUE., THE PROGRAM RESETS THE SECOND OF
  5856. C          THE TWO ELEMENTS TO .FALSE..
  5857. C
  5858. C        M IS THE NUMBER OF COLUMNS ACTUALLY USED TO STORE
  5859. C          THE EIGENVECTORS.
  5860. C
  5861. C        Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS.
  5862. C          IF THE NEXT SELECTED EIGENVALUE IS REAL, THE NEXT COLUMN
  5863. C          OF Z CONTAINS ITS EIGENVECTOR.  IF THE EIGENVALUE IS
  5864. C          COMPLEX, THE NEXT TWO COLUMNS OF Z CONTAIN THE REAL AND
  5865. C          IMAGINARY PARTS OF ITS EIGENVECTOR.  THE EIGENVECTORS ARE
  5866. C          NORMALIZED SO THAT THE COMPONENT OF LARGEST MAGNITUDE IS 1.
  5867. C          ANY VECTOR WHICH FAILS THE ACCEPTANCE TEST IS SET TO ZERO.
  5868. C
  5869. C        IERR IS SET TO
  5870. C          ZERO       FOR NORMAL RETURN,
  5871. C          -(2*N+1)   IF MORE THAN MM COLUMNS OF Z ARE NECESSARY
  5872. C                     TO STORE THE EIGENVECTORS CORRESPONDING TO
  5873. C                     THE SPECIFIED EIGENVALUES.
  5874. C          -K         IF THE ITERATION CORRESPONDING TO THE K-TH
  5875. C                     VALUE FAILS,
  5876. C          -(N+K)     IF BOTH ERROR SITUATIONS OCCUR.
  5877. C
  5878. C        RM1, RV1, AND RV2 ARE TEMPORARY STORAGE ARRAYS.  NOTE THAT RM1
  5879. C          IS SQUARE OF DIMENSION N BY N AND, AUGMENTED BY TWO COLUMNS
  5880. C          OF Z, IS THE TRANSPOSE OF THE CORRESPONDING ALGOL B ARRAY.
  5881. C
  5882. C     THE ALGOL PROCEDURE GUESSVEC APPEARS IN INVIT IN LINE.
  5883. C
  5884. C     CALLS CDIV FOR COMPLEX DIVISION.
  5885. C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
  5886. C
  5887. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  5888. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  5889. C
  5890. C     THIS VERSION DATED AUGUST 1983.
  5891. C
  5892. C     ------------------------------------------------------------------
  5893. C
  5894.       IERR = 0
  5895.       UK = 0
  5896.       S = 1
  5897. C     .......... IP = 0, REAL EIGENVALUE
  5898. C                     1, FIRST OF CONJUGATE COMPLEX PAIR
  5899. C                    -1, SECOND OF CONJUGATE COMPLEX PAIR ..........
  5900.       IP = 0
  5901.       N1 = N - 1
  5902. C
  5903.       DO 980 K = 1, N
  5904.          IF (WI(K) .EQ. 0.0D0 .OR. IP .LT. 0) GO TO 100
  5905.          IP = 1
  5906.          IF (SELECT(K) .AND. SELECT(K+1)) SELECT(K+1) = .FALSE.
  5907.   100    IF (.NOT. SELECT(K)) GO TO 960
  5908.          IF (WI(K) .NE. 0.0D0) S = S + 1
  5909.          IF (S .GT. MM) GO TO 1000
  5910.          IF (UK .GE. K) GO TO 200
  5911. C     .......... CHECK FOR POSSIBLE SPLITTING ..........
  5912.          DO 120 UK = K, N
  5913.             IF (UK .EQ. N) GO TO 140
  5914.             IF (A(UK+1,UK) .EQ. 0.0D0) GO TO 140
  5915.   120    CONTINUE
  5916. C     .......... COMPUTE INFINITY NORM OF LEADING UK BY UK
  5917. C                (HESSENBERG) MATRIX ..........
  5918.   140    NORM = 0.0D0
  5919.          MP = 1
  5920. C
  5921.          DO 180 I = 1, UK
  5922.             X = 0.0D0
  5923. C
  5924.             DO 160 J = MP, UK
  5925.   160       X = X + DABS(A(I,J))
  5926. C
  5927.             IF (X .GT. NORM) NORM = X
  5928.             MP = I
  5929.   180    CONTINUE
  5930. C     .......... EPS3 REPLACES ZERO PIVOT IN DECOMPOSITION
  5931. C                AND CLOSE ROOTS ARE MODIFIED BY EPS3 ..........
  5932.          IF (NORM .EQ. 0.0D0) NORM = 1.0D0
  5933.          EPS3 = EPSLON(NORM)
  5934. C     .......... GROWTO IS THE CRITERION FOR THE GROWTH ..........
  5935.          UKROOT = UK
  5936.          UKROOT = DSQRT(UKROOT)
  5937.          GROWTO = 0.1D0 / UKROOT
  5938.   200    RLAMBD = WR(K)
  5939.          ILAMBD = WI(K)
  5940.          IF (K .EQ. 1) GO TO 280
  5941.          KM1 = K - 1
  5942.          GO TO 240
  5943. C     .......... PERTURB EIGENVALUE IF IT IS CLOSE
  5944. C                TO ANY PREVIOUS EIGENVALUE ..........
  5945.   220    RLAMBD = RLAMBD + EPS3
  5946. C     .......... FOR I=K-1 STEP -1 UNTIL 1 DO -- ..........
  5947.   240    DO 260 II = 1, KM1
  5948.             I = K - II
  5949.             IF (SELECT(I) .AND. DABS(WR(I)-RLAMBD) .LT. EPS3 .AND.
  5950.      X         DABS(WI(I)-ILAMBD) .LT. EPS3) GO TO 220
  5951.   260    CONTINUE
  5952. C
  5953.          WR(K) = RLAMBD
  5954. C     .......... PERTURB CONJUGATE EIGENVALUE TO MATCH ..........
  5955.          IP1 = K + IP
  5956.          WR(IP1) = RLAMBD
  5957. C     .......... FORM UPPER HESSENBERG A-RLAMBD*I (TRANSPOSED)
  5958. C                AND INITIAL REAL VECTOR ..........
  5959.   280    MP = 1
  5960. C
  5961.          DO 320 I = 1, UK
  5962. C
  5963.             DO 300 J = MP, UK
  5964.   300       RM1(J,I) = A(I,J)
  5965. C
  5966.             RM1(I,I) = RM1(I,I) - RLAMBD
  5967.             MP = I
  5968.             RV1(I) = EPS3
  5969.   320    CONTINUE
  5970. C
  5971.          ITS = 0
  5972.          IF (ILAMBD .NE. 0.0D0) GO TO 520
  5973. C     .......... REAL EIGENVALUE.
  5974. C                TRIANGULAR DECOMPOSITION WITH INTERCHANGES,
  5975. C                REPLACING ZERO PIVOTS BY EPS3 ..........
  5976.          IF (UK .EQ. 1) GO TO 420
  5977. C
  5978.          DO 400 I = 2, UK
  5979.             MP = I - 1
  5980.             IF (DABS(RM1(MP,I)) .LE. DABS(RM1(MP,MP))) GO TO 360
  5981. C
  5982.             DO 340 J = MP, UK
  5983.                Y = RM1(J,I)
  5984.                RM1(J,I) = RM1(J,MP)
  5985.                RM1(J,MP) = Y
  5986.   340       CONTINUE
  5987. C
  5988.   360       IF (RM1(MP,MP) .EQ. 0.0D0) RM1(MP,MP) = EPS3
  5989.             X = RM1(MP,I) / RM1(MP,MP)
  5990.             IF (X .EQ. 0.0D0) GO TO 400
  5991. C
  5992.             DO 380 J = I, UK
  5993.   380       RM1(J,I) = RM1(J,I) - X * RM1(J,MP)
  5994. C
  5995.   400    CONTINUE
  5996. C
  5997.   420    IF (RM1(UK,UK) .EQ. 0.0D0) RM1(UK,UK) = EPS3
  5998. C     .......... BACK SUBSTITUTION FOR REAL VECTOR
  5999. C                FOR I=UK STEP -1 UNTIL 1 DO -- ..........
  6000.   440    DO 500 II = 1, UK
  6001.             I = UK + 1 - II
  6002.             Y = RV1(I)
  6003.             IF (I .EQ. UK) GO TO 480
  6004.             IP1 = I + 1
  6005. C
  6006.             DO 460 J = IP1, UK
  6007.   460       Y = Y - RM1(J,I) * RV1(J)
  6008. C
  6009.   480       RV1(I) = Y / RM1(I,I)
  6010.   500    CONTINUE
  6011. C
  6012.          GO TO 740
  6013. C     .......... COMPLEX EIGENVALUE.
  6014. C                TRIANGULAR DECOMPOSITION WITH INTERCHANGES,
  6015. C                REPLACING ZERO PIVOTS BY EPS3.  STORE IMAGINARY
  6016. C                PARTS IN UPPER TRIANGLE STARTING AT (1,3) ..........
  6017.   520    NS = N - S
  6018.          Z(1,S-1) = -ILAMBD
  6019.          Z(1,S) = 0.0D0
  6020.          IF (N .EQ. 2) GO TO 550
  6021.          RM1(1,3) = -ILAMBD
  6022.          Z(1,S-1) = 0.0D0
  6023.          IF (N .EQ. 3) GO TO 550
  6024. C
  6025.          DO 540 I = 4, N
  6026.   540    RM1(1,I) = 0.0D0
  6027. C
  6028.   550    DO 640 I = 2, UK
  6029.             MP = I - 1
  6030.             W = RM1(MP,I)
  6031.             IF (I .LT. N) T = RM1(MP,I+1)
  6032.             IF (I .EQ. N) T = Z(MP,S-1)
  6033.             X = RM1(MP,MP) * RM1(MP,MP) + T * T
  6034.             IF (W * W .LE. X) GO TO 580
  6035.             X = RM1(MP,MP) / W
  6036.             Y = T / W
  6037.             RM1(MP,MP) = W
  6038.             IF (I .LT. N) RM1(MP,I+1) = 0.0D0
  6039.             IF (I .EQ. N) Z(MP,S-1) = 0.0D0
  6040. C
  6041.             DO 560 J = I, UK
  6042.                W = RM1(J,I)
  6043.                RM1(J,I) = RM1(J,MP) - X * W
  6044.                RM1(J,MP) = W
  6045.                IF (J .LT. N1) GO TO 555
  6046.                L = J - NS
  6047.                Z(I,L) = Z(MP,L) - Y * W
  6048.                Z(MP,L) = 0.0D0
  6049.                GO TO 560
  6050.   555          RM1(I,J+2) = RM1(MP,J+2) - Y * W
  6051.                RM1(MP,J+2) = 0.0D0
  6052.   560       CONTINUE
  6053. C
  6054.             RM1(I,I) = RM1(I,I) - Y * ILAMBD
  6055.             IF (I .LT. N1) GO TO 570
  6056.             L = I - NS
  6057.             Z(MP,L) = -ILAMBD
  6058.             Z(I,L) = Z(I,L) + X * ILAMBD
  6059.             GO TO 640
  6060.   570       RM1(MP,I+2) = -ILAMBD
  6061.             RM1(I,I+2) = RM1(I,I+2) + X * ILAMBD
  6062.             GO TO 640
  6063.   580       IF (X .NE. 0.0D0) GO TO 600
  6064.             RM1(MP,MP) = EPS3
  6065.             IF (I .LT. N) RM1(MP,I+1) = 0.0D0
  6066.             IF (I .EQ. N) Z(MP,S-1) = 0.0D0
  6067.             T = 0.0D0
  6068.             X = EPS3 * EPS3
  6069.   600       W = W / X
  6070.             X = RM1(MP,MP) * W
  6071.             Y = -T * W
  6072. C
  6073.             DO 620 J = I, UK
  6074.                IF (J .LT. N1) GO TO 610
  6075.                L = J - NS
  6076.                T = Z(MP,L)
  6077.                Z(I,L) = -X * T - Y * RM1(J,MP)
  6078.                GO TO 615
  6079.   610          T = RM1(MP,J+2)
  6080.                RM1(I,J+2) = -X * T - Y * RM1(J,MP)
  6081.   615          RM1(J,I) = RM1(J,I) - X * RM1(J,MP) + Y * T
  6082.   620       CONTINUE
  6083. C
  6084.             IF (I .LT. N1) GO TO 630
  6085.             L = I - NS
  6086.             Z(I,L) = Z(I,L) - ILAMBD
  6087.             GO TO 640
  6088.   630       RM1(I,I+2) = RM1(I,I+2) - ILAMBD
  6089.   640    CONTINUE
  6090. C
  6091.          IF (UK .LT. N1) GO TO 650
  6092.          L = UK - NS
  6093.          T = Z(UK,L)
  6094.          GO TO 655
  6095.   650    T = RM1(UK,UK+2)
  6096.   655    IF (RM1(UK,UK) .EQ. 0.0D0 .AND. T .EQ. 0.0D0) RM1(UK,UK) = EPS3
  6097. C     .......... BACK SUBSTITUTION FOR COMPLEX VECTOR
  6098. C                FOR I=UK STEP -1 UNTIL 1 DO -- ..........
  6099.   660    DO 720 II = 1, UK
  6100.             I = UK + 1 - II
  6101.             X = RV1(I)
  6102.             Y = 0.0D0
  6103.             IF (I .EQ. UK) GO TO 700
  6104.             IP1 = I + 1
  6105. C
  6106.             DO 680 J = IP1, UK
  6107.                IF (J .LT. N1) GO TO 670
  6108.                L = J - NS
  6109.                T = Z(I,L)
  6110.                GO TO 675
  6111.   670          T = RM1(I,J+2)
  6112.   675          X = X - RM1(J,I) * RV1(J) + T * RV2(J)
  6113.                Y = Y - RM1(J,I) * RV2(J) - T * RV1(J)
  6114.   680       CONTINUE
  6115. C
  6116.   700       IF (I .LT. N1) GO TO 710
  6117.             L = I - NS
  6118.             T = Z(I,L)
  6119.             GO TO 715
  6120.   710       T = RM1(I,I+2)
  6121.   715       CALL CDIV(X,Y,RM1(I,I),T,RV1(I),RV2(I))
  6122.   720    CONTINUE
  6123. C     .......... ACCEPTANCE TEST FOR REAL OR COMPLEX
  6124. C                EIGENVECTOR AND NORMALIZATION ..........
  6125.   740    ITS = ITS + 1
  6126.          NORM = 0.0D0
  6127.          NORMV = 0.0D0
  6128. C
  6129.          DO 780 I = 1, UK
  6130.             IF (ILAMBD .EQ. 0.0D0) X = DABS(RV1(I))
  6131.             IF (ILAMBD .NE. 0.0D0) X = PYTHAG(RV1(I),RV2(I))
  6132.             IF (NORMV .GE. X) GO TO 760
  6133.             NORMV = X
  6134.             J = I
  6135.   760       NORM = NORM + X
  6136.   780    CONTINUE
  6137. C
  6138.          IF (NORM .LT. GROWTO) GO TO 840
  6139. C     .......... ACCEPT VECTOR ..........
  6140.          X = RV1(J)
  6141.          IF (ILAMBD .EQ. 0.0D0) X = 1.0D0 / X
  6142.          IF (ILAMBD .NE. 0.0D0) Y = RV2(J)
  6143. C
  6144.          DO 820 I = 1, UK
  6145.             IF (ILAMBD .NE. 0.0D0) GO TO 800
  6146.             Z(I,S) = RV1(I) * X
  6147.             GO TO 820
  6148.   800       CALL CDIV(RV1(I),RV2(I),X,Y,Z(I,S-1),Z(I,S))
  6149.   820    CONTINUE
  6150. C
  6151.          IF (UK .EQ. N) GO TO 940
  6152.          J = UK + 1
  6153.          GO TO 900
  6154. C     .......... IN-LINE PROCEDURE FOR CHOOSING
  6155. C                A NEW STARTING VECTOR ..........
  6156.   840    IF (ITS .GE. UK) GO TO 880
  6157.          X = UKROOT
  6158.          Y = EPS3 / (X + 1.0D0)
  6159.          RV1(1) = EPS3
  6160. C
  6161.          DO 860 I = 2, UK
  6162.   860    RV1(I) = Y
  6163. C
  6164.          J = UK - ITS + 1
  6165.          RV1(J) = RV1(J) - EPS3 * X
  6166.          IF (ILAMBD .EQ. 0.0D0) GO TO 440
  6167.          GO TO 660
  6168. C     .......... SET ERROR -- UNACCEPTED EIGENVECTOR ..........
  6169.   880    J = 1
  6170.          IERR = -K
  6171. C     .......... SET REMAINING VECTOR COMPONENTS TO ZERO ..........
  6172.   900    DO 920 I = J, N
  6173.             Z(I,S) = 0.0D0
  6174.             IF (ILAMBD .NE. 0.0D0) Z(I,S-1) = 0.0D0
  6175.   920    CONTINUE
  6176. C
  6177.   940    S = S + 1
  6178.   960    IF (IP .EQ. (-1)) IP = 0
  6179.          IF (IP .EQ. 1) IP = -1
  6180.   980 CONTINUE
  6181. C
  6182.       GO TO 1001
  6183. C     .......... SET ERROR -- UNDERESTIMATE OF EIGENVECTOR
  6184. C                SPACE REQUIRED ..........
  6185.  1000 IF (IERR .NE. 0) IERR = IERR - N
  6186.       IF (IERR .EQ. 0) IERR = -(2 * N + 1)
  6187.  1001 M = S - 1 - IABS(IP)
  6188.       RETURN
  6189.       END
  6190.       SUBROUTINE MINFIT(NM,M,N,A,W,IP,B,IERR,RV1)
  6191. C
  6192.       INTEGER I,J,K,L,M,N,II,IP,I1,KK,K1,LL,L1,M1,NM,ITS,IERR
  6193.       DOUBLE PRECISION A(NM,N),W(N),B(NM,IP),RV1(N)
  6194.       DOUBLE PRECISION C,F,G,H,S,X,Y,Z,TST1,TST2,SCALE,PYTHAG
  6195. C
  6196. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE MINFIT,
  6197. C     NUM. MATH. 14, 403-420(1970) BY GOLUB AND REINSCH.
  6198. C     HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 134-151(1971).
  6199. C
  6200. C     THIS SUBROUTINE DETERMINES, TOWARDS THE SOLUTION OF THE LINEAR
  6201. C                                                        T
  6202. C     SYSTEM AX=B, THE SINGULAR VALUE DECOMPOSITION A=USV  OF A REAL
  6203. C                                         T
  6204. C     M BY N RECTANGULAR MATRIX, FORMING U B RATHER THAN U.  HOUSEHOLDER
  6205. C     BIDIAGONALIZATION AND A VARIANT OF THE QR ALGORITHM ARE USED.
  6206. C
  6207. C     ON INPUT
  6208. C
  6209. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  6210. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  6211. C          DIMENSION STATEMENT.  NOTE THAT NM MUST BE AT LEAST
  6212. C          AS LARGE AS THE MAXIMUM OF M AND N.
  6213. C
  6214. C        M IS THE NUMBER OF ROWS OF A AND B.
  6215. C
  6216. C        N IS THE NUMBER OF COLUMNS OF A AND THE ORDER OF V.
  6217. C
  6218. C        A CONTAINS THE RECTANGULAR COEFFICIENT MATRIX OF THE SYSTEM.
  6219. C
  6220. C        IP IS THE NUMBER OF COLUMNS OF B.  IP CAN BE ZERO.
  6221. C
  6222. C        B CONTAINS THE CONSTANT COLUMN MATRIX OF THE SYSTEM
  6223. C          IF IP IS NOT ZERO.  OTHERWISE B IS NOT REFERENCED.
  6224. C
  6225. C     ON OUTPUT
  6226. C
  6227. C        A HAS BEEN OVERWRITTEN BY THE MATRIX V (ORTHOGONAL) OF THE
  6228. C          DECOMPOSITION IN ITS FIRST N ROWS AND COLUMNS.  IF AN
  6229. C          ERROR EXIT IS MADE, THE COLUMNS OF V CORRESPONDING TO
  6230. C          INDICES OF CORRECT SINGULAR VALUES SHOULD BE CORRECT.
  6231. C
  6232. C        W CONTAINS THE N (NON-NEGATIVE) SINGULAR VALUES OF A (THE
  6233. C          DIAGONAL ELEMENTS OF S).  THEY ARE UNORDERED.  IF AN
  6234. C          ERROR EXIT IS MADE, THE SINGULAR VALUES SHOULD BE CORRECT
  6235. C          FOR INDICES IERR+1,IERR+2,...,N.
  6236. C
  6237. C                                   T
  6238. C        B HAS BEEN OVERWRITTEN BY U B.  IF AN ERROR EXIT IS MADE,
  6239. C                       T
  6240. C          THE ROWS OF U B CORRESPONDING TO INDICES OF CORRECT
  6241. C          SINGULAR VALUES SHOULD BE CORRECT.
  6242. C
  6243. C        IERR IS SET TO
  6244. C          ZERO       FOR NORMAL RETURN,
  6245. C          K          IF THE K-TH SINGULAR VALUE HAS NOT BEEN
  6246. C                     DETERMINED AFTER 30 ITERATIONS.
  6247. C
  6248. C        RV1 IS A TEMPORARY STORAGE ARRAY.
  6249. C
  6250. C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
  6251. C
  6252. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  6253. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  6254. C
  6255. C     THIS VERSION DATED AUGUST 1983.
  6256. C
  6257. C     ------------------------------------------------------------------
  6258. C
  6259.       IERR = 0
  6260. C     .......... HOUSEHOLDER REDUCTION TO BIDIAGONAL FORM ..........
  6261.       G = 0.0D0
  6262.       SCALE = 0.0D0
  6263.       X = 0.0D0
  6264. C
  6265.       DO 300 I = 1, N
  6266.          L = I + 1
  6267.          RV1(I) = SCALE * G
  6268.          G = 0.0D0
  6269.          S = 0.0D0
  6270.          SCALE = 0.0D0
  6271.          IF (I .GT. M) GO TO 210
  6272. C
  6273.          DO 120 K = I, M
  6274.   120    SCALE = SCALE + DABS(A(K,I))
  6275. C
  6276.          IF (SCALE .EQ. 0.0D0) GO TO 210
  6277. C
  6278.          DO 130 K = I, M
  6279.             A(K,I) = A(K,I) / SCALE
  6280.             S = S + A(K,I)**2
  6281.   130    CONTINUE
  6282. C
  6283.          F = A(I,I)
  6284.          G = -DSIGN(DSQRT(S),F)
  6285.          H = F * G - S
  6286.          A(I,I) = F - G
  6287.          IF (I .EQ. N) GO TO 160
  6288. C
  6289.          DO 150 J = L, N
  6290.             S = 0.0D0
  6291. C
  6292.             DO 140 K = I, M
  6293.   140       S = S + A(K,I) * A(K,J)
  6294. C
  6295.             F = S / H
  6296. C
  6297.             DO 150 K = I, M
  6298.                A(K,J) = A(K,J) + F * A(K,I)
  6299.   150    CONTINUE
  6300. C
  6301.   160    IF (IP .EQ. 0) GO TO 190
  6302. C
  6303.          DO 180 J = 1, IP
  6304.             S = 0.0D0
  6305. C
  6306.             DO 170 K = I, M
  6307.   170       S = S + A(K,I) * B(K,J)
  6308. C
  6309.             F = S / H
  6310. C
  6311.             DO 180 K = I, M
  6312.                B(K,J) = B(K,J) + F * A(K,I)
  6313.   180    CONTINUE
  6314. C
  6315.   190    DO 200 K = I, M
  6316.   200    A(K,I) = SCALE * A(K,I)
  6317. C
  6318.   210    W(I) = SCALE * G
  6319.          G = 0.0D0
  6320.          S = 0.0D0
  6321.          SCALE = 0.0D0
  6322.          IF (I .GT. M .OR. I .EQ. N) GO TO 290
  6323. C
  6324.          DO 220 K = L, N
  6325.   220    SCALE = SCALE + DABS(A(I,K))
  6326. C
  6327.          IF (SCALE .EQ. 0.0D0) GO TO 290
  6328. C
  6329.          DO 230 K = L, N
  6330.             A(I,K) = A(I,K) / SCALE
  6331.             S = S + A(I,K)**2
  6332.   230    CONTINUE
  6333. C
  6334.          F = A(I,L)
  6335.          G = -DSIGN(DSQRT(S),F)
  6336.          H = F * G - S
  6337.          A(I,L) = F - G
  6338. C
  6339.          DO 240 K = L, N
  6340.   240    RV1(K) = A(I,K) / H
  6341. C
  6342.          IF (I .EQ. M) GO TO 270
  6343. C
  6344.          DO 260 J = L, M
  6345.             S = 0.0D0
  6346. C
  6347.             DO 250 K = L, N
  6348.   250       S = S + A(J,K) * A(I,K)
  6349. C
  6350.             DO 260 K = L, N
  6351.                A(J,K) = A(J,K) + S * RV1(K)
  6352.   260    CONTINUE
  6353. C
  6354.   270    DO 280 K = L, N
  6355.   280    A(I,K) = SCALE * A(I,K)
  6356. C
  6357.   290    X = DMAX1(X,DABS(W(I))+DABS(RV1(I)))
  6358.   300 CONTINUE
  6359. C     .......... ACCUMULATION OF RIGHT-HAND TRANSFORMATIONS.
  6360. C                FOR I=N STEP -1 UNTIL 1 DO -- ..........
  6361.       DO 400 II = 1, N
  6362.          I = N + 1 - II
  6363.          IF (I .EQ. N) GO TO 390
  6364.          IF (G .EQ. 0.0D0) GO TO 360
  6365. C
  6366.          DO 320 J = L, N
  6367. C     .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ..........
  6368.   320    A(J,I) = (A(I,J) / A(I,L)) / G
  6369. C
  6370.          DO 350 J = L, N
  6371.             S = 0.0D0
  6372. C
  6373.             DO 340 K = L, N
  6374.   340       S = S + A(I,K) * A(K,J)
  6375. C
  6376.             DO 350 K = L, N
  6377.                A(K,J) = A(K,J) + S * A(K,I)
  6378.   350    CONTINUE
  6379. C
  6380.   360    DO 380 J = L, N
  6381.             A(I,J) = 0.0D0
  6382.             A(J,I) = 0.0D0
  6383.   380    CONTINUE
  6384. C
  6385.   390    A(I,I) = 1.0D0
  6386.          G = RV1(I)
  6387.          L = I
  6388.   400 CONTINUE
  6389. C
  6390.       IF (M .GE. N .OR. IP .EQ. 0) GO TO 510
  6391.       M1 = M + 1
  6392. C
  6393.       DO 500 I = M1, N
  6394. C
  6395.          DO 500 J = 1, IP
  6396.             B(I,J) = 0.0D0
  6397.   500 CONTINUE
  6398. C     .......... DIAGONALIZATION OF THE BIDIAGONAL FORM ..........
  6399.   510 TST1 = X
  6400. C     .......... FOR K=N STEP -1 UNTIL 1 DO -- ..........
  6401.       DO 700 KK = 1, N
  6402.          K1 = N - KK
  6403.          K = K1 + 1
  6404.          ITS = 0
  6405. C     .......... TEST FOR SPLITTING.
  6406. C                FOR L=K STEP -1 UNTIL 1 DO -- ..........
  6407.   520    DO 530 LL = 1, K
  6408.             L1 = K - LL
  6409.             L = L1 + 1
  6410.             TST2 = TST1 + DABS(RV1(L))
  6411.             IF (TST2 .EQ. TST1) GO TO 565
  6412. C     .......... RV1(1) IS ALWAYS ZERO, SO THERE IS NO EXIT
  6413. C                THROUGH THE BOTTOM OF THE LOOP ..........
  6414.             TST2 = TST1 + DABS(W(L1))
  6415.             IF (TST2 .EQ. TST1) GO TO 540
  6416.   530    CONTINUE
  6417. C     .......... CANCELLATION OF RV1(L) IF L GREATER THAN 1 ..........
  6418.   540    C = 0.0D0
  6419.          S = 1.0D0
  6420. C
  6421.          DO 560 I = L, K
  6422.             F = S * RV1(I)
  6423.             RV1(I) = C * RV1(I)
  6424.             TST2 = TST1 + DABS(F)
  6425.             IF (TST2 .EQ. TST1) GO TO 565
  6426.             G = W(I)
  6427.             H = PYTHAG(F,G)
  6428.             W(I) = H
  6429.             C = G / H
  6430.             S = -F / H
  6431.             IF (IP .EQ. 0) GO TO 560
  6432. C
  6433.             DO 550 J = 1, IP
  6434.                Y = B(L1,J)
  6435.                Z = B(I,J)
  6436.                B(L1,J) = Y * C + Z * S
  6437.                B(I,J) = -Y * S + Z * C
  6438.   550       CONTINUE
  6439. C
  6440.   560    CONTINUE
  6441. C     .......... TEST FOR CONVERGENCE ..........
  6442.   565    Z = W(K)
  6443.          IF (L .EQ. K) GO TO 650
  6444. C     .......... SHIFT FROM BOTTOM 2 BY 2 MINOR ..........
  6445.          IF (ITS .EQ. 30) GO TO 1000
  6446.          ITS = ITS + 1
  6447.          X = W(L)
  6448.          Y = W(K1)
  6449.          G = RV1(K1)
  6450.          H = RV1(K)
  6451.          F = 0.5D0 * (((G + Z) / H) * ((G - Z) / Y) + Y / H - H / Y)
  6452.          G = PYTHAG(F,1.0D0)
  6453.          F = X - (Z / X) * Z + (H / X) * (Y / (F + DSIGN(G,F)) - H)
  6454. C     .......... NEXT QR TRANSFORMATION ..........
  6455.          C = 1.0D0
  6456.          S = 1.0D0
  6457. C
  6458.          DO 600 I1 = L, K1
  6459.             I = I1 + 1
  6460.             G = RV1(I)
  6461.             Y = W(I)
  6462.             H = S * G
  6463.             G = C * G
  6464.             Z = PYTHAG(F,H)
  6465.             RV1(I1) = Z
  6466.             C = F / Z
  6467.             S = H / Z
  6468.             F = X * C + G * S
  6469.             G = -X * S + G * C
  6470.             H = Y * S
  6471.             Y = Y * C
  6472. C
  6473.             DO 570 J = 1, N
  6474.                X = A(J,I1)
  6475.                Z = A(J,I)
  6476.                A(J,I1) = X * C + Z * S
  6477.                A(J,I) = -X * S + Z * C
  6478.   570       CONTINUE
  6479. C
  6480.             Z = PYTHAG(F,H)
  6481.             W(I1) = Z
  6482. C     .......... ROTATION CAN BE ARBITRARY IF Z IS ZERO ..........
  6483.             IF (Z .EQ. 0.0D0) GO TO 580
  6484.             C = F / Z
  6485.             S = H / Z
  6486.   580       F = C * G + S * Y
  6487.             X = -S * G + C * Y
  6488.             IF (IP .EQ. 0) GO TO 600
  6489. C
  6490.             DO 590 J = 1, IP
  6491.                Y = B(I1,J)
  6492.                Z = B(I,J)
  6493.                B(I1,J) = Y * C + Z * S
  6494.                B(I,J) = -Y * S + Z * C
  6495.   590       CONTINUE
  6496. C
  6497.   600    CONTINUE
  6498. C
  6499.          RV1(L) = 0.0D0
  6500.          RV1(K) = F
  6501.          W(K) = X
  6502.          GO TO 520
  6503. C     .......... CONVERGENCE ..........
  6504.   650    IF (Z .GE. 0.0D0) GO TO 700
  6505. C     .......... W(K) IS MADE NON-NEGATIVE ..........
  6506.          W(K) = -Z
  6507. C
  6508.          DO 690 J = 1, N
  6509.   690    A(J,K) = -A(J,K)
  6510. C
  6511.   700 CONTINUE
  6512. C
  6513.       GO TO 1001
  6514. C     .......... SET ERROR -- NO CONVERGENCE TO A
  6515. C                SINGULAR VALUE AFTER 30 ITERATIONS ..........
  6516.  1000 IERR = K
  6517.  1001 RETURN
  6518.       END
  6519.       SUBROUTINE ORTBAK(NM,LOW,IGH,A,ORT,M,Z)
  6520. C
  6521.       INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1
  6522.       DOUBLE PRECISION A(NM,IGH),ORT(IGH),Z(NM,M)
  6523.       DOUBLE PRECISION G
  6524. C
  6525. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTBAK,
  6526. C     NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON.
  6527. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
  6528. C
  6529. C     THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL GENERAL
  6530. C     MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
  6531. C     UPPER HESSENBERG MATRIX DETERMINED BY  ORTHES.
  6532. C
  6533. C     ON INPUT
  6534. C
  6535. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  6536. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  6537. C          DIMENSION STATEMENT.
  6538. C
  6539. C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
  6540. C          SUBROUTINE  BALANC.  IF  BALANC  HAS NOT BEEN USED,
  6541. C          SET LOW=1 AND IGH EQUAL TO THE ORDER OF THE MATRIX.
  6542. C
  6543. C        A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS-
  6544. C          FORMATIONS USED IN THE REDUCTION BY  ORTHES
  6545. C          IN ITS STRICT LOWER TRIANGLE.
  6546. C
  6547. C        ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANS-
  6548. C          FORMATIONS USED IN THE REDUCTION BY  ORTHES.
  6549. C          ONLY ELEMENTS LOW THROUGH IGH ARE USED.
  6550. C
  6551. C        M IS THE NUMBER OF COLUMNS OF Z TO BE BACK TRANSFORMED.
  6552. C
  6553. C        Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGEN-
  6554. C          VECTORS TO BE BACK TRANSFORMED IN ITS FIRST M COLUMNS.
  6555. C
  6556. C     ON OUTPUT
  6557. C
  6558. C        Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE
  6559. C          TRANSFORMED EIGENVECTORS IN ITS FIRST M COLUMNS.
  6560. C
  6561. C        ORT HAS BEEN ALTERED.
  6562. C
  6563. C     NOTE THAT ORTBAK PRESERVES VECTOR EUCLIDEAN NORMS.
  6564. C
  6565. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  6566. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  6567. C
  6568. C     THIS VERSION DATED AUGUST 1983.
  6569. C
  6570. C     ------------------------------------------------------------------
  6571. C
  6572.       IF (M .EQ. 0) GO TO 200
  6573.       LA = IGH - 1
  6574.       KP1 = LOW + 1
  6575.       IF (LA .LT. KP1) GO TO 200
  6576. C     .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
  6577.       DO 140 MM = KP1, LA
  6578.          MP = LOW + IGH - MM
  6579.          IF (A(MP,MP-1) .EQ. 0.0D0) GO TO 140
  6580.          MP1 = MP + 1
  6581. C
  6582.          DO 100 I = MP1, IGH
  6583.   100    ORT(I) = A(I,MP-1)
  6584. C
  6585.          DO 130 J = 1, M
  6586.             G = 0.0D0
  6587. C
  6588.             DO 110 I = MP, IGH
  6589.   110       G = G + ORT(I) * Z(I,J)
  6590. C     .......... DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHES.
  6591. C                DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ..........
  6592.             G = (G / ORT(MP)) / A(MP,MP-1)
  6593. C
  6594.             DO 120 I = MP, IGH
  6595.   120       Z(I,J) = Z(I,J) + G * ORT(I)
  6596. C
  6597.   130    CONTINUE
  6598. C
  6599.   140 CONTINUE
  6600. C
  6601.   200 RETURN
  6602.       END
  6603.       SUBROUTINE ORTHES(NM,N,LOW,IGH,A,ORT)
  6604. C
  6605.       INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
  6606.       DOUBLE PRECISION A(NM,N),ORT(IGH)
  6607.       DOUBLE PRECISION F,G,H,SCALE
  6608. C
  6609. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTHES,
  6610. C     NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON.
  6611. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
  6612. C
  6613. C     GIVEN A REAL GENERAL MATRIX, THIS SUBROUTINE
  6614. C     REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
  6615. C     LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
  6616. C     ORTHOGONAL SIMILARITY TRANSFORMATIONS.
  6617. C
  6618. C     ON INPUT
  6619. C
  6620. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  6621. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  6622. C          DIMENSION STATEMENT.
  6623. C
  6624. C        N IS THE ORDER OF THE MATRIX.
  6625. C
  6626. C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
  6627. C          SUBROUTINE  BALANC.  IF  BALANC  HAS NOT BEEN USED,
  6628. C          SET LOW=1, IGH=N.
  6629. C
  6630. C        A CONTAINS THE INPUT MATRIX.
  6631. C
  6632. C     ON OUTPUT
  6633. C
  6634. C        A CONTAINS THE HESSENBERG MATRIX.  INFORMATION ABOUT
  6635. C          THE ORTHOGONAL TRANSFORMATIONS USED IN THE REDUCTION
  6636. C          IS STORED IN THE REMAINING TRIANGLE UNDER THE
  6637. C          HESSENBERG MATRIX.
  6638. C
  6639. C        ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS.
  6640. C          ONLY ELEMENTS LOW THROUGH IGH ARE USED.
  6641. C
  6642. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  6643. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  6644. C
  6645. C     THIS VERSION DATED AUGUST 1983.
  6646. C
  6647. C     ------------------------------------------------------------------
  6648. C
  6649.       LA = IGH - 1
  6650.       KP1 = LOW + 1
  6651.       IF (LA .LT. KP1) GO TO 200
  6652. C
  6653.       DO 180 M = KP1, LA
  6654.          H = 0.0D0
  6655.          ORT(M) = 0.0D0
  6656.          SCALE = 0.0D0
  6657. C     .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
  6658.          DO 90 I = M, IGH
  6659.    90    SCALE = SCALE + DABS(A(I,M-1))
  6660. C
  6661.          IF (SCALE .EQ. 0.0D0) GO TO 180
  6662.          MP = M + IGH
  6663. C     .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
  6664.          DO 100 II = M, IGH
  6665.             I = MP - II
  6666.             ORT(I) = A(I,M-1) / SCALE
  6667.             H = H + ORT(I) * ORT(I)
  6668.   100    CONTINUE
  6669. C
  6670.          G = -DSIGN(DSQRT(H),ORT(M))
  6671.          H = H - ORT(M) * G
  6672.          ORT(M) = ORT(M) - G
  6673. C     .......... FORM (I-(U*UT)/H) * A ..........
  6674.          DO 130 J = M, N
  6675.             F = 0.0D0
  6676. C     .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
  6677.             DO 110 II = M, IGH
  6678.                I = MP - II
  6679.                F = F + ORT(I) * A(I,J)
  6680.   110       CONTINUE
  6681. C
  6682.             F = F / H
  6683. C
  6684.             DO 120 I = M, IGH
  6685.   120       A(I,J) = A(I,J) - F * ORT(I)
  6686. C
  6687.   130    CONTINUE
  6688. C     .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
  6689.          DO 160 I = 1, IGH
  6690.             F = 0.0D0
  6691. C     .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
  6692.             DO 140 JJ = M, IGH
  6693.                J = MP - JJ
  6694.                F = F + ORT(J) * A(I,J)
  6695.   140       CONTINUE
  6696. C
  6697.             F = F / H
  6698. C
  6699.             DO 150 J = M, IGH
  6700.   150       A(I,J) = A(I,J) - F * ORT(J)
  6701. C
  6702.   160    CONTINUE
  6703. C
  6704.          ORT(M) = SCALE * ORT(M)
  6705.          A(M,M-1) = SCALE * G
  6706.   180 CONTINUE
  6707. C
  6708.   200 RETURN
  6709.       END
  6710.       SUBROUTINE ORTRAN(NM,N,LOW,IGH,A,ORT,Z)
  6711. C
  6712.       INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1
  6713.       DOUBLE PRECISION A(NM,IGH),ORT(IGH),Z(NM,N)
  6714.       DOUBLE PRECISION G
  6715. C
  6716. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTRANS,
  6717. C     NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON.
  6718. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
  6719. C
  6720. C     THIS SUBROUTINE ACCUMULATES THE ORTHOGONAL SIMILARITY
  6721. C     TRANSFORMATIONS USED IN THE REDUCTION OF A REAL GENERAL
  6722. C     MATRIX TO UPPER HESSENBERG FORM BY  ORTHES.
  6723. C
  6724. C     ON INPUT
  6725. C
  6726. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  6727. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  6728. C          DIMENSION STATEMENT.
  6729. C
  6730. C        N IS THE ORDER OF THE MATRIX.
  6731. C
  6732. C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
  6733. C          SUBROUTINE  BALANC.  IF  BALANC  HAS NOT BEEN USED,
  6734. C          SET LOW=1, IGH=N.
  6735. C
  6736. C        A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS-
  6737. C          FORMATIONS USED IN THE REDUCTION BY  ORTHES
  6738. C          IN ITS STRICT LOWER TRIANGLE.
  6739. C
  6740. C        ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANS-
  6741. C          FORMATIONS USED IN THE REDUCTION BY  ORTHES.
  6742. C          ONLY ELEMENTS LOW THROUGH IGH ARE USED.
  6743. C
  6744. C     ON OUTPUT
  6745. C
  6746. C        Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
  6747. C          REDUCTION BY  ORTHES.
  6748. C
  6749. C        ORT HAS BEEN ALTERED.
  6750. C
  6751. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  6752. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  6753. C
  6754. C     THIS VERSION DATED AUGUST 1983.
  6755. C
  6756. C     ------------------------------------------------------------------
  6757. C
  6758. C     .......... INITIALIZE Z TO IDENTITY MATRIX ..........
  6759.       DO 80 J = 1, N
  6760. C
  6761.          DO 60 I = 1, N
  6762.    60    Z(I,J) = 0.0D0
  6763. C
  6764.          Z(J,J) = 1.0D0
  6765.    80 CONTINUE
  6766. C
  6767.       KL = IGH - LOW - 1
  6768.       IF (KL .LT. 1) GO TO 200
  6769. C     .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
  6770.       DO 140 MM = 1, KL
  6771.          MP = IGH - MM
  6772.          IF (A(MP,MP-1) .EQ. 0.0D0) GO TO 140
  6773.          MP1 = MP + 1
  6774. C
  6775.          DO 100 I = MP1, IGH
  6776.   100    ORT(I) = A(I,MP-1)
  6777. C
  6778.          DO 130 J = MP, IGH
  6779.             G = 0.0D0
  6780. C
  6781.             DO 110 I = MP, IGH
  6782.   110       G = G + ORT(I) * Z(I,J)
  6783. C     .......... DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHES.
  6784. C                DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ..........
  6785.             G = (G / ORT(MP)) / A(MP,MP-1)
  6786. C
  6787.             DO 120 I = MP, IGH
  6788.   120       Z(I,J) = Z(I,J) + G * ORT(I)
  6789. C
  6790.   130    CONTINUE
  6791. C
  6792.   140 CONTINUE
  6793. C
  6794.   200 RETURN
  6795.       END
  6796.       SUBROUTINE QZHES(NM,N,A,B,MATZ,Z)
  6797. C
  6798.       INTEGER I,J,K,L,N,LB,L1,NM,NK1,NM1,NM2
  6799.       DOUBLE PRECISION A(NM,N),B(NM,N),Z(NM,N)
  6800.       DOUBLE PRECISION R,S,T,U1,U2,V1,V2,RHO
  6801.       LOGICAL MATZ
  6802. C
  6803. C     THIS SUBROUTINE IS THE FIRST STEP OF THE QZ ALGORITHM
  6804. C     FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS,
  6805. C     SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART.
  6806. C
  6807. C     THIS SUBROUTINE ACCEPTS A PAIR OF REAL GENERAL MATRICES AND
  6808. C     REDUCES ONE OF THEM TO UPPER HESSENBERG FORM AND THE OTHER
  6809. C     TO UPPER TRIANGULAR FORM USING ORTHOGONAL TRANSFORMATIONS.
  6810. C     IT IS USUALLY FOLLOWED BY  QZIT,  QZVAL  AND, POSSIBLY,  QZVEC.
  6811. C
  6812. C     ON INPUT
  6813. C
  6814. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  6815. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  6816. C          DIMENSION STATEMENT.
  6817. C
  6818. C        N IS THE ORDER OF THE MATRICES.
  6819. C
  6820. C        A CONTAINS A REAL GENERAL MATRIX.
  6821. C
  6822. C        B CONTAINS A REAL GENERAL MATRIX.
  6823. C
  6824. C        MATZ SHOULD BE SET TO .TRUE. IF THE RIGHT HAND TRANSFORMATIONS
  6825. C          ARE TO BE ACCUMULATED FOR LATER USE IN COMPUTING
  6826. C          EIGENVECTORS, AND TO .FALSE. OTHERWISE.
  6827. C
  6828. C     ON OUTPUT
  6829. C
  6830. C        A HAS BEEN REDUCED TO UPPER HESSENBERG FORM.  THE ELEMENTS
  6831. C          BELOW THE FIRST SUBDIAGONAL HAVE BEEN SET TO ZERO.
  6832. C
  6833. C        B HAS BEEN REDUCED TO UPPER TRIANGULAR FORM.  THE ELEMENTS
  6834. C          BELOW THE MAIN DIAGONAL HAVE BEEN SET TO ZERO.
  6835. C
  6836. C        Z CONTAINS THE PRODUCT OF THE RIGHT HAND TRANSFORMATIONS IF
  6837. C          MATZ HAS BEEN SET TO .TRUE.  OTHERWISE, Z IS NOT REFERENCED.
  6838. C
  6839. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  6840. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  6841. C
  6842. C     THIS VERSION DATED AUGUST 1983.
  6843. C
  6844. C     ------------------------------------------------------------------
  6845. C
  6846. C     .......... INITIALIZE Z ..........
  6847.       IF (.NOT. MATZ) GO TO 10
  6848. C
  6849.       DO 3 J = 1, N
  6850. C
  6851.          DO 2 I = 1, N
  6852.             Z(I,J) = 0.0D0
  6853.     2    CONTINUE
  6854. C
  6855.          Z(J,J) = 1.0D0
  6856.     3 CONTINUE
  6857. C     .......... REDUCE B TO UPPER TRIANGULAR FORM ..........
  6858.    10 IF (N .LE. 1) GO TO 170
  6859.       NM1 = N - 1
  6860. C
  6861.       DO 100 L = 1, NM1
  6862.          L1 = L + 1
  6863.          S = 0.0D0
  6864. C
  6865.          DO 20 I = L1, N
  6866.             S = S + DABS(B(I,L))
  6867.    20    CONTINUE
  6868. C
  6869.          IF (S .EQ. 0.0D0) GO TO 100
  6870.          S = S + DABS(B(L,L))
  6871.          R = 0.0D0
  6872. C
  6873.          DO 25 I = L, N
  6874.             B(I,L) = B(I,L) / S
  6875.             R = R + B(I,L)**2
  6876.    25    CONTINUE
  6877. C
  6878.          R = DSIGN(DSQRT(R),B(L,L))
  6879.          B(L,L) = B(L,L) + R
  6880.          RHO = R * B(L,L)
  6881. C
  6882.          DO 50 J = L1, N
  6883.             T = 0.0D0
  6884. C
  6885.             DO 30 I = L, N
  6886.                T = T + B(I,L) * B(I,J)
  6887.    30       CONTINUE
  6888. C
  6889.             T = -T / RHO
  6890. C
  6891.             DO 40 I = L, N
  6892.                B(I,J) = B(I,J) + T * B(I,L)
  6893.    40       CONTINUE
  6894. C
  6895.    50    CONTINUE
  6896. C
  6897.          DO 80 J = 1, N
  6898.             T = 0.0D0
  6899. C
  6900.             DO 60 I = L, N
  6901.                T = T + B(I,L) * A(I,J)
  6902.    60       CONTINUE
  6903. C
  6904.             T = -T / RHO
  6905. C
  6906.             DO 70 I = L, N
  6907.                A(I,J) = A(I,J) + T * B(I,L)
  6908.    70       CONTINUE
  6909. C
  6910.    80    CONTINUE
  6911. C
  6912.          B(L,L) = -S * R
  6913. C
  6914.          DO 90 I = L1, N
  6915.             B(I,L) = 0.0D0
  6916.    90    CONTINUE
  6917. C
  6918.   100 CONTINUE
  6919. C     .......... REDUCE A TO UPPER HESSENBERG FORM, WHILE
  6920. C                KEEPING B TRIANGULAR ..........
  6921.       IF (N .EQ. 2) GO TO 170
  6922.       NM2 = N - 2
  6923. C
  6924.       DO 160 K = 1, NM2
  6925.          NK1 = NM1 - K
  6926. C     .......... FOR L=N-1 STEP -1 UNTIL K+1 DO -- ..........
  6927.          DO 150 LB = 1, NK1
  6928.             L = N - LB
  6929.             L1 = L + 1
  6930. C     .......... ZERO A(L+1,K) ..........
  6931.             S = DABS(A(L,K)) + DABS(A(L1,K))
  6932.             IF (S .EQ. 0.0D0) GO TO 150
  6933.             U1 = A(L,K) / S
  6934.             U2 = A(L1,K) / S
  6935.             R = DSIGN(DSQRT(U1*U1+U2*U2),U1)
  6936.             V1 =  -(U1 + R) / R
  6937.             V2 = -U2 / R
  6938.             U2 = V2 / V1
  6939. C
  6940.             DO 110 J = K, N
  6941.                T = A(L,J) + U2 * A(L1,J)
  6942.                A(L,J) = A(L,J) + T * V1
  6943.                A(L1,J) = A(L1,J) + T * V2
  6944.   110       CONTINUE
  6945. C
  6946.             A(L1,K) = 0.0D0
  6947. C
  6948.             DO 120 J = L, N
  6949.                T = B(L,J) + U2 * B(L1,J)
  6950.                B(L,J) = B(L,J) + T * V1
  6951.                B(L1,J) = B(L1,J) + T * V2
  6952.   120       CONTINUE
  6953. C     .......... ZERO B(L+1,L) ..........
  6954.             S = DABS(B(L1,L1)) + DABS(B(L1,L))
  6955.             IF (S .EQ. 0.0D0) GO TO 150
  6956.             U1 = B(L1,L1) / S
  6957.             U2 = B(L1,L) / S
  6958.             R = DSIGN(DSQRT(U1*U1+U2*U2),U1)
  6959.             V1 =  -(U1 + R) / R
  6960.             V2 = -U2 / R
  6961.             U2 = V2 / V1
  6962. C
  6963.             DO 130 I = 1, L1
  6964.                T = B(I,L1) + U2 * B(I,L)
  6965.                B(I,L1) = B(I,L1) + T * V1
  6966.                B(I,L) = B(I,L) + T * V2
  6967.   130       CONTINUE
  6968. C
  6969.             B(L1,L) = 0.0D0
  6970. C
  6971.             DO 140 I = 1, N
  6972.                T = A(I,L1) + U2 * A(I,L)
  6973.                A(I,L1) = A(I,L1) + T * V1
  6974.                A(I,L) = A(I,L) + T * V2
  6975.   140       CONTINUE
  6976. C
  6977.             IF (.NOT. MATZ) GO TO 150
  6978. C
  6979.             DO 145 I = 1, N
  6980.                T = Z(I,L1) + U2 * Z(I,L)
  6981.                Z(I,L1) = Z(I,L1) + T * V1
  6982.                Z(I,L) = Z(I,L) + T * V2
  6983.   145       CONTINUE
  6984. C
  6985.   150    CONTINUE
  6986. C
  6987.   160 CONTINUE
  6988. C
  6989.   170 RETURN
  6990.       END
  6991.       SUBROUTINE QZIT(NM,N,A,B,EPS1,MATZ,Z,IERR)
  6992. C
  6993.       INTEGER I,J,K,L,N,EN,K1,K2,LD,LL,L1,NA,NM,ISH,ITN,ITS,KM1,LM1,
  6994.      X        ENM2,IERR,LOR1,ENORN
  6995.       DOUBLE PRECISION A(NM,N),B(NM,N),Z(NM,N)
  6996.       DOUBLE PRECISION R,S,T,A1,A2,A3,EP,SH,U1,U2,U3,V1,V2,V3,ANI,A11,
  6997.      X       A12,A21,A22,A33,A34,A43,A44,BNI,B11,B12,B22,B33,B34,
  6998.      X       B44,EPSA,EPSB,EPS1,ANORM,BNORM,EPSLON
  6999.       LOGICAL MATZ,NOTLAS
  7000. C
  7001. C     THIS SUBROUTINE IS THE SECOND STEP OF THE QZ ALGORITHM
  7002. C     FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS,
  7003. C     SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART,
  7004. C     AS MODIFIED IN TECHNICAL NOTE NASA TN D-7305(1973) BY WARD.
  7005. C
  7006. C     THIS SUBROUTINE ACCEPTS A PAIR OF REAL MATRICES, ONE OF THEM
  7007. C     IN UPPER HESSENBERG FORM AND THE OTHER IN UPPER TRIANGULAR FORM.
  7008. C     IT REDUCES THE HESSENBERG MATRIX TO QUASI-TRIANGULAR FORM USING
  7009. C     ORTHOGONAL TRANSFORMATIONS WHILE MAINTAINING THE TRIANGULAR FORM
  7010. C     OF THE OTHER MATRIX.  IT IS USUALLY PRECEDED BY  QZHES  AND
  7011. C     FOLLOWED BY  QZVAL  AND, POSSIBLY,  QZVEC.
  7012. C
  7013. C     ON INPUT
  7014. C
  7015. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  7016. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  7017. C          DIMENSION STATEMENT.
  7018. C
  7019. C        N IS THE ORDER OF THE MATRICES.
  7020. C
  7021. C        A CONTAINS A REAL UPPER HESSENBERG MATRIX.
  7022. C
  7023. C        B CONTAINS A REAL UPPER TRIANGULAR MATRIX.
  7024. C
  7025. C        EPS1 IS A TOLERANCE USED TO DETERMINE NEGLIGIBLE ELEMENTS.
  7026. C          EPS1 = 0.0 (OR NEGATIVE) MAY BE INPUT, IN WHICH CASE AN
  7027. C          ELEMENT WILL BE NEGLECTED ONLY IF IT IS LESS THAN ROUNDOFF
  7028. C          ERROR TIMES THE NORM OF ITS MATRIX.  IF THE INPUT EPS1 IS
  7029. C          POSITIVE, THEN AN ELEMENT WILL BE CONSIDERED NEGLIGIBLE
  7030. C          IF IT IS LESS THAN EPS1 TIMES THE NORM OF ITS MATRIX.  A
  7031. C          POSITIVE VALUE OF EPS1 MAY RESULT IN FASTER EXECUTION,
  7032. C          BUT LESS ACCURATE RESULTS.
  7033. C
  7034. C        MATZ SHOULD BE SET TO .TRUE. IF THE RIGHT HAND TRANSFORMATIONS
  7035. C          ARE TO BE ACCUMULATED FOR LATER USE IN COMPUTING
  7036. C          EIGENVECTORS, AND TO .FALSE. OTHERWISE.
  7037. C
  7038. C        Z CONTAINS, IF MATZ HAS BEEN SET TO .TRUE., THE
  7039. C          TRANSFORMATION MATRIX PRODUCED IN THE REDUCTION
  7040. C          BY  QZHES, IF PERFORMED, OR ELSE THE IDENTITY MATRIX.
  7041. C          IF MATZ HAS BEEN SET TO .FALSE., Z IS NOT REFERENCED.
  7042. C
  7043. C     ON OUTPUT
  7044. C
  7045. C        A HAS BEEN REDUCED TO QUASI-TRIANGULAR FORM.  THE ELEMENTS
  7046. C          BELOW THE FIRST SUBDIAGONAL ARE STILL ZERO AND NO TWO
  7047. C          CONSECUTIVE SUBDIAGONAL ELEMENTS ARE NONZERO.
  7048. C
  7049. C        B IS STILL IN UPPER TRIANGULAR FORM, ALTHOUGH ITS ELEMENTS
  7050. C          HAVE BEEN ALTERED.  THE LOCATION B(N,1) IS USED TO STORE
  7051. C          EPS1 TIMES THE NORM OF B FOR LATER USE BY  QZVAL  AND  QZVEC.
  7052. C
  7053. C        Z CONTAINS THE PRODUCT OF THE RIGHT HAND TRANSFORMATIONS
  7054. C          (FOR BOTH STEPS) IF MATZ HAS BEEN SET TO .TRUE..
  7055. C
  7056. C        IERR IS SET TO
  7057. C          ZERO       FOR NORMAL RETURN,
  7058. C          J          IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
  7059. C                     WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
  7060. C
  7061. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  7062. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  7063. C
  7064. C     THIS VERSION DATED AUGUST 1983.
  7065. C
  7066. C     ------------------------------------------------------------------
  7067. C
  7068.       IERR = 0
  7069. C     .......... COMPUTE EPSA,EPSB ..........
  7070.       ANORM = 0.0D0
  7071.       BNORM = 0.0D0
  7072. C
  7073.       DO 30 I = 1, N
  7074.          ANI = 0.0D0
  7075.          IF (I .NE. 1) ANI = DABS(A(I,I-1))
  7076.          BNI = 0.0D0
  7077. C
  7078.          DO 20 J = I, N
  7079.             ANI = ANI + DABS(A(I,J))
  7080.             BNI = BNI + DABS(B(I,J))
  7081.    20    CONTINUE
  7082. C
  7083.          IF (ANI .GT. ANORM) ANORM = ANI
  7084.          IF (BNI .GT. BNORM) BNORM = BNI
  7085.    30 CONTINUE
  7086. C
  7087.       IF (ANORM .EQ. 0.0D0) ANORM = 1.0D0
  7088.       IF (BNORM .EQ. 0.0D0) BNORM = 1.0D0
  7089.       EP = EPS1
  7090.       IF (EP .GT. 0.0D0) GO TO 50
  7091. C     .......... USE ROUNDOFF LEVEL IF EPS1 IS ZERO ..........
  7092.       EP = EPSLON(1.0D0)
  7093.    50 EPSA = EP * ANORM
  7094.       EPSB = EP * BNORM
  7095. C     .......... REDUCE A TO QUASI-TRIANGULAR FORM, WHILE
  7096. C                KEEPING B TRIANGULAR ..........
  7097.       LOR1 = 1
  7098.       ENORN = N
  7099.       EN = N
  7100.       ITN = 30*N
  7101. C     .......... BEGIN QZ STEP ..........
  7102.    60 IF (EN .LE. 2) GO TO 1001
  7103.       IF (.NOT. MATZ) ENORN = EN
  7104.       ITS = 0
  7105.       NA = EN - 1
  7106.       ENM2 = NA - 1
  7107.    70 ISH = 2
  7108. C     .......... CHECK FOR CONVERGENCE OR REDUCIBILITY.
  7109. C                FOR L=EN STEP -1 UNTIL 1 DO -- ..........
  7110.       DO 80 LL = 1, EN
  7111.          LM1 = EN - LL
  7112.          L = LM1 + 1
  7113.          IF (L .EQ. 1) GO TO 95
  7114.          IF (DABS(A(L,LM1)) .LE. EPSA) GO TO 90
  7115.    80 CONTINUE
  7116. C
  7117.    90 A(L,LM1) = 0.0D0
  7118.       IF (L .LT. NA) GO TO 95
  7119. C     .......... 1-BY-1 OR 2-BY-2 BLOCK ISOLATED ..........
  7120.       EN = LM1
  7121.       GO TO 60
  7122. C     .......... CHECK FOR SMALL TOP OF B ..........
  7123.    95 LD = L
  7124.   100 L1 = L + 1
  7125.       B11 = B(L,L)
  7126.       IF (DABS(B11) .GT. EPSB) GO TO 120
  7127.       B(L,L) = 0.0D0
  7128.       S = DABS(A(L,L)) + DABS(A(L1,L))
  7129.       U1 = A(L,L) / S
  7130.       U2 = A(L1,L) / S
  7131.       R = DSIGN(DSQRT(U1*U1+U2*U2),U1)
  7132.       V1 = -(U1 + R) / R
  7133.       V2 = -U2 / R
  7134.       U2 = V2 / V1
  7135. C
  7136.       DO 110 J = L, ENORN
  7137.          T = A(L,J) + U2 * A(L1,J)
  7138.          A(L,J) = A(L,J) + T * V1
  7139.          A(L1,J) = A(L1,J) + T * V2
  7140.          T = B(L,J) + U2 * B(L1,J)
  7141.          B(L,J) = B(L,J) + T * V1
  7142.          B(L1,J) = B(L1,J) + T * V2
  7143.   110 CONTINUE
  7144. C
  7145.       IF (L .NE. 1) A(L,LM1) = -A(L,LM1)
  7146.       LM1 = L
  7147.       L = L1
  7148.       GO TO 90
  7149.   120 A11 = A(L,L) / B11
  7150.       A21 = A(L1,L) / B11
  7151.       IF (ISH .EQ. 1) GO TO 140
  7152. C     .......... ITERATION STRATEGY ..........
  7153.       IF (ITN .EQ. 0) GO TO 1000
  7154.       IF (ITS .EQ. 10) GO TO 155
  7155. C     .......... DETERMINE TYPE OF SHIFT ..........
  7156.       B22 = B(L1,L1)
  7157.       IF (DABS(B22) .LT. EPSB) B22 = EPSB
  7158.       B33 = B(NA,NA)
  7159.       IF (DABS(B33) .LT. EPSB) B33 = EPSB
  7160.       B44 = B(EN,EN)
  7161.       IF (DABS(B44) .LT. EPSB) B44 = EPSB
  7162.       A33 = A(NA,NA) / B33
  7163.       A34 = A(NA,EN) / B44
  7164.       A43 = A(EN,NA) / B33
  7165.       A44 = A(EN,EN) / B44
  7166.       B34 = B(NA,EN) / B44
  7167.       T = 0.5D0 * (A43 * B34 - A33 - A44)
  7168.       R = T * T + A34 * A43 - A33 * A44
  7169.       IF (R .LT. 0.0D0) GO TO 150
  7170. C     .......... DETERMINE SINGLE SHIFT ZEROTH COLUMN OF A ..........
  7171.       ISH = 1
  7172.       R = DSQRT(R)
  7173.       SH = -T + R
  7174.       S = -T - R
  7175.       IF (DABS(S-A44) .LT. DABS(SH-A44)) SH = S
  7176. C     .......... LOOK FOR TWO CONSECUTIVE SMALL
  7177. C                SUB-DIAGONAL ELEMENTS OF A.
  7178. C                FOR L=EN-2 STEP -1 UNTIL LD DO -- ..........
  7179.       DO 130 LL = LD, ENM2
  7180.          L = ENM2 + LD - LL
  7181.          IF (L .EQ. LD) GO TO 140
  7182.          LM1 = L - 1
  7183.          L1 = L + 1
  7184.          T = A(L,L)
  7185.          IF (DABS(B(L,L)) .GT. EPSB) T = T - SH * B(L,L)
  7186.          IF (DABS(A(L,LM1)) .LE. DABS(T/A(L1,L)) * EPSA) GO TO 100
  7187.   130 CONTINUE
  7188. C
  7189.   140 A1 = A11 - SH
  7190.       A2 = A21
  7191.       IF (L .NE. LD) A(L,LM1) = -A(L,LM1)
  7192.       GO TO 160
  7193. C     .......... DETERMINE DOUBLE SHIFT ZEROTH COLUMN OF A ..........
  7194.   150 A12 = A(L,L1) / B22
  7195.       A22 = A(L1,L1) / B22
  7196.       B12 = B(L,L1) / B22
  7197.       A1 = ((A33 - A11) * (A44 - A11) - A34 * A43 + A43 * B34 * A11)
  7198.      X     / A21 + A12 - A11 * B12
  7199.       A2 = (A22 - A11) - A21 * B12 - (A33 - A11) - (A44 - A11)
  7200.      X     + A43 * B34
  7201.       A3 = A(L1+1,L1) / B22
  7202.       GO TO 160
  7203. C     .......... AD HOC SHIFT ..........
  7204.   155 A1 = 0.0D0
  7205.       A2 = 1.0D0
  7206.       A3 = 1.1605D0
  7207.   160 ITS = ITS + 1
  7208.       ITN = ITN - 1
  7209.       IF (.NOT. MATZ) LOR1 = LD
  7210. C     .......... MAIN LOOP ..........
  7211.       DO 260 K = L, NA
  7212.          NOTLAS = K .NE. NA .AND. ISH .EQ. 2
  7213.          K1 = K + 1
  7214.          K2 = K + 2
  7215.          KM1 = MAX0(K-1,L)
  7216.          LL = MIN0(EN,K1+ISH)
  7217.          IF (NOTLAS) GO TO 190
  7218. C     .......... ZERO A(K+1,K-1) ..........
  7219.          IF (K .EQ. L) GO TO 170
  7220.          A1 = A(K,KM1)
  7221.          A2 = A(K1,KM1)
  7222.   170    S = DABS(A1) + DABS(A2)
  7223.          IF (S .EQ. 0.0D0) GO TO 70
  7224.          U1 = A1 / S
  7225.          U2 = A2 / S
  7226.          R = DSIGN(DSQRT(U1*U1+U2*U2),U1)
  7227.          V1 = -(U1 + R) / R
  7228.          V2 = -U2 / R
  7229.          U2 = V2 / V1
  7230. C
  7231.          DO 180 J = KM1, ENORN
  7232.             T = A(K,J) + U2 * A(K1,J)
  7233.             A(K,J) = A(K,J) + T * V1
  7234.             A(K1,J) = A(K1,J) + T * V2
  7235.             T = B(K,J) + U2 * B(K1,J)
  7236.             B(K,J) = B(K,J) + T * V1
  7237.             B(K1,J) = B(K1,J) + T * V2
  7238.   180    CONTINUE
  7239. C
  7240.          IF (K .NE. L) A(K1,KM1) = 0.0D0
  7241.          GO TO 240
  7242. C     .......... ZERO A(K+1,K-1) AND A(K+2,K-1) ..........
  7243.   190    IF (K .EQ. L) GO TO 200
  7244.          A1 = A(K,KM1)
  7245.          A2 = A(K1,KM1)
  7246.          A3 = A(K2,KM1)
  7247.   200    S = DABS(A1) + DABS(A2) + DABS(A3)
  7248.          IF (S .EQ. 0.0D0) GO TO 260
  7249.          U1 = A1 / S
  7250.          U2 = A2 / S
  7251.          U3 = A3 / S
  7252.          R = DSIGN(DSQRT(U1*U1+U2*U2+U3*U3),U1)
  7253.          V1 = -(U1 + R) / R
  7254.          V2 = -U2 / R
  7255.          V3 = -U3 / R
  7256.          U2 = V2 / V1
  7257.          U3 = V3 / V1
  7258. C
  7259.          DO 210 J = KM1, ENORN
  7260.             T = A(K,J) + U2 * A(K1,J) + U3 * A(K2,J)
  7261.             A(K,J) = A(K,J) + T * V1
  7262.             A(K1,J) = A(K1,J) + T * V2
  7263.             A(K2,J) = A(K2,J) + T * V3
  7264.             T = B(K,J) + U2 * B(K1,J) + U3 * B(K2,J)
  7265.             B(K,J) = B(K,J) + T * V1
  7266.             B(K1,J) = B(K1,J) + T * V2
  7267.             B(K2,J) = B(K2,J) + T * V3
  7268.   210    CONTINUE
  7269. C
  7270.          IF (K .EQ. L) GO TO 220
  7271.          A(K1,KM1) = 0.0D0
  7272.          A(K2,KM1) = 0.0D0
  7273. C     .......... ZERO B(K+2,K+1) AND B(K+2,K) ..........
  7274.   220    S = DABS(B(K2,K2)) + DABS(B(K2,K1)) + DABS(B(K2,K))
  7275.          IF (S .EQ. 0.0D0) GO TO 240
  7276.          U1 = B(K2,K2) / S
  7277.          U2 = B(K2,K1) / S
  7278.          U3 = B(K2,K) / S
  7279.          R = DSIGN(DSQRT(U1*U1+U2*U2+U3*U3),U1)
  7280.          V1 = -(U1 + R) / R
  7281.          V2 = -U2 / R
  7282.          V3 = -U3 / R
  7283.          U2 = V2 / V1
  7284.          U3 = V3 / V1
  7285. C
  7286.          DO 230 I = LOR1, LL
  7287.             T = A(I,K2) + U2 * A(I,K1) + U3 * A(I,K)
  7288.             A(I,K2) = A(I,K2) + T * V1
  7289.             A(I,K1) = A(I,K1) + T * V2
  7290.             A(I,K) = A(I,K) + T * V3
  7291.             T = B(I,K2) + U2 * B(I,K1) + U3 * B(I,K)
  7292.             B(I,K2) = B(I,K2) + T * V1
  7293.             B(I,K1) = B(I,K1) + T * V2
  7294.             B(I,K) = B(I,K) + T * V3
  7295.   230    CONTINUE
  7296. C
  7297.          B(K2,K) = 0.0D0
  7298.          B(K2,K1) = 0.0D0
  7299.          IF (.NOT. MATZ) GO TO 240
  7300. C
  7301.          DO 235 I = 1, N
  7302.             T = Z(I,K2) + U2 * Z(I,K1) + U3 * Z(I,K)
  7303.             Z(I,K2) = Z(I,K2) + T * V1
  7304.             Z(I,K1) = Z(I,K1) + T * V2
  7305.             Z(I,K) = Z(I,K) + T * V3
  7306.   235    CONTINUE
  7307. C     .......... ZERO B(K+1,K) ..........
  7308.   240    S = DABS(B(K1,K1)) + DABS(B(K1,K))
  7309.          IF (S .EQ. 0.0D0) GO TO 260
  7310.          U1 = B(K1,K1) / S
  7311.          U2 = B(K1,K) / S
  7312.          R = DSIGN(DSQRT(U1*U1+U2*U2),U1)
  7313.          V1 = -(U1 + R) / R
  7314.          V2 = -U2 / R
  7315.          U2 = V2 / V1
  7316. C
  7317.          DO 250 I = LOR1, LL
  7318.             T = A(I,K1) + U2 * A(I,K)
  7319.             A(I,K1) = A(I,K1) + T * V1
  7320.             A(I,K) = A(I,K) + T * V2
  7321.             T = B(I,K1) + U2 * B(I,K)
  7322.             B(I,K1) = B(I,K1) + T * V1
  7323.             B(I,K) = B(I,K) + T * V2
  7324.   250    CONTINUE
  7325. C
  7326.          B(K1,K) = 0.0D0
  7327.          IF (.NOT. MATZ) GO TO 260
  7328. C
  7329.          DO 255 I = 1, N
  7330.             T = Z(I,K1) + U2 * Z(I,K)
  7331.             Z(I,K1) = Z(I,K1) + T * V1
  7332.             Z(I,K) = Z(I,K) + T * V2
  7333.   255    CONTINUE
  7334. C
  7335.   260 CONTINUE
  7336. C     .......... END QZ STEP ..........
  7337.       GO TO 70
  7338. C     .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
  7339. C                CONVERGED AFTER 30*N ITERATIONS ..........
  7340.  1000 IERR = EN
  7341. C     .......... SAVE EPSB FOR USE BY QZVAL AND QZVEC ..........
  7342.  1001 IF (N .GT. 1) B(N,1) = EPSB
  7343.       RETURN
  7344.       END
  7345.       SUBROUTINE QZVAL(NM,N,A,B,ALFR,ALFI,BETA,MATZ,Z)
  7346. C
  7347.       INTEGER I,J,N,EN,NA,NM,NN,ISW
  7348.       DOUBLE PRECISION A(NM,N),B(NM,N),ALFR(N),ALFI(N),BETA(N),Z(NM,N)
  7349.       DOUBLE PRECISION C,D,E,R,S,T,AN,A1,A2,BN,CQ,CZ,DI,DR,EI,TI,TR,U1,
  7350.      X       U2,V1,V2,A1I,A11,A12,A2I,A21,A22,B11,B12,B22,SQI,SQR,
  7351.      X       SSI,SSR,SZI,SZR,A11I,A11R,A12I,A12R,A22I,A22R,EPSB
  7352.       LOGICAL MATZ
  7353. C
  7354. C     THIS SUBROUTINE IS THE THIRD STEP OF THE QZ ALGORITHM
  7355. C     FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS,
  7356. C     SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART.
  7357. C
  7358. C     THIS SUBROUTINE ACCEPTS A PAIR OF REAL MATRICES, ONE OF THEM
  7359. C     IN QUASI-TRIANGULAR FORM AND THE OTHER IN UPPER TRIANGULAR FORM.
  7360. C     IT REDUCES THE QUASI-TRIANGULAR MATRIX FURTHER, SO THAT ANY
  7361. C     REMAINING 2-BY-2 BLOCKS CORRESPOND TO PAIRS OF COMPLEX
  7362. C     EIGENVALUES, AND RETURNS QUANTITIES WHOSE RATIOS GIVE THE
  7363. C     GENERALIZED EIGENVALUES.  IT IS USUALLY PRECEDED BY  QZHES
  7364. C     AND  QZIT  AND MAY BE FOLLOWED BY  QZVEC.
  7365. C
  7366. C     ON INPUT
  7367. C
  7368. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  7369. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  7370. C          DIMENSION STATEMENT.
  7371. C
  7372. C        N IS THE ORDER OF THE MATRICES.
  7373. C
  7374. C        A CONTAINS A REAL UPPER QUASI-TRIANGULAR MATRIX.
  7375. C
  7376. C        B CONTAINS A REAL UPPER TRIANGULAR MATRIX.  IN ADDITION,
  7377. C          LOCATION B(N,1) CONTAINS THE TOLERANCE QUANTITY (EPSB)
  7378. C          COMPUTED AND SAVED IN  QZIT.
  7379. C
  7380. C        MATZ SHOULD BE SET TO .TRUE. IF THE RIGHT HAND TRANSFORMATIONS
  7381. C          ARE TO BE ACCUMULATED FOR LATER USE IN COMPUTING
  7382. C          EIGENVECTORS, AND TO .FALSE. OTHERWISE.
  7383. C
  7384. C        Z CONTAINS, IF MATZ HAS BEEN SET TO .TRUE., THE
  7385. C          TRANSFORMATION MATRIX PRODUCED IN THE REDUCTIONS BY QZHES
  7386. C          AND QZIT, IF PERFORMED, OR ELSE THE IDENTITY MATRIX.
  7387. C          IF MATZ HAS BEEN SET TO .FALSE., Z IS NOT REFERENCED.
  7388. C
  7389. C     ON OUTPUT
  7390. C
  7391. C        A HAS BEEN REDUCED FURTHER TO A QUASI-TRIANGULAR MATRIX
  7392. C          IN WHICH ALL NONZERO SUBDIAGONAL ELEMENTS CORRESPOND TO
  7393. C          PAIRS OF COMPLEX EIGENVALUES.
  7394. C
  7395. C        B IS STILL IN UPPER TRIANGULAR FORM, ALTHOUGH ITS ELEMENTS
  7396. C          HAVE BEEN ALTERED.  B(N,1) IS UNALTERED.
  7397. C
  7398. C        ALFR AND ALFI CONTAIN THE REAL AND IMAGINARY PARTS OF THE
  7399. C          DIAGONAL ELEMENTS OF THE TRIANGULAR MATRIX THAT WOULD BE
  7400. C          OBTAINED IF A WERE REDUCED COMPLETELY TO TRIANGULAR FORM
  7401. C          BY UNITARY TRANSFORMATIONS.  NON-ZERO VALUES OF ALFI OCCUR
  7402. C          IN PAIRS, THE FIRST MEMBER POSITIVE AND THE SECOND NEGATIVE.
  7403. C
  7404. C        BETA CONTAINS THE DIAGONAL ELEMENTS OF THE CORRESPONDING B,
  7405. C          NORMALIZED TO BE REAL AND NON-NEGATIVE.  THE GENERALIZED
  7406. C          EIGENVALUES ARE THEN THE RATIOS ((ALFR+I*ALFI)/BETA).
  7407. C
  7408. C        Z CONTAINS THE PRODUCT OF THE RIGHT HAND TRANSFORMATIONS
  7409. C          (FOR ALL THREE STEPS) IF MATZ HAS BEEN SET TO .TRUE.
  7410. C
  7411. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  7412. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  7413. C
  7414. C     THIS VERSION DATED AUGUST 1983.
  7415. C
  7416. C     ------------------------------------------------------------------
  7417. C
  7418.       EPSB = B(N,1)
  7419.       ISW = 1
  7420. C     .......... FIND EIGENVALUES OF QUASI-TRIANGULAR MATRICES.
  7421. C                FOR EN=N STEP -1 UNTIL 1 DO -- ..........
  7422.       DO 510 NN = 1, N
  7423.          EN = N + 1 - NN
  7424.          NA = EN - 1
  7425.          IF (ISW .EQ. 2) GO TO 505
  7426.          IF (EN .EQ. 1) GO TO 410
  7427.          IF (A(EN,NA) .NE. 0.0D0) GO TO 420
  7428. C     .......... 1-BY-1 BLOCK, ONE REAL ROOT ..........
  7429.   410    ALFR(EN) = A(EN,EN)
  7430.          IF (B(EN,EN) .LT. 0.0D0) ALFR(EN) = -ALFR(EN)
  7431.          BETA(EN) = DABS(B(EN,EN))
  7432.          ALFI(EN) = 0.0D0
  7433.          GO TO 510
  7434. C     .......... 2-BY-2 BLOCK ..........
  7435.   420    IF (DABS(B(NA,NA)) .LE. EPSB) GO TO 455
  7436.          IF (DABS(B(EN,EN)) .GT. EPSB) GO TO 430
  7437.          A1 = A(EN,EN)
  7438.          A2 = A(EN,NA)
  7439.          BN = 0.0D0
  7440.          GO TO 435
  7441.   430    AN = DABS(A(NA,NA)) + DABS(A(NA,EN)) + DABS(A(EN,NA))
  7442.      X      + DABS(A(EN,EN))
  7443.          BN = DABS(B(NA,NA)) + DABS(B(NA,EN)) + DABS(B(EN,EN))
  7444.          A11 = A(NA,NA) / AN
  7445.          A12 = A(NA,EN) / AN
  7446.          A21 = A(EN,NA) / AN
  7447.          A22 = A(EN,EN) / AN
  7448.          B11 = B(NA,NA) / BN
  7449.          B12 = B(NA,EN) / BN
  7450.          B22 = B(EN,EN) / BN
  7451.          E = A11 / B11
  7452.          EI = A22 / B22
  7453.          S = A21 / (B11 * B22)
  7454.          T = (A22 - E * B22) / B22
  7455.          IF (DABS(E) .LE. DABS(EI)) GO TO 431
  7456.          E = EI
  7457.          T = (A11 - E * B11) / B11
  7458.   431    C = 0.5D0 * (T - S * B12)
  7459.          D = C * C + S * (A12 - E * B12)
  7460.          IF (D .LT. 0.0D0) GO TO 480
  7461. C     .......... TWO REAL ROOTS.
  7462. C                ZERO BOTH A(EN,NA) AND B(EN,NA) ..........
  7463.          E = E + (C + DSIGN(DSQRT(D),C))
  7464.          A11 = A11 - E * B11
  7465.          A12 = A12 - E * B12
  7466.          A22 = A22 - E * B22
  7467.          IF (DABS(A11) + DABS(A12) .LT.
  7468.      X       DABS(A21) + DABS(A22)) GO TO 432
  7469.          A1 = A12
  7470.          A2 = A11
  7471.          GO TO 435
  7472.   432    A1 = A22
  7473.          A2 = A21
  7474. C     .......... CHOOSE AND APPLY REAL Z ..........
  7475.   435    S = DABS(A1) + DABS(A2)
  7476.          U1 = A1 / S
  7477.          U2 = A2 / S
  7478.          R = DSIGN(DSQRT(U1*U1+U2*U2),U1)
  7479.          V1 = -(U1 + R) / R
  7480.          V2 = -U2 / R
  7481.          U2 = V2 / V1
  7482. C
  7483.          DO 440 I = 1, EN
  7484.             T = A(I,EN) + U2 * A(I,NA)
  7485.             A(I,EN) = A(I,EN) + T * V1
  7486.             A(I,NA) = A(I,NA) + T * V2
  7487.             T = B(I,EN) + U2 * B(I,NA)
  7488.             B(I,EN) = B(I,EN) + T * V1
  7489.             B(I,NA) = B(I,NA) + T * V2
  7490.   440    CONTINUE
  7491. C
  7492.          IF (.NOT. MATZ) GO TO 450
  7493. C
  7494.          DO 445 I = 1, N
  7495.             T = Z(I,EN) + U2 * Z(I,NA)
  7496.             Z(I,EN) = Z(I,EN) + T * V1
  7497.             Z(I,NA) = Z(I,NA) + T * V2
  7498.   445    CONTINUE
  7499. C
  7500.   450    IF (BN .EQ. 0.0D0) GO TO 475
  7501.          IF (AN .LT. DABS(E) * BN) GO TO 455
  7502.          A1 = B(NA,NA)
  7503.          A2 = B(EN,NA)
  7504.          GO TO 460
  7505.   455    A1 = A(NA,NA)
  7506.          A2 = A(EN,NA)
  7507. C     .......... CHOOSE AND APPLY REAL Q ..........
  7508.   460    S = DABS(A1) + DABS(A2)
  7509.          IF (S .EQ. 0.0D0) GO TO 475
  7510.          U1 = A1 / S
  7511.          U2 = A2 / S
  7512.          R = DSIGN(DSQRT(U1*U1+U2*U2),U1)
  7513.          V1 = -(U1 + R) / R
  7514.          V2 = -U2 / R
  7515.          U2 = V2 / V1
  7516. C
  7517.          DO 470 J = NA, N
  7518.             T = A(NA,J) + U2 * A(EN,J)
  7519.             A(NA,J) = A(NA,J) + T * V1
  7520.             A(EN,J) = A(EN,J) + T * V2
  7521.             T = B(NA,J) + U2 * B(EN,J)
  7522.             B(NA,J) = B(NA,J) + T * V1
  7523.             B(EN,J) = B(EN,J) + T * V2
  7524.   470    CONTINUE
  7525. C
  7526.   475    A(EN,NA) = 0.0D0
  7527.          B(EN,NA) = 0.0D0
  7528.          ALFR(NA) = A(NA,NA)
  7529.          ALFR(EN) = A(EN,EN)
  7530.          IF (B(NA,NA) .LT. 0.0D0) ALFR(NA) = -ALFR(NA)
  7531.          IF (B(EN,EN) .LT. 0.0D0) ALFR(EN) = -ALFR(EN)
  7532.          BETA(NA) = DABS(B(NA,NA))
  7533.          BETA(EN) = DABS(B(EN,EN))
  7534.          ALFI(EN) = 0.0D0
  7535.          ALFI(NA) = 0.0D0
  7536.          GO TO 505
  7537. C     .......... TWO COMPLEX ROOTS ..........
  7538.   480    E = E + C
  7539.          EI = DSQRT(-D)
  7540.          A11R = A11 - E * B11
  7541.          A11I = EI * B11
  7542.          A12R = A12 - E * B12
  7543.          A12I = EI * B12
  7544.          A22R = A22 - E * B22
  7545.          A22I = EI * B22
  7546.          IF (DABS(A11R) + DABS(A11I) + DABS(A12R) + DABS(A12I) .LT.
  7547.      X       DABS(A21) + DABS(A22R) + DABS(A22I)) GO TO 482
  7548.          A1 = A12R
  7549.          A1I = A12I
  7550.          A2 = -A11R
  7551.          A2I = -A11I
  7552.          GO TO 485
  7553.   482    A1 = A22R
  7554.          A1I = A22I
  7555.          A2 = -A21
  7556.          A2I = 0.0D0
  7557. C     .......... CHOOSE COMPLEX Z ..........
  7558.   485    CZ = DSQRT(A1*A1+A1I*A1I)
  7559.          IF (CZ .EQ. 0.0D0) GO TO 487
  7560.          SZR = (A1 * A2 + A1I * A2I) / CZ
  7561.          SZI = (A1 * A2I - A1I * A2) / CZ
  7562.          R = DSQRT(CZ*CZ+SZR*SZR+SZI*SZI)
  7563.          CZ = CZ / R
  7564.          SZR = SZR / R
  7565.          SZI = SZI / R
  7566.          GO TO 490
  7567.   487    SZR = 1.0D0
  7568.          SZI = 0.0D0
  7569.   490    IF (AN .LT. (DABS(E) + EI) * BN) GO TO 492
  7570.          A1 = CZ * B11 + SZR * B12
  7571.          A1I = SZI * B12
  7572.          A2 = SZR * B22
  7573.          A2I = SZI * B22
  7574.          GO TO 495
  7575.   492    A1 = CZ * A11 + SZR * A12
  7576.          A1I = SZI * A12
  7577.          A2 = CZ * A21 + SZR * A22
  7578.          A2I = SZI * A22
  7579. C     .......... CHOOSE COMPLEX Q ..........
  7580.   495    CQ = DSQRT(A1*A1+A1I*A1I)
  7581.          IF (CQ .EQ. 0.0D0) GO TO 497
  7582.          SQR = (A1 * A2 + A1I * A2I) / CQ
  7583.          SQI = (A1 * A2I - A1I * A2) / CQ
  7584.          R = DSQRT(CQ*CQ+SQR*SQR+SQI*SQI)
  7585.          CQ = CQ / R
  7586.          SQR = SQR / R
  7587.          SQI = SQI / R
  7588.          GO TO 500
  7589.   497    SQR = 1.0D0
  7590.          SQI = 0.0D0
  7591. C     .......... COMPUTE DIAGONAL ELEMENTS THAT WOULD RESULT
  7592. C                IF TRANSFORMATIONS WERE APPLIED ..........
  7593.   500    SSR = SQR * SZR + SQI * SZI
  7594.          SSI = SQR * SZI - SQI * SZR
  7595.          I = 1
  7596.          TR = CQ * CZ * A11 + CQ * SZR * A12 + SQR * CZ * A21
  7597.      X      + SSR * A22
  7598.          TI = CQ * SZI * A12 - SQI * CZ * A21 + SSI * A22
  7599.          DR = CQ * CZ * B11 + CQ * SZR * B12 + SSR * B22
  7600.          DI = CQ * SZI * B12 + SSI * B22
  7601.          GO TO 503
  7602.   502    I = 2
  7603.          TR = SSR * A11 - SQR * CZ * A12 - CQ * SZR * A21
  7604.      X      + CQ * CZ * A22
  7605.          TI = -SSI * A11 - SQI * CZ * A12 + CQ * SZI * A21
  7606.          DR = SSR * B11 - SQR * CZ * B12 + CQ * CZ * B22
  7607.          DI = -SSI * B11 - SQI * CZ * B12
  7608.   503    T = TI * DR - TR * DI
  7609.          J = NA
  7610.          IF (T .LT. 0.0D0) J = EN
  7611.          R = DSQRT(DR*DR+DI*DI)
  7612.          BETA(J) = BN * R
  7613.          ALFR(J) = AN * (TR * DR + TI * DI) / R
  7614.          ALFI(J) = AN * T / R
  7615.          IF (I .EQ. 1) GO TO 502
  7616.   505    ISW = 3 - ISW
  7617.   510 CONTINUE
  7618.       B(N,1) = EPSB
  7619. C
  7620.       RETURN
  7621.       END
  7622.       SUBROUTINE QZVEC(NM,N,A,B,ALFR,ALFI,BETA,Z)
  7623. C
  7624.       INTEGER I,J,K,M,N,EN,II,JJ,NA,NM,NN,ISW,ENM2
  7625.       DOUBLE PRECISION A(NM,N),B(NM,N),ALFR(N),ALFI(N),BETA(N),Z(NM,N)
  7626.       DOUBLE PRECISION D,Q,R,S,T,W,X,Y,DI,DR,RA,RR,SA,TI,TR,T1,T2,W1,X1,
  7627.      X       ZZ,Z1,ALFM,ALMI,ALMR,BETM,EPSB
  7628. C
  7629. C     THIS SUBROUTINE IS THE OPTIONAL FOURTH STEP OF THE QZ ALGORITHM
  7630. C     FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS,
  7631. C     SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART.
  7632. C
  7633. C     THIS SUBROUTINE ACCEPTS A PAIR OF REAL MATRICES, ONE OF THEM IN
  7634. C     QUASI-TRIANGULAR FORM (IN WHICH EACH 2-BY-2 BLOCK CORRESPONDS TO
  7635. C     A PAIR OF COMPLEX EIGENVALUES) AND THE OTHER IN UPPER TRIANGULAR
  7636. C     FORM.  IT COMPUTES THE EIGENVECTORS OF THE TRIANGULAR PROBLEM AND
  7637. C     TRANSFORMS THE RESULTS BACK TO THE ORIGINAL COORDINATE SYSTEM.
  7638. C     IT IS USUALLY PRECEDED BY  QZHES,  QZIT, AND  QZVAL.
  7639. C
  7640. C     ON INPUT
  7641. C
  7642. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  7643. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  7644. C          DIMENSION STATEMENT.
  7645. C
  7646. C        N IS THE ORDER OF THE MATRICES.
  7647. C
  7648. C        A CONTAINS A REAL UPPER QUASI-TRIANGULAR MATRIX.
  7649. C
  7650. C        B CONTAINS A REAL UPPER TRIANGULAR MATRIX.  IN ADDITION,
  7651. C          LOCATION B(N,1) CONTAINS THE TOLERANCE QUANTITY (EPSB)
  7652. C          COMPUTED AND SAVED IN  QZIT.
  7653. C
  7654. C        ALFR, ALFI, AND BETA  ARE VECTORS WITH COMPONENTS WHOSE
  7655. C          RATIOS ((ALFR+I*ALFI)/BETA) ARE THE GENERALIZED
  7656. C          EIGENVALUES.  THEY ARE USUALLY OBTAINED FROM  QZVAL.
  7657. C
  7658. C        Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
  7659. C          REDUCTIONS BY  QZHES,  QZIT, AND  QZVAL, IF PERFORMED.
  7660. C          IF THE EIGENVECTORS OF THE TRIANGULAR PROBLEM ARE
  7661. C          DESIRED, Z MUST CONTAIN THE IDENTITY MATRIX.
  7662. C
  7663. C     ON OUTPUT
  7664. C
  7665. C        A IS UNALTERED.  ITS SUBDIAGONAL ELEMENTS PROVIDE INFORMATION
  7666. C           ABOUT THE STORAGE OF THE COMPLEX EIGENVECTORS.
  7667. C
  7668. C        B HAS BEEN DESTROYED.
  7669. C
  7670. C        ALFR, ALFI, AND BETA ARE UNALTERED.
  7671. C
  7672. C        Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS.
  7673. C          IF ALFI(I) .EQ. 0.0, THE I-TH EIGENVALUE IS REAL AND
  7674. C            THE I-TH COLUMN OF Z CONTAINS ITS EIGENVECTOR.
  7675. C          IF ALFI(I) .NE. 0.0, THE I-TH EIGENVALUE IS COMPLEX.
  7676. C            IF ALFI(I) .GT. 0.0, THE EIGENVALUE IS THE FIRST OF
  7677. C              A COMPLEX PAIR AND THE I-TH AND (I+1)-TH COLUMNS
  7678. C              OF Z CONTAIN ITS EIGENVECTOR.
  7679. C            IF ALFI(I) .LT. 0.0, THE EIGENVALUE IS THE SECOND OF
  7680. C              A COMPLEX PAIR AND THE (I-1)-TH AND I-TH COLUMNS
  7681. C              OF Z CONTAIN THE CONJUGATE OF ITS EIGENVECTOR.
  7682. C          EACH EIGENVECTOR IS NORMALIZED SO THAT THE MODULUS
  7683. C          OF ITS LARGEST COMPONENT IS 1.0 .
  7684. C
  7685. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  7686. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  7687. C
  7688. C     THIS VERSION DATED AUGUST 1983.
  7689. C
  7690. C     ------------------------------------------------------------------
  7691. C
  7692.       EPSB = B(N,1)
  7693.       ISW = 1
  7694. C     .......... FOR EN=N STEP -1 UNTIL 1 DO -- ..........
  7695.       DO 800 NN = 1, N
  7696.          EN = N + 1 - NN
  7697.          NA = EN - 1
  7698.          IF (ISW .EQ. 2) GO TO 795
  7699.          IF (ALFI(EN) .NE. 0.0D0) GO TO 710
  7700. C     .......... REAL VECTOR ..........
  7701.          M = EN
  7702.          B(EN,EN) = 1.0D0
  7703.          IF (NA .EQ. 0) GO TO 800
  7704.          ALFM = ALFR(M)
  7705.          BETM = BETA(M)
  7706. C     .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
  7707.          DO 700 II = 1, NA
  7708.             I = EN - II
  7709.             W = BETM * A(I,I) - ALFM * B(I,I)
  7710.             R = 0.0D0
  7711. C
  7712.             DO 610 J = M, EN
  7713.   610       R = R + (BETM * A(I,J) - ALFM * B(I,J)) * B(J,EN)
  7714. C
  7715.             IF (I .EQ. 1 .OR. ISW .EQ. 2) GO TO 630
  7716.             IF (BETM * A(I,I-1) .EQ. 0.0D0) GO TO 630
  7717.             ZZ = W
  7718.             S = R
  7719.             GO TO 690
  7720.   630       M = I
  7721.             IF (ISW .EQ. 2) GO TO 640
  7722. C     .......... REAL 1-BY-1 BLOCK ..........
  7723.             T = W
  7724.             IF (W .EQ. 0.0D0) T = EPSB
  7725.             B(I,EN) = -R / T
  7726.             GO TO 700
  7727. C     .......... REAL 2-BY-2 BLOCK ..........
  7728.   640       X = BETM * A(I,I+1) - ALFM * B(I,I+1)
  7729.             Y = BETM * A(I+1,I)
  7730.             Q = W * ZZ - X * Y
  7731.             T = (X * S - ZZ * R) / Q
  7732.             B(I,EN) = T
  7733.             IF (DABS(X) .LE. DABS(ZZ)) GO TO 650
  7734.             B(I+1,EN) = (-R - W * T) / X
  7735.             GO TO 690
  7736.   650       B(I+1,EN) = (-S - Y * T) / ZZ
  7737.   690       ISW = 3 - ISW
  7738.   700    CONTINUE
  7739. C     .......... END REAL VECTOR ..........
  7740.          GO TO 800
  7741. C     .......... COMPLEX VECTOR ..........
  7742.   710    M = NA
  7743.          ALMR = ALFR(M)
  7744.          ALMI = ALFI(M)
  7745.          BETM = BETA(M)
  7746. C     .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT
  7747. C                EIGENVECTOR MATRIX IS TRIANGULAR ..........
  7748.          Y = BETM * A(EN,NA)
  7749.          B(NA,NA) = -ALMI * B(EN,EN) / Y
  7750.          B(NA,EN) = (ALMR * B(EN,EN) - BETM * A(EN,EN)) / Y
  7751.          B(EN,NA) = 0.0D0
  7752.          B(EN,EN) = 1.0D0
  7753.          ENM2 = NA - 1
  7754.          IF (ENM2 .EQ. 0) GO TO 795
  7755. C     .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- ..........
  7756.          DO 790 II = 1, ENM2
  7757.             I = NA - II
  7758.             W = BETM * A(I,I) - ALMR * B(I,I)
  7759.             W1 = -ALMI * B(I,I)
  7760.             RA = 0.0D0
  7761.             SA = 0.0D0
  7762. C
  7763.             DO 760 J = M, EN
  7764.                X = BETM * A(I,J) - ALMR * B(I,J)
  7765.                X1 = -ALMI * B(I,J)
  7766.                RA = RA + X * B(J,NA) - X1 * B(J,EN)
  7767.                SA = SA + X * B(J,EN) + X1 * B(J,NA)
  7768.   760       CONTINUE
  7769. C
  7770.             IF (I .EQ. 1 .OR. ISW .EQ. 2) GO TO 770
  7771.             IF (BETM * A(I,I-1) .EQ. 0.0D0) GO TO 770
  7772.             ZZ = W
  7773.             Z1 = W1
  7774.             R = RA
  7775.             S = SA
  7776.             ISW = 2
  7777.             GO TO 790
  7778.   770       M = I
  7779.             IF (ISW .EQ. 2) GO TO 780
  7780. C     .......... COMPLEX 1-BY-1 BLOCK ..........
  7781.             TR = -RA
  7782.             TI = -SA
  7783.   773       DR = W
  7784.             DI = W1
  7785. C     .......... COMPLEX DIVIDE (T1,T2) = (TR,TI) / (DR,DI) ..........
  7786.   775       IF (DABS(DI) .GT. DABS(DR)) GO TO 777
  7787.             RR = DI / DR
  7788.             D = DR + DI * RR
  7789.             T1 = (TR + TI * RR) / D
  7790.             T2 = (TI - TR * RR) / D
  7791.             GO TO (787,782), ISW
  7792.   777       RR = DR / DI
  7793.             D = DR * RR + DI
  7794.             T1 = (TR * RR + TI) / D
  7795.             T2 = (TI * RR - TR) / D
  7796.             GO TO (787,782), ISW
  7797. C     .......... COMPLEX 2-BY-2 BLOCK ..........
  7798.   780       X = BETM * A(I,I+1) - ALMR * B(I,I+1)
  7799.             X1 = -ALMI * B(I,I+1)
  7800.             Y = BETM * A(I+1,I)
  7801.             TR = Y * RA - W * R + W1 * S
  7802.             TI = Y * SA - W * S - W1 * R
  7803.             DR = W * ZZ - W1 * Z1 - X * Y
  7804.             DI = W * Z1 + W1 * ZZ - X1 * Y
  7805.             IF (DR .EQ. 0.0D0 .AND. DI .EQ. 0.0D0) DR = EPSB
  7806.             GO TO 775
  7807.   782       B(I+1,NA) = T1
  7808.             B(I+1,EN) = T2
  7809.             ISW = 1
  7810.             IF (DABS(Y) .GT. DABS(W) + DABS(W1)) GO TO 785
  7811.             TR = -RA - X * B(I+1,NA) + X1 * B(I+1,EN)
  7812.             TI = -SA - X * B(I+1,EN) - X1 * B(I+1,NA)
  7813.             GO TO 773
  7814.   785       T1 = (-R - ZZ * B(I+1,NA) + Z1 * B(I+1,EN)) / Y
  7815.             T2 = (-S - ZZ * B(I+1,EN) - Z1 * B(I+1,NA)) / Y
  7816.   787       B(I,NA) = T1
  7817.             B(I,EN) = T2
  7818.   790    CONTINUE
  7819. C     .......... END COMPLEX VECTOR ..........
  7820.   795    ISW = 3 - ISW
  7821.   800 CONTINUE
  7822. C     .......... END BACK SUBSTITUTION.
  7823. C                TRANSFORM TO ORIGINAL COORDINATE SYSTEM.
  7824. C                FOR J=N STEP -1 UNTIL 1 DO -- ..........
  7825.       DO 880 JJ = 1, N
  7826.          J = N + 1 - JJ
  7827. C
  7828.          DO 880 I = 1, N
  7829.             ZZ = 0.0D0
  7830. C
  7831.             DO 860 K = 1, J
  7832.   860       ZZ = ZZ + Z(I,K) * B(K,J)
  7833. C
  7834.             Z(I,J) = ZZ
  7835.   880 CONTINUE
  7836. C     .......... NORMALIZE SO THAT MODULUS OF LARGEST
  7837. C                COMPONENT OF EACH VECTOR IS 1.
  7838. C                (ISW IS 1 INITIALLY FROM BEFORE) ..........
  7839.       DO 950 J = 1, N
  7840.          D = 0.0D0
  7841.          IF (ISW .EQ. 2) GO TO 920
  7842.          IF (ALFI(J) .NE. 0.0D0) GO TO 945
  7843. C
  7844.          DO 890 I = 1, N
  7845.             IF (DABS(Z(I,J)) .GT. D) D = DABS(Z(I,J))
  7846.   890    CONTINUE
  7847. C
  7848.          DO 900 I = 1, N
  7849.   900    Z(I,J) = Z(I,J) / D
  7850. C
  7851.          GO TO 950
  7852. C
  7853.   920    DO 930 I = 1, N
  7854.             R = DABS(Z(I,J-1)) + DABS(Z(I,J))
  7855.             IF (R .NE. 0.0D0) R = R * DSQRT((Z(I,J-1)/R)**2
  7856.      X                                     +(Z(I,J)/R)**2)
  7857.             IF (R .GT. D) D = R
  7858.   930    CONTINUE
  7859. C
  7860.          DO 940 I = 1, N
  7861.             Z(I,J-1) = Z(I,J-1) / D
  7862.             Z(I,J) = Z(I,J) / D
  7863.   940    CONTINUE
  7864. C
  7865.   945    ISW = 3 - ISW
  7866.   950 CONTINUE
  7867. C
  7868.       RETURN
  7869.       END
  7870.       SUBROUTINE RATQR(N,EPS1,D,E,E2,M,W,IND,BD,TYPE,IDEF,IERR)
  7871. C
  7872.       INTEGER I,J,K,M,N,II,JJ,K1,IDEF,IERR,JDEF
  7873.       DOUBLE PRECISION D(N),E(N),E2(N),W(N),BD(N)
  7874.       DOUBLE PRECISION F,P,Q,R,S,EP,QP,ERR,TOT,EPS1,DELTA,EPSLON
  7875.       INTEGER IND(N)
  7876.       LOGICAL TYPE
  7877. C
  7878. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE RATQR,
  7879. C     NUM. MATH. 11, 264-272(1968) BY REINSCH AND BAUER.
  7880. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 257-265(1971).
  7881. C
  7882. C     THIS SUBROUTINE FINDS THE ALGEBRAICALLY SMALLEST OR LARGEST
  7883. C     EIGENVALUES OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE
  7884. C     RATIONAL QR METHOD WITH NEWTON CORRECTIONS.
  7885. C
  7886. C     ON INPUT
  7887. C
  7888. C        N IS THE ORDER OF THE MATRIX.
  7889. C
  7890. C        EPS1 IS A THEORETICAL ABSOLUTE ERROR TOLERANCE FOR THE
  7891. C          COMPUTED EIGENVALUES.  IF THE INPUT EPS1 IS NON-POSITIVE,
  7892. C          OR INDEED SMALLER THAN ITS DEFAULT VALUE, IT IS RESET
  7893. C          AT EACH ITERATION TO THE RESPECTIVE DEFAULT VALUE,
  7894. C          NAMELY, THE PRODUCT OF THE RELATIVE MACHINE PRECISION
  7895. C          AND THE MAGNITUDE OF THE CURRENT EIGENVALUE ITERATE.
  7896. C          THE THEORETICAL ABSOLUTE ERROR IN THE K-TH EIGENVALUE
  7897. C          IS USUALLY NOT GREATER THAN K TIMES EPS1.
  7898. C
  7899. C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
  7900. C
  7901. C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
  7902. C          IN ITS LAST N-1 POSITIONS.  E(1) IS ARBITRARY.
  7903. C
  7904. C        E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
  7905. C          E2(1) IS ARBITRARY.
  7906. C
  7907. C        M IS THE NUMBER OF EIGENVALUES TO BE FOUND.
  7908. C
  7909. C        IDEF SHOULD BE SET TO 1 IF THE INPUT MATRIX IS KNOWN TO BE
  7910. C          POSITIVE DEFINITE, TO -1 IF THE INPUT MATRIX IS KNOWN TO
  7911. C          BE NEGATIVE DEFINITE, AND TO 0 OTHERWISE.
  7912. C
  7913. C        TYPE SHOULD BE SET TO .TRUE. IF THE SMALLEST EIGENVALUES
  7914. C          ARE TO BE FOUND, AND TO .FALSE. IF THE LARGEST EIGENVALUES
  7915. C          ARE TO BE FOUND.
  7916. C
  7917. C     ON OUTPUT
  7918. C
  7919. C        EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS
  7920. C          (LAST) DEFAULT VALUE.
  7921. C
  7922. C        D AND E ARE UNALTERED (UNLESS W OVERWRITES D).
  7923. C
  7924. C        ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED
  7925. C          AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE
  7926. C          MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES.
  7927. C          E2(1) IS SET TO 0.0D0 IF THE SMALLEST EIGENVALUES HAVE BEEN
  7928. C          FOUND, AND TO 2.0D0 IF THE LARGEST EIGENVALUES HAVE BEEN
  7929. C          FOUND.  E2 IS OTHERWISE UNALTERED (UNLESS OVERWRITTEN BY BD).
  7930. C
  7931. C        W CONTAINS THE M ALGEBRAICALLY SMALLEST EIGENVALUES IN
  7932. C          ASCENDING ORDER, OR THE M LARGEST EIGENVALUES IN
  7933. C          DESCENDING ORDER.  IF AN ERROR EXIT IS MADE BECAUSE OF
  7934. C          AN INCORRECT SPECIFICATION OF IDEF, NO EIGENVALUES
  7935. C          ARE FOUND.  IF THE NEWTON ITERATES FOR A PARTICULAR
  7936. C          EIGENVALUE ARE NOT MONOTONE, THE BEST ESTIMATE OBTAINED
  7937. C          IS RETURNED AND IERR IS SET.  W MAY COINCIDE WITH D.
  7938. C
  7939. C        IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES
  7940. C          ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W --
  7941. C          1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM
  7942. C          THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC..
  7943. C
  7944. C        BD CONTAINS REFINED BOUNDS FOR THE THEORETICAL ERRORS OF THE
  7945. C          CORRESPONDING EIGENVALUES IN W.  THESE BOUNDS ARE USUALLY
  7946. C          WITHIN THE TOLERANCE SPECIFIED BY EPS1.  BD MAY COINCIDE
  7947. C          WITH E2.
  7948. C
  7949. C        IERR IS SET TO
  7950. C          ZERO       FOR NORMAL RETURN,
  7951. C          6*N+1      IF  IDEF  IS SET TO 1 AND  TYPE  TO .TRUE.
  7952. C                     WHEN THE MATRIX IS NOT POSITIVE DEFINITE, OR
  7953. C                     IF  IDEF  IS SET TO -1 AND  TYPE  TO .FALSE.
  7954. C                     WHEN THE MATRIX IS NOT NEGATIVE DEFINITE,
  7955. C          5*N+K      IF SUCCESSIVE ITERATES TO THE K-TH EIGENVALUE
  7956. C                     ARE NOT MONOTONE INCREASING, WHERE K REFERS
  7957. C                     TO THE LAST SUCH OCCURRENCE.
  7958. C
  7959. C     NOTE THAT SUBROUTINE TRIDIB IS GENERALLY FASTER AND MORE
  7960. C     ACCURATE THAN RATQR IF THE EIGENVALUES ARE CLUSTERED.
  7961. C
  7962. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  7963. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  7964. C
  7965. C     THIS VERSION DATED AUGUST 1983.
  7966. C
  7967. C     ------------------------------------------------------------------
  7968. C
  7969.       IERR = 0
  7970.       JDEF = IDEF
  7971. C     .......... COPY D ARRAY INTO W ..........
  7972.       DO 20 I = 1, N
  7973.    20 W(I) = D(I)
  7974. C
  7975.       IF (TYPE) GO TO 40
  7976.       J = 1
  7977.       GO TO 400
  7978.    40 ERR = 0.0D0
  7979.       S = 0.0D0
  7980. C     .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES AND DEFINE
  7981. C                INITIAL SHIFT FROM LOWER GERSCHGORIN BOUND.
  7982. C                COPY E2 ARRAY INTO BD ..........
  7983.       TOT = W(1)
  7984.       Q = 0.0D0
  7985.       J = 0
  7986. C
  7987.       DO 100 I = 1, N
  7988.          P = Q
  7989.          IF (I .EQ. 1) GO TO 60
  7990.          IF (P .GT. EPSLON(DABS(D(I)) + DABS(D(I-1)))) GO TO 80
  7991.    60    E2(I) = 0.0D0
  7992.    80    BD(I) = E2(I)
  7993. C     .......... COUNT ALSO IF ELEMENT OF E2 HAS UNDERFLOWED ..........
  7994.          IF (E2(I) .EQ. 0.0D0) J = J + 1
  7995.          IND(I) = J
  7996.          Q = 0.0D0
  7997.          IF (I .NE. N) Q = DABS(E(I+1))
  7998.          TOT = DMIN1(W(I)-P-Q,TOT)
  7999.   100 CONTINUE
  8000. C
  8001.       IF (JDEF .EQ. 1 .AND. TOT .LT. 0.0D0) GO TO 140
  8002. C
  8003.       DO 110 I = 1, N
  8004.   110 W(I) = W(I) - TOT
  8005. C
  8006.       GO TO 160
  8007.   140 TOT = 0.0D0
  8008. C
  8009.   160 DO 360 K = 1, M
  8010. C     .......... NEXT QR TRANSFORMATION ..........
  8011.   180    TOT = TOT + S
  8012.          DELTA = W(N) - S
  8013.          I = N
  8014.          F = DABS(EPSLON(TOT))
  8015.          IF (EPS1 .LT. F) EPS1 = F
  8016.          IF (DELTA .GT. EPS1) GO TO 190
  8017.          IF (DELTA .LT. (-EPS1)) GO TO 1000
  8018.          GO TO 300
  8019. C     .......... REPLACE SMALL SUB-DIAGONAL SQUARES BY ZERO
  8020. C                TO REDUCE THE INCIDENCE OF UNDERFLOWS ..........
  8021.   190    IF (K .EQ. N) GO TO 210
  8022.          K1 = K + 1
  8023.          DO 200 J = K1, N
  8024.             IF (BD(J) .LE. (EPSLON(W(J)+W(J-1))) ** 2) BD(J) = 0.0D0
  8025.   200    CONTINUE
  8026. C
  8027.   210    F = BD(N) / DELTA
  8028.          QP = DELTA + F
  8029.          P = 1.0D0
  8030.          IF (K .EQ. N) GO TO 260
  8031.          K1 = N - K
  8032. C     .......... FOR I=N-1 STEP -1 UNTIL K DO -- ..........
  8033.          DO 240 II = 1, K1
  8034.             I = N - II
  8035.             Q = W(I) - S - F
  8036.             R = Q / QP
  8037.             P = P * R + 1.0D0
  8038.             EP = F * R
  8039.             W(I+1) = QP + EP
  8040.             DELTA = Q - EP
  8041.             IF (DELTA .GT. EPS1) GO TO 220
  8042.             IF (DELTA .LT. (-EPS1)) GO TO 1000
  8043.             GO TO 300
  8044.   220       F = BD(I) / Q
  8045.             QP = DELTA + F
  8046.             BD(I+1) = QP * EP
  8047.   240    CONTINUE
  8048. C
  8049.   260    W(K) = QP
  8050.          S = QP / P
  8051.          IF (TOT + S .GT. TOT) GO TO 180
  8052. C     .......... SET ERROR -- IRREGULAR END OF ITERATION.
  8053. C                DEFLATE MINIMUM DIAGONAL ELEMENT ..........
  8054.          IERR = 5 * N + K
  8055.          S = 0.0D0
  8056.          DELTA = QP
  8057. C
  8058.          DO 280 J = K, N
  8059.             IF (W(J) .GT. DELTA) GO TO 280
  8060.             I = J
  8061.             DELTA = W(J)
  8062.   280    CONTINUE
  8063. C     .......... CONVERGENCE ..........
  8064.   300    IF (I .LT. N) BD(I+1) = BD(I) * F / QP
  8065.          II = IND(I)
  8066.          IF (I .EQ. K) GO TO 340
  8067.          K1 = I - K
  8068. C     .......... FOR J=I-1 STEP -1 UNTIL K DO -- ..........
  8069.          DO 320 JJ = 1, K1
  8070.             J = I - JJ
  8071.             W(J+1) = W(J) - S
  8072.             BD(J+1) = BD(J)
  8073.             IND(J+1) = IND(J)
  8074.   320    CONTINUE
  8075. C
  8076.   340    W(K) = TOT
  8077.          ERR = ERR + DABS(DELTA)
  8078.          BD(K) = ERR
  8079.          IND(K) = II
  8080.   360 CONTINUE
  8081. C
  8082.       IF (TYPE) GO TO 1001
  8083.       F = BD(1)
  8084.       E2(1) = 2.0D0
  8085.       BD(1) = F
  8086.       J = 2
  8087. C     .......... NEGATE ELEMENTS OF W FOR LARGEST VALUES ..........
  8088.   400 DO 500 I = 1, N
  8089.   500 W(I) = -W(I)
  8090. C
  8091.       JDEF = -JDEF
  8092.       GO TO (40,1001), J
  8093. C     .......... SET ERROR -- IDEF SPECIFIED INCORRECTLY ..........
  8094.  1000 IERR = 6 * N + 1
  8095.  1001 RETURN
  8096.       END
  8097.       SUBROUTINE REBAK(NM,N,B,DL,M,Z)
  8098. C
  8099.       INTEGER I,J,K,M,N,I1,II,NM
  8100.       DOUBLE PRECISION B(NM,N),DL(N),Z(NM,M)
  8101.       DOUBLE PRECISION X
  8102. C
  8103. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE REBAKA,
  8104. C     NUM. MATH. 11, 99-110(1968) BY MARTIN AND WILKINSON.
  8105. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971).
  8106. C
  8107. C     THIS SUBROUTINE FORMS THE EIGENVECTORS OF A GENERALIZED
  8108. C     SYMMETRIC EIGENSYSTEM BY BACK TRANSFORMING THOSE OF THE
  8109. C     DERIVED SYMMETRIC MATRIX DETERMINED BY  REDUC.
  8110. C
  8111. C     ON INPUT
  8112. C
  8113. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  8114. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  8115. C          DIMENSION STATEMENT.
  8116. C
  8117. C        N IS THE ORDER OF THE MATRIX SYSTEM.
  8118. C
  8119. C        B CONTAINS INFORMATION ABOUT THE SIMILARITY TRANSFORMATION
  8120. C          (CHOLESKY DECOMPOSITION) USED IN THE REDUCTION BY  REDUC
  8121. C          IN ITS STRICT LOWER TRIANGLE.
  8122. C
  8123. C        DL CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATION.
  8124. C
  8125. C        M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
  8126. C
  8127. C        Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED
  8128. C          IN ITS FIRST M COLUMNS.
  8129. C
  8130. C     ON OUTPUT
  8131. C
  8132. C        Z CONTAINS THE TRANSFORMED EIGENVECTORS
  8133. C          IN ITS FIRST M COLUMNS.
  8134. C
  8135. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  8136. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  8137. C
  8138. C     THIS VERSION DATED AUGUST 1983.
  8139. C
  8140. C     ------------------------------------------------------------------
  8141. C
  8142.       IF (M .EQ. 0) GO TO 200
  8143. C
  8144.       DO 100 J = 1, M
  8145. C     .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
  8146.          DO 100 II = 1, N
  8147.             I = N + 1 - II
  8148.             I1 = I + 1
  8149.             X = Z(I,J)
  8150.             IF (I .EQ. N) GO TO 80
  8151. C
  8152.             DO 60 K = I1, N
  8153.    60       X = X - B(K,I) * Z(K,J)
  8154. C
  8155.    80       Z(I,J) = X / DL(I)
  8156.   100 CONTINUE
  8157. C
  8158.   200 RETURN
  8159.       END
  8160.       SUBROUTINE REBAKB(NM,N,B,DL,M,Z)
  8161. C
  8162.       INTEGER I,J,K,M,N,I1,II,NM
  8163.       DOUBLE PRECISION B(NM,N),DL(N),Z(NM,M)
  8164.       DOUBLE PRECISION X
  8165. C
  8166. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE REBAKB,
  8167. C     NUM. MATH. 11, 99-110(1968) BY MARTIN AND WILKINSON.
  8168. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971).
  8169. C
  8170. C     THIS SUBROUTINE FORMS THE EIGENVECTORS OF A GENERALIZED
  8171. C     SYMMETRIC EIGENSYSTEM BY BACK TRANSFORMING THOSE OF THE
  8172. C     DERIVED SYMMETRIC MATRIX DETERMINED BY  REDUC2.
  8173. C
  8174. C     ON INPUT
  8175. C
  8176. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  8177. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  8178. C          DIMENSION STATEMENT.
  8179. C
  8180. C        N IS THE ORDER OF THE MATRIX SYSTEM.
  8181. C
  8182. C        B CONTAINS INFORMATION ABOUT THE SIMILARITY TRANSFORMATION
  8183. C          (CHOLESKY DECOMPOSITION) USED IN THE REDUCTION BY  REDUC2
  8184. C          IN ITS STRICT LOWER TRIANGLE.
  8185. C
  8186. C        DL CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATION.
  8187. C
  8188. C        M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
  8189. C
  8190. C        Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED
  8191. C          IN ITS FIRST M COLUMNS.
  8192. C
  8193. C     ON OUTPUT
  8194. C
  8195. C        Z CONTAINS THE TRANSFORMED EIGENVECTORS
  8196. C          IN ITS FIRST M COLUMNS.
  8197. C
  8198. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  8199. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  8200. C
  8201. C     THIS VERSION DATED AUGUST 1983.
  8202. C
  8203. C     ------------------------------------------------------------------
  8204. C
  8205.       IF (M .EQ. 0) GO TO 200
  8206. C
  8207.       DO 100 J = 1, M
  8208. C     .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
  8209.          DO 100 II = 1, N
  8210.             I1 = N - II
  8211.             I = I1 + 1
  8212.             X = DL(I) * Z(I,J)
  8213.             IF (I .EQ. 1) GO TO 80
  8214. C
  8215.             DO 60 K = 1, I1
  8216.    60       X = X + B(I,K) * Z(K,J)
  8217. C
  8218.    80       Z(I,J) = X
  8219.   100 CONTINUE
  8220. C
  8221.   200 RETURN
  8222.       END
  8223.       SUBROUTINE REDUC(NM,N,A,B,DL,IERR)
  8224. C
  8225.       INTEGER I,J,K,N,I1,J1,NM,NN,IERR
  8226.       DOUBLE PRECISION A(NM,N),B(NM,N),DL(N)
  8227.       DOUBLE PRECISION X,Y
  8228. C
  8229. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE REDUC1,
  8230. C     NUM. MATH. 11, 99-110(1968) BY MARTIN AND WILKINSON.
  8231. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971).
  8232. C
  8233. C     THIS SUBROUTINE REDUCES THE GENERALIZED SYMMETRIC EIGENPROBLEM
  8234. C     AX=(LAMBDA)BX, WHERE B IS POSITIVE DEFINITE, TO THE STANDARD
  8235. C     SYMMETRIC EIGENPROBLEM USING THE CHOLESKY FACTORIZATION OF B.
  8236. C
  8237. C     ON INPUT
  8238. C
  8239. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  8240. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  8241. C          DIMENSION STATEMENT.
  8242. C
  8243. C        N IS THE ORDER OF THE MATRICES A AND B.  IF THE CHOLESKY
  8244. C          FACTOR L OF B IS ALREADY AVAILABLE, N SHOULD BE PREFIXED
  8245. C          WITH A MINUS SIGN.
  8246. C
  8247. C        A AND B CONTAIN THE REAL SYMMETRIC INPUT MATRICES.  ONLY THE
  8248. C          FULL UPPER TRIANGLES OF THE MATRICES NEED BE SUPPLIED.  IF
  8249. C          N IS NEGATIVE, THE STRICT LOWER TRIANGLE OF B CONTAINS,
  8250. C          INSTEAD, THE STRICT LOWER TRIANGLE OF ITS CHOLESKY FACTOR L.
  8251. C
  8252. C        DL CONTAINS, IF N IS NEGATIVE, THE DIAGONAL ELEMENTS OF L.
  8253. C
  8254. C     ON OUTPUT
  8255. C
  8256. C        A CONTAINS IN ITS FULL LOWER TRIANGLE THE FULL LOWER TRIANGLE
  8257. C          OF THE SYMMETRIC MATRIX DERIVED FROM THE REDUCTION TO THE
  8258. C          STANDARD FORM.  THE STRICT UPPER TRIANGLE OF A IS UNALTERED.
  8259. C
  8260. C        B CONTAINS IN ITS STRICT LOWER TRIANGLE THE STRICT LOWER
  8261. C          TRIANGLE OF ITS CHOLESKY FACTOR L.  THE FULL UPPER
  8262. C          TRIANGLE OF B IS UNALTERED.
  8263. C
  8264. C        DL CONTAINS THE DIAGONAL ELEMENTS OF L.
  8265. C
  8266. C        IERR IS SET TO
  8267. C          ZERO       FOR NORMAL RETURN,
  8268. C          7*N+1      IF B IS NOT POSITIVE DEFINITE.
  8269. C
  8270. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  8271. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  8272. C
  8273. C     THIS VERSION DATED AUGUST 1983.
  8274. C
  8275. C     ------------------------------------------------------------------
  8276. C
  8277.       IERR = 0
  8278.       NN = IABS(N)
  8279.       IF (N .LT. 0) GO TO 100
  8280. C     .......... FORM L IN THE ARRAYS B AND DL ..........
  8281.       DO 80 I = 1, N
  8282.          I1 = I - 1
  8283. C
  8284.          DO 80 J = I, N
  8285.             X = B(I,J)
  8286.             IF (I .EQ. 1) GO TO 40
  8287. C
  8288.             DO 20 K = 1, I1
  8289.    20       X = X - B(I,K) * B(J,K)
  8290. C
  8291.    40       IF (J .NE. I) GO TO 60
  8292.             IF (X .LE. 0.0D0) GO TO 1000
  8293.             Y = DSQRT(X)
  8294.             DL(I) = Y
  8295.             GO TO 80
  8296.    60       B(J,I) = X / Y
  8297.    80 CONTINUE
  8298. C     .......... FORM THE TRANSPOSE OF THE UPPER TRIANGLE OF INV(L)*A
  8299. C                IN THE LOWER TRIANGLE OF THE ARRAY A ..........
  8300.   100 DO 200 I = 1, NN
  8301.          I1 = I - 1
  8302.          Y = DL(I)
  8303. C
  8304.          DO 200 J = I, NN
  8305.             X = A(I,J)
  8306.             IF (I .EQ. 1) GO TO 180
  8307. C
  8308.             DO 160 K = 1, I1
  8309.   160       X = X - B(I,K) * A(J,K)
  8310. C
  8311.   180       A(J,I) = X / Y
  8312.   200 CONTINUE
  8313. C     .......... PRE-MULTIPLY BY INV(L) AND OVERWRITE ..........
  8314.       DO 300 J = 1, NN
  8315.          J1 = J - 1
  8316. C
  8317.          DO 300 I = J, NN
  8318.             X = A(I,J)
  8319.             IF (I .EQ. J) GO TO 240
  8320.             I1 = I - 1
  8321. C
  8322.             DO 220 K = J, I1
  8323.   220       X = X - A(K,J) * B(I,K)
  8324. C
  8325.   240       IF (J .EQ. 1) GO TO 280
  8326. C
  8327.             DO 260 K = 1, J1
  8328.   260       X = X - A(J,K) * B(I,K)
  8329. C
  8330.   280       A(I,J) = X / DL(I)
  8331.   300 CONTINUE
  8332. C
  8333.       GO TO 1001
  8334. C     .......... SET ERROR -- B IS NOT POSITIVE DEFINITE ..........
  8335.  1000 IERR = 7 * N + 1
  8336.  1001 RETURN
  8337.       END
  8338.       SUBROUTINE REDUC2(NM,N,A,B,DL,IERR)
  8339. C
  8340.       INTEGER I,J,K,N,I1,J1,NM,NN,IERR
  8341.       DOUBLE PRECISION A(NM,N),B(NM,N),DL(N)
  8342.       DOUBLE PRECISION X,Y
  8343. C
  8344. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE REDUC2,
  8345. C     NUM. MATH. 11, 99-110(1968) BY MARTIN AND WILKINSON.
  8346. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971).
  8347. C
  8348. C     THIS SUBROUTINE REDUCES THE GENERALIZED SYMMETRIC EIGENPROBLEMS
  8349. C     ABX=(LAMBDA)X OR BAY=(LAMBDA)Y, WHERE B IS POSITIVE DEFINITE,
  8350. C     TO THE STANDARD SYMMETRIC EIGENPROBLEM USING THE CHOLESKY
  8351. C     FACTORIZATION OF B.
  8352. C
  8353. C     ON INPUT
  8354. C
  8355. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  8356. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  8357. C          DIMENSION STATEMENT.
  8358. C
  8359. C        N IS THE ORDER OF THE MATRICES A AND B.  IF THE CHOLESKY
  8360. C          FACTOR L OF B IS ALREADY AVAILABLE, N SHOULD BE PREFIXED
  8361. C          WITH A MINUS SIGN.
  8362. C
  8363. C        A AND B CONTAIN THE REAL SYMMETRIC INPUT MATRICES.  ONLY THE
  8364. C          FULL UPPER TRIANGLES OF THE MATRICES NEED BE SUPPLIED.  IF
  8365. C          N IS NEGATIVE, THE STRICT LOWER TRIANGLE OF B CONTAINS,
  8366. C          INSTEAD, THE STRICT LOWER TRIANGLE OF ITS CHOLESKY FACTOR L.
  8367. C
  8368. C        DL CONTAINS, IF N IS NEGATIVE, THE DIAGONAL ELEMENTS OF L.
  8369. C
  8370. C     ON OUTPUT
  8371. C
  8372. C        A CONTAINS IN ITS FULL LOWER TRIANGLE THE FULL LOWER TRIANGLE
  8373. C          OF THE SYMMETRIC MATRIX DERIVED FROM THE REDUCTION TO THE
  8374. C          STANDARD FORM.  THE STRICT UPPER TRIANGLE OF A IS UNALTERED.
  8375. C
  8376. C        B CONTAINS IN ITS STRICT LOWER TRIANGLE THE STRICT LOWER
  8377. C          TRIANGLE OF ITS CHOLESKY FACTOR L.  THE FULL UPPER
  8378. C          TRIANGLE OF B IS UNALTERED.
  8379. C
  8380. C        DL CONTAINS THE DIAGONAL ELEMENTS OF L.
  8381. C
  8382. C        IERR IS SET TO
  8383. C          ZERO       FOR NORMAL RETURN,
  8384. C          7*N+1      IF B IS NOT POSITIVE DEFINITE.
  8385. C
  8386. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  8387. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  8388. C
  8389. C     THIS VERSION DATED AUGUST 1983.
  8390. C
  8391. C     ------------------------------------------------------------------
  8392. C
  8393.       IERR = 0
  8394.       NN = IABS(N)
  8395.       IF (N .LT. 0) GO TO 100
  8396. C     .......... FORM L IN THE ARRAYS B AND DL ..........
  8397.       DO 80 I = 1, N
  8398.          I1 = I - 1
  8399. C
  8400.          DO 80 J = I, N
  8401.             X = B(I,J)
  8402.             IF (I .EQ. 1) GO TO 40
  8403. C
  8404.             DO 20 K = 1, I1
  8405.    20       X = X - B(I,K) * B(J,K)
  8406. C
  8407.    40       IF (J .NE. I) GO TO 60
  8408.             IF (X .LE. 0.0D0) GO TO 1000
  8409.             Y = DSQRT(X)
  8410.             DL(I) = Y
  8411.             GO TO 80
  8412.    60       B(J,I) = X / Y
  8413.    80 CONTINUE
  8414. C     .......... FORM THE LOWER TRIANGLE OF A*L
  8415. C                IN THE LOWER TRIANGLE OF THE ARRAY A ..........
  8416.   100 DO 200 I = 1, NN
  8417.          I1 = I + 1
  8418. C
  8419.          DO 200 J = 1, I
  8420.             X = A(J,I) * DL(J)
  8421.             IF (J .EQ. I) GO TO 140
  8422.             J1 = J + 1
  8423. C
  8424.             DO 120 K = J1, I
  8425.   120       X = X + A(K,I) * B(K,J)
  8426. C
  8427.   140       IF (I .EQ. NN) GO TO 180
  8428. C
  8429.             DO 160 K = I1, NN
  8430.   160       X = X + A(I,K) * B(K,J)
  8431. C
  8432.   180       A(I,J) = X
  8433.   200 CONTINUE
  8434. C     .......... PRE-MULTIPLY BY TRANSPOSE(L) AND OVERWRITE ..........
  8435.       DO 300 I = 1, NN
  8436.          I1 = I + 1
  8437.          Y = DL(I)
  8438. C
  8439.          DO 300 J = 1, I
  8440.             X = Y * A(I,J)
  8441.             IF (I .EQ. NN) GO TO 280
  8442. C
  8443.             DO 260 K = I1, NN
  8444.   260       X = X + A(K,J) * B(K,I)
  8445. C
  8446.   280       A(I,J) = X
  8447.   300 CONTINUE
  8448. C
  8449.       GO TO 1001
  8450. C     .......... SET ERROR -- B IS NOT POSITIVE DEFINITE ..........
  8451.  1000 IERR = 7 * N + 1
  8452.  1001 RETURN
  8453.       END
  8454.       SUBROUTINE RG(NM,N,A,WR,WI,MATZ,Z,IV1,FV1,IERR)
  8455. C
  8456.       INTEGER N,NM,IS1,IS2,IERR,MATZ
  8457.       DOUBLE PRECISION A(NM,N),WR(N),WI(N),Z(NM,N),FV1(N)
  8458.       INTEGER IV1(N)
  8459. C
  8460. C     THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
  8461. C     SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
  8462. C     TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
  8463. C     OF A REAL GENERAL MATRIX.
  8464. C
  8465. C     ON INPUT
  8466. C
  8467. C        NM  MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
  8468. C        ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  8469. C        DIMENSION STATEMENT.
  8470. C
  8471. C        N  IS THE ORDER OF THE MATRIX  A.
  8472. C
  8473. C        A  CONTAINS THE REAL GENERAL MATRIX.
  8474. C
  8475. C        MATZ  IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
  8476. C        ONLY EIGENVALUES ARE DESIRED.  OTHERWISE IT IS SET TO
  8477. C        ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
  8478. C
  8479. C     ON OUTPUT
  8480. C
  8481. C        WR  AND  WI  CONTAIN THE REAL AND IMAGINARY PARTS,
  8482. C        RESPECTIVELY, OF THE EIGENVALUES.  COMPLEX CONJUGATE
  8483. C        PAIRS OF EIGENVALUES APPEAR CONSECUTIVELY WITH THE
  8484. C        EIGENVALUE HAVING THE POSITIVE IMAGINARY PART FIRST.
  8485. C
  8486. C        Z  CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS
  8487. C        IF MATZ IS NOT ZERO.  IF THE J-TH EIGENVALUE IS REAL, THE
  8488. C        J-TH COLUMN OF  Z  CONTAINS ITS EIGENVECTOR.  IF THE J-TH
  8489. C        EIGENVALUE IS COMPLEX WITH POSITIVE IMAGINARY PART, THE
  8490. C        J-TH AND (J+1)-TH COLUMNS OF  Z  CONTAIN THE REAL AND
  8491. C        IMAGINARY PARTS OF ITS EIGENVECTOR.  THE CONJUGATE OF THIS
  8492. C        VECTOR IS THE EIGENVECTOR FOR THE CONJUGATE EIGENVALUE.
  8493. C
  8494. C        IERR  IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
  8495. C           COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR HQR
  8496. C           AND HQR2.  THE NORMAL COMPLETION CODE IS ZERO.
  8497. C
  8498. C        IV1  AND  FV1  ARE TEMPORARY STORAGE ARRAYS.
  8499. C
  8500. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  8501. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  8502. C
  8503. C     THIS VERSION DATED AUGUST 1983.
  8504. C
  8505. C     ------------------------------------------------------------------
  8506. C
  8507.       IF (N .LE. NM) GO TO 10
  8508.       IERR = 10 * N
  8509.       GO TO 50
  8510. C
  8511.    10 CALL  BALANC(NM,N,A,IS1,IS2,FV1)
  8512.       CALL  ELMHES(NM,N,IS1,IS2,A,IV1)
  8513.       IF (MATZ .NE. 0) GO TO 20
  8514. C     .......... FIND EIGENVALUES ONLY ..........
  8515.       CALL  HQR(NM,N,IS1,IS2,A,WR,WI,IERR)
  8516.       GO TO 50
  8517. C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
  8518.    20 CALL  ELTRAN(NM,N,IS1,IS2,A,IV1,Z)
  8519.       CALL  HQR2(NM,N,IS1,IS2,A,WR,WI,Z,IERR)
  8520.       IF (IERR .NE. 0) GO TO 50
  8521.       CALL  BALBAK(NM,N,IS1,IS2,FV1,N,Z)
  8522.    50 RETURN
  8523.       END
  8524.       SUBROUTINE RGG(NM,N,A,B,ALFR,ALFI,BETA,MATZ,Z,IERR)
  8525. C
  8526.       INTEGER N,NM,IERR,MATZ
  8527.       DOUBLE PRECISION A(NM,N),B(NM,N),ALFR(N),ALFI(N),BETA(N),Z(NM,N)
  8528.       LOGICAL TF
  8529. C
  8530. C     THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
  8531. C     SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
  8532. C     TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
  8533. C     FOR THE REAL GENERAL GENERALIZED EIGENPROBLEM  AX = (LAMBDA)BX.
  8534. C
  8535. C     ON INPUT
  8536. C
  8537. C        NM  MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
  8538. C        ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  8539. C        DIMENSION STATEMENT.
  8540. C
  8541. C        N  IS THE ORDER OF THE MATRICES  A  AND  B.
  8542. C
  8543. C        A  CONTAINS A REAL GENERAL MATRIX.
  8544. C
  8545. C        B  CONTAINS A REAL GENERAL MATRIX.
  8546. C
  8547. C        MATZ  IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
  8548. C        ONLY EIGENVALUES ARE DESIRED.  OTHERWISE IT IS SET TO
  8549. C        ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
  8550. C
  8551. C     ON OUTPUT
  8552. C
  8553. C        ALFR  AND  ALFI  CONTAIN THE REAL AND IMAGINARY PARTS,
  8554. C        RESPECTIVELY, OF THE NUMERATORS OF THE EIGENVALUES.
  8555. C
  8556. C        BETA  CONTAINS THE DENOMINATORS OF THE EIGENVALUES,
  8557. C        WHICH ARE THUS GIVEN BY THE RATIOS  (ALFR+I*ALFI)/BETA.
  8558. C        COMPLEX CONJUGATE PAIRS OF EIGENVALUES APPEAR CONSECUTIVELY
  8559. C        WITH THE EIGENVALUE HAVING THE POSITIVE IMAGINARY PART FIRST.
  8560. C
  8561. C        Z  CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS
  8562. C        IF MATZ IS NOT ZERO.  IF THE J-TH EIGENVALUE IS REAL, THE
  8563. C        J-TH COLUMN OF  Z  CONTAINS ITS EIGENVECTOR.  IF THE J-TH
  8564. C        EIGENVALUE IS COMPLEX WITH POSITIVE IMAGINARY PART, THE
  8565. C        J-TH AND (J+1)-TH COLUMNS OF  Z  CONTAIN THE REAL AND
  8566. C        IMAGINARY PARTS OF ITS EIGENVECTOR.  THE CONJUGATE OF THIS
  8567. C        VECTOR IS THE EIGENVECTOR FOR THE CONJUGATE EIGENVALUE.
  8568. C
  8569. C        IERR  IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
  8570. C           COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR QZIT.
  8571. C           THE NORMAL COMPLETION CODE IS ZERO.
  8572. C
  8573. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  8574. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  8575. C
  8576. C     THIS VERSION DATED AUGUST 1983.
  8577. C
  8578. C     ------------------------------------------------------------------
  8579. C
  8580.       IF (N .LE. NM) GO TO 10
  8581.       IERR = 10 * N
  8582.       GO TO 50
  8583. C
  8584.    10 IF (MATZ .NE. 0) GO TO 20
  8585. C     .......... FIND EIGENVALUES ONLY ..........
  8586.       TF = .FALSE.
  8587.       CALL  QZHES(NM,N,A,B,TF,Z)
  8588.       CALL  QZIT(NM,N,A,B,0.0D0,TF,Z,IERR)
  8589.       CALL  QZVAL(NM,N,A,B,ALFR,ALFI,BETA,TF,Z)
  8590.       GO TO 50
  8591. C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
  8592.    20 TF = .TRUE.
  8593.       CALL  QZHES(NM,N,A,B,TF,Z)
  8594.       CALL  QZIT(NM,N,A,B,0.0D0,TF,Z,IERR)
  8595.       CALL  QZVAL(NM,N,A,B,ALFR,ALFI,BETA,TF,Z)
  8596.       IF (IERR .NE. 0) GO TO 50
  8597.       CALL  QZVEC(NM,N,A,B,ALFR,ALFI,BETA,Z)
  8598.    50 RETURN
  8599.       END
  8600.       SUBROUTINE RS(NM,N,A,W,MATZ,Z,FV1,FV2,IERR)
  8601. C
  8602.       INTEGER N,NM,IERR,MATZ
  8603.       DOUBLE PRECISION A(NM,N),W(N),Z(NM,N),FV1(N),FV2(N)
  8604. C
  8605. C     THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
  8606. C     SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
  8607. C     TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
  8608. C     OF A REAL SYMMETRIC MATRIX.
  8609. C
  8610. C     ON INPUT
  8611. C
  8612. C        NM  MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
  8613. C        ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  8614. C        DIMENSION STATEMENT.
  8615. C
  8616. C        N  IS THE ORDER OF THE MATRIX  A.
  8617. C
  8618. C        A  CONTAINS THE REAL SYMMETRIC MATRIX.
  8619. C
  8620. C        MATZ  IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
  8621. C        ONLY EIGENVALUES ARE DESIRED.  OTHERWISE IT IS SET TO
  8622. C        ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
  8623. C
  8624. C     ON OUTPUT
  8625. C
  8626. C        W  CONTAINS THE EIGENVALUES IN ASCENDING ORDER.
  8627. C
  8628. C        Z  CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO.
  8629. C
  8630. C        IERR  IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
  8631. C           COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT
  8632. C           AND TQL2.  THE NORMAL COMPLETION CODE IS ZERO.
  8633. C
  8634. C        FV1  AND  FV2  ARE TEMPORARY STORAGE ARRAYS.
  8635. C
  8636. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  8637. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  8638. C
  8639. C     THIS VERSION DATED AUGUST 1983.
  8640. C
  8641. C     ------------------------------------------------------------------
  8642. C
  8643.       IF (N .LE. NM) GO TO 10
  8644.       IERR = 10 * N
  8645.       GO TO 50
  8646. C
  8647.    10 IF (MATZ .NE. 0) GO TO 20
  8648. C     .......... FIND EIGENVALUES ONLY ..........
  8649.       CALL  TRED1(NM,N,A,W,FV1,FV2)
  8650.       CALL  TQLRAT(N,W,FV2,IERR)
  8651.       GO TO 50
  8652. C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
  8653.    20 CALL  TRED2(NM,N,A,W,FV1,Z)
  8654.       CALL  TQL2(NM,N,W,FV1,Z,IERR)
  8655.    50 RETURN
  8656.       END
  8657.       SUBROUTINE RSB(NM,N,MB,A,W,MATZ,Z,FV1,FV2,IERR)
  8658. C
  8659.       INTEGER N,MB,NM,IERR,MATZ
  8660.       DOUBLE PRECISION A(NM,MB),W(N),Z(NM,N),FV1(N),FV2(N)
  8661.       LOGICAL TF
  8662. C
  8663. C     THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
  8664. C     SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
  8665. C     TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
  8666. C     OF A REAL SYMMETRIC BAND MATRIX.
  8667. C
  8668. C     ON INPUT
  8669. C
  8670. C        NM  MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
  8671. C        ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  8672. C        DIMENSION STATEMENT.
  8673. C
  8674. C        N  IS THE ORDER OF THE MATRIX  A.
  8675. C
  8676. C        MB  IS THE HALF BAND WIDTH OF THE MATRIX, DEFINED AS THE
  8677. C        NUMBER OF ADJACENT DIAGONALS, INCLUDING THE PRINCIPAL
  8678. C        DIAGONAL, REQUIRED TO SPECIFY THE NON-ZERO PORTION OF THE
  8679. C        LOWER TRIANGLE OF THE MATRIX.
  8680. C
  8681. C        A  CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC
  8682. C        BAND MATRIX.  ITS LOWEST SUBDIAGONAL IS STORED IN THE
  8683. C        LAST  N+1-MB  POSITIONS OF THE FIRST COLUMN, ITS NEXT
  8684. C        SUBDIAGONAL IN THE LAST  N+2-MB  POSITIONS OF THE
  8685. C        SECOND COLUMN, FURTHER SUBDIAGONALS SIMILARLY, AND
  8686. C        FINALLY ITS PRINCIPAL DIAGONAL IN THE  N  POSITIONS
  8687. C        OF THE LAST COLUMN.  CONTENTS OF STORAGES NOT PART
  8688. C        OF THE MATRIX ARE ARBITRARY.
  8689. C
  8690. C        MATZ  IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
  8691. C        ONLY EIGENVALUES ARE DESIRED.  OTHERWISE IT IS SET TO
  8692. C        ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
  8693. C
  8694. C     ON OUTPUT
  8695. C
  8696. C        W  CONTAINS THE EIGENVALUES IN ASCENDING ORDER.
  8697. C
  8698. C        Z  CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO.
  8699. C
  8700. C        IERR  IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
  8701. C           COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT
  8702. C           AND TQL2.  THE NORMAL COMPLETION CODE IS ZERO.
  8703. C
  8704. C        FV1  AND  FV2  ARE TEMPORARY STORAGE ARRAYS.
  8705. C
  8706. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  8707. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  8708. C
  8709. C     THIS VERSION DATED AUGUST 1983.
  8710. C
  8711. C     ------------------------------------------------------------------
  8712. C
  8713.       IF (N .LE. NM) GO TO 5
  8714.       IERR = 10 * N
  8715.       GO TO 50
  8716.     5 IF (MB .GT. 0) GO TO 10
  8717.       IERR = 12 * N
  8718.       GO TO 50
  8719.    10 IF (MB .LE. N) GO TO 15
  8720.       IERR = 12 * N
  8721.       GO TO 50
  8722. C
  8723.    15 IF (MATZ .NE. 0) GO TO 20
  8724. C     .......... FIND EIGENVALUES ONLY ..........
  8725.       TF = .FALSE.
  8726.       CALL  BANDR(NM,N,MB,A,W,FV1,FV2,TF,Z)
  8727.       CALL  TQLRAT(N,W,FV2,IERR)
  8728.       GO TO 50
  8729. C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
  8730.    20 TF = .TRUE.
  8731.       CALL  BANDR(NM,N,MB,A,W,FV1,FV1,TF,Z)
  8732.       CALL  TQL2(NM,N,W,FV1,Z,IERR)
  8733.    50 RETURN
  8734.       END
  8735.       SUBROUTINE RSG(NM,N,A,B,W,MATZ,Z,FV1,FV2,IERR)
  8736. C
  8737.       INTEGER N,NM,IERR,MATZ
  8738.       DOUBLE PRECISION A(NM,N),B(NM,N),W(N),Z(NM,N),FV1(N),FV2(N)
  8739. C
  8740. C     THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
  8741. C     SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
  8742. C     TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
  8743. C     FOR THE REAL SYMMETRIC GENERALIZED EIGENPROBLEM  AX = (LAMBDA)BX.
  8744. C
  8745. C     ON INPUT
  8746. C
  8747. C        NM  MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
  8748. C        ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  8749. C        DIMENSION STATEMENT.
  8750. C
  8751. C        N  IS THE ORDER OF THE MATRICES  A  AND  B.
  8752. C
  8753. C        A  CONTAINS A REAL SYMMETRIC MATRIX.
  8754. C
  8755. C        B  CONTAINS A POSITIVE DEFINITE REAL SYMMETRIC MATRIX.
  8756. C
  8757. C        MATZ  IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
  8758. C        ONLY EIGENVALUES ARE DESIRED.  OTHERWISE IT IS SET TO
  8759. C        ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
  8760. C
  8761. C     ON OUTPUT
  8762. C
  8763. C        W  CONTAINS THE EIGENVALUES IN ASCENDING ORDER.
  8764. C
  8765. C        Z  CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO.
  8766. C
  8767. C        IERR  IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
  8768. C           COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT
  8769. C           AND TQL2.  THE NORMAL COMPLETION CODE IS ZERO.
  8770. C
  8771. C        FV1  AND  FV2  ARE TEMPORARY STORAGE ARRAYS.
  8772. C
  8773. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  8774. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  8775. C
  8776. C     THIS VERSION DATED AUGUST 1983.
  8777. C
  8778. C     ------------------------------------------------------------------
  8779. C
  8780.       IF (N .LE. NM) GO TO 10
  8781.       IERR = 10 * N
  8782.       GO TO 50
  8783. C
  8784.    10 CALL  REDUC(NM,N,A,B,FV2,IERR)
  8785.       IF (IERR .NE. 0) GO TO 50
  8786.       IF (MATZ .NE. 0) GO TO 20
  8787. C     .......... FIND EIGENVALUES ONLY ..........
  8788.       CALL  TRED1(NM,N,A,W,FV1,FV2)
  8789.       CALL  TQLRAT(N,W,FV2,IERR)
  8790.       GO TO 50
  8791. C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
  8792.    20 CALL  TRED2(NM,N,A,W,FV1,Z)
  8793.       CALL  TQL2(NM,N,W,FV1,Z,IERR)
  8794.       IF (IERR .NE. 0) GO TO 50
  8795.       CALL  REBAK(NM,N,B,FV2,N,Z)
  8796.    50 RETURN
  8797.       END
  8798.       SUBROUTINE RSGAB(NM,N,A,B,W,MATZ,Z,FV1,FV2,IERR)
  8799. C
  8800.       INTEGER N,NM,IERR,MATZ
  8801.       DOUBLE PRECISION A(NM,N),B(NM,N),W(N),Z(NM,N),FV1(N),FV2(N)
  8802. C
  8803. C     THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
  8804. C     SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
  8805. C     TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
  8806. C     FOR THE REAL SYMMETRIC GENERALIZED EIGENPROBLEM  ABX = (LAMBDA)X.
  8807. C
  8808. C     ON INPUT
  8809. C
  8810. C        NM  MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
  8811. C        ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  8812. C        DIMENSION STATEMENT.
  8813. C
  8814. C        N  IS THE ORDER OF THE MATRICES  A  AND  B.
  8815. C
  8816. C        A  CONTAINS A REAL SYMMETRIC MATRIX.
  8817. C
  8818. C        B  CONTAINS A POSITIVE DEFINITE REAL SYMMETRIC MATRIX.
  8819. C
  8820. C        MATZ  IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
  8821. C        ONLY EIGENVALUES ARE DESIRED.  OTHERWISE IT IS SET TO
  8822. C        ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
  8823. C
  8824. C     ON OUTPUT
  8825. C
  8826. C        W  CONTAINS THE EIGENVALUES IN ASCENDING ORDER.
  8827. C
  8828. C        Z  CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO.
  8829. C
  8830. C        IERR  IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
  8831. C           COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT
  8832. C           AND TQL2.  THE NORMAL COMPLETION CODE IS ZERO.
  8833. C
  8834. C        FV1  AND  FV2  ARE TEMPORARY STORAGE ARRAYS.
  8835. C
  8836. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  8837. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  8838. C
  8839. C     THIS VERSION DATED AUGUST 1983.
  8840. C
  8841. C     ------------------------------------------------------------------
  8842. C
  8843.       IF (N .LE. NM) GO TO 10
  8844.       IERR = 10 * N
  8845.       GO TO 50
  8846. C
  8847.    10 CALL  REDUC2(NM,N,A,B,FV2,IERR)
  8848.       IF (IERR .NE. 0) GO TO 50
  8849.       IF (MATZ .NE. 0) GO TO 20
  8850. C     .......... FIND EIGENVALUES ONLY ..........
  8851.       CALL  TRED1(NM,N,A,W,FV1,FV2)
  8852.       CALL  TQLRAT(N,W,FV2,IERR)
  8853.       GO TO 50
  8854. C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
  8855.    20 CALL  TRED2(NM,N,A,W,FV1,Z)
  8856.       CALL  TQL2(NM,N,W,FV1,Z,IERR)
  8857.       IF (IERR .NE. 0) GO TO 50
  8858.       CALL  REBAK(NM,N,B,FV2,N,Z)
  8859.    50 RETURN
  8860.       END
  8861.       SUBROUTINE RSGBA(NM,N,A,B,W,MATZ,Z,FV1,FV2,IERR)
  8862. C
  8863.       INTEGER N,NM,IERR,MATZ
  8864.       DOUBLE PRECISION A(NM,N),B(NM,N),W(N),Z(NM,N),FV1(N),FV2(N)
  8865. C
  8866. C     THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
  8867. C     SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
  8868. C     TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
  8869. C     FOR THE REAL SYMMETRIC GENERALIZED EIGENPROBLEM  BAX = (LAMBDA)X.
  8870. C
  8871. C     ON INPUT
  8872. C
  8873. C        NM  MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
  8874. C        ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  8875. C        DIMENSION STATEMENT.
  8876. C
  8877. C        N  IS THE ORDER OF THE MATRICES  A  AND  B.
  8878. C
  8879. C        A  CONTAINS A REAL SYMMETRIC MATRIX.
  8880. C
  8881. C        B  CONTAINS A POSITIVE DEFINITE REAL SYMMETRIC MATRIX.
  8882. C
  8883. C        MATZ  IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
  8884. C        ONLY EIGENVALUES ARE DESIRED.  OTHERWISE IT IS SET TO
  8885. C        ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
  8886. C
  8887. C     ON OUTPUT
  8888. C
  8889. C        W  CONTAINS THE EIGENVALUES IN ASCENDING ORDER.
  8890. C
  8891. C        Z  CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO.
  8892. C
  8893. C        IERR  IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
  8894. C           COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT
  8895. C           AND TQL2.  THE NORMAL COMPLETION CODE IS ZERO.
  8896. C
  8897. C        FV1  AND  FV2  ARE TEMPORARY STORAGE ARRAYS.
  8898. C
  8899. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  8900. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  8901. C
  8902. C     THIS VERSION DATED AUGUST 1983.
  8903. C
  8904. C     ------------------------------------------------------------------
  8905. C
  8906.       IF (N .LE. NM) GO TO 10
  8907.       IERR = 10 * N
  8908.       GO TO 50
  8909. C
  8910.    10 CALL  REDUC2(NM,N,A,B,FV2,IERR)
  8911.       IF (IERR .NE. 0) GO TO 50
  8912.       IF (MATZ .NE. 0) GO TO 20
  8913. C     .......... FIND EIGENVALUES ONLY ..........
  8914.       CALL  TRED1(NM,N,A,W,FV1,FV2)
  8915.       CALL  TQLRAT(N,W,FV2,IERR)
  8916.       GO TO 50
  8917. C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
  8918.    20 CALL  TRED2(NM,N,A,W,FV1,Z)
  8919.       CALL  TQL2(NM,N,W,FV1,Z,IERR)
  8920.       IF (IERR .NE. 0) GO TO 50
  8921.       CALL  REBAKB(NM,N,B,FV2,N,Z)
  8922.    50 RETURN
  8923.       END
  8924.       SUBROUTINE RSM(NM,N,A,W,M,Z,FWORK,IWORK,IERR)
  8925. C 
  8926.       INTEGER N,NM,M,IWORK(N),IERR
  8927.       DOUBLE PRECISION A(NM,N),W(N),Z(NM,M),FWORK(1)
  8928. C
  8929. C     THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
  8930. C     SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
  8931. C     TO FIND ALL OF THE EIGENVALUES AND SOME OF THE EIGENVECTORS
  8932. C     OF A REAL SYMMETRIC MATRIX.
  8933. C
  8934. C     ON INPUT
  8935. C
  8936. C        NM  MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
  8937. C        ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  8938. C        DIMENSION STATEMENT.
  8939. C
  8940. C        N  IS THE ORDER OF THE MATRIX  A.
  8941. C
  8942. C        A  CONTAINS THE REAL SYMMETRIC MATRIX.
  8943. C
  8944. C        M  THE EIGENVECTORS CORRESPONDING TO THE FIRST M EIGENVALUES
  8945. C           ARE TO BE COMPUTED.
  8946. C           IF M = 0 THEN NO EIGENVECTORS ARE COMPUTED.
  8947. C           IF M = N THEN ALL OF THE EIGENVECTORS ARE COMPUTED.
  8948. C
  8949. C     ON OUTPUT
  8950. C
  8951. C        W  CONTAINS ALL N EIGENVALUES IN ASCENDING ORDER.
  8952. C
  8953. C        Z  CONTAINS THE ORTHONORMAL EIGENVECTORS ASSOCIATED WITH
  8954. C           THE FIRST M EIGENVALUES.
  8955. C
  8956. C        IERR  IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
  8957. C           COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT,
  8958. C           IMTQLV AND TINVIT.  THE NORMAL COMPLETION CODE IS ZERO.
  8959. C
  8960. C        FWORK  IS A TEMPORARY STORAGE ARRAY OF DIMENSION 8*N.
  8961. C
  8962. C        IWORK  IS AN INTEGER TEMPORARY STORAGE ARRAY OF DIMENSION N.
  8963. C
  8964. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  8965. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  8966. C
  8967. C     THIS VERSION DATED AUGUST 1983.
  8968. C
  8969. C     ------------------------------------------------------------------
  8970. C
  8971.       IERR = 10 * N
  8972.       IF (N .GT. NM .OR. M .GT. NM) GO TO 50
  8973.       K1 = 1
  8974.       K2 = K1 + N
  8975.       K3 = K2 + N
  8976.       K4 = K3 + N
  8977.       K5 = K4 + N
  8978.       K6 = K5 + N
  8979.       K7 = K6 + N
  8980.       K8 = K7 + N
  8981.       IF (M .GT. 0) GO TO 10
  8982. C     .......... FIND EIGENVALUES ONLY ..........
  8983.       CALL  TRED1(NM,N,A,W,FWORK(K1),FWORK(K2))
  8984.       CALL  TQLRAT(N,W,FWORK(K2),IERR)
  8985.       GO TO 50
  8986. C     .......... FIND ALL EIGENVALUES AND M EIGENVECTORS ..........
  8987.    10 CALL  TRED1(NM,N,A,FWORK(K1),FWORK(K2),FWORK(K3))
  8988.       CALL  IMTQLV(N,FWORK(K1),FWORK(K2),FWORK(K3),W,IWORK,
  8989.      X             IERR,FWORK(K4))
  8990.       CALL  TINVIT(NM,N,FWORK(K1),FWORK(K2),FWORK(K3),M,W,IWORK,Z,IERR,
  8991.      X             FWORK(K4),FWORK(K5),FWORK(K6),FWORK(K7),FWORK(K8))
  8992.       CALL  TRBAK1(NM,N,A,FWORK(K2),M,Z)
  8993.    50 RETURN
  8994.       END
  8995.       SUBROUTINE RSP(NM,N,NV,A,W,MATZ,Z,FV1,FV2,IERR)
  8996. C
  8997.       INTEGER I,J,N,NM,NV,IERR,MATZ
  8998.       DOUBLE PRECISION A(NV),W(N),Z(NM,N),FV1(N),FV2(N)
  8999. C
  9000. C     THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
  9001. C     SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
  9002. C     TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
  9003. C     OF A REAL SYMMETRIC PACKED MATRIX.
  9004. C
  9005. C     ON INPUT
  9006. C
  9007. C        NM  MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
  9008. C        ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  9009. C        DIMENSION STATEMENT.
  9010. C
  9011. C        N  IS THE ORDER OF THE MATRIX  A.
  9012. C
  9013. C        NV  IS AN INTEGER VARIABLE SET EQUAL TO THE
  9014. C        DIMENSION OF THE ARRAY  A  AS SPECIFIED FOR
  9015. C        A  IN THE CALLING PROGRAM.  NV  MUST NOT BE
  9016. C        LESS THAN  N*(N+1)/2.
  9017. C
  9018. C        A  CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC
  9019. C        PACKED MATRIX STORED ROW-WISE.
  9020. C
  9021. C        MATZ  IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
  9022. C        ONLY EIGENVALUES ARE DESIRED.  OTHERWISE IT IS SET TO
  9023. C        ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
  9024. C
  9025. C     ON OUTPUT
  9026. C
  9027. C        W  CONTAINS THE EIGENVALUES IN ASCENDING ORDER.
  9028. C
  9029. C        Z  CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO.
  9030. C
  9031. C        IERR  IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
  9032. C           COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT
  9033. C           AND TQL2.  THE NORMAL COMPLETION CODE IS ZERO.
  9034. C
  9035. C        FV1  AND  FV2  ARE TEMPORARY STORAGE ARRAYS.
  9036. C
  9037. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  9038. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  9039. C
  9040. C     THIS VERSION DATED AUGUST 1983.
  9041. C
  9042. C     ------------------------------------------------------------------
  9043. C
  9044.       IF (N .LE. NM) GO TO 5
  9045.       IERR = 10 * N
  9046.       GO TO 50
  9047.     5 IF (NV .GE. (N * (N + 1)) / 2) GO TO 10
  9048.       IERR = 20 * N
  9049.       GO TO 50
  9050. C
  9051.    10 CALL  TRED3(N,NV,A,W,FV1,FV2)
  9052.       IF (MATZ .NE. 0) GO TO 20
  9053. C     .......... FIND EIGENVALUES ONLY ..........
  9054.       CALL  TQLRAT(N,W,FV2,IERR)
  9055.       GO TO 50
  9056. C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
  9057.    20 DO 40 I = 1, N
  9058. C
  9059.          DO 30 J = 1, N
  9060.             Z(J,I) = 0.0D0
  9061.    30    CONTINUE
  9062. C
  9063.          Z(I,I) = 1.0D0
  9064.    40 CONTINUE
  9065. C
  9066.       CALL  TQL2(NM,N,W,FV1,Z,IERR)
  9067.       IF (IERR .NE. 0) GO TO 50
  9068.       CALL  TRBAK3(NM,N,NV,A,N,Z)
  9069.    50 RETURN
  9070.       END
  9071.       SUBROUTINE RST(NM,N,W,E,MATZ,Z,IERR)
  9072. C
  9073.       INTEGER I,J,N,NM,IERR,MATZ
  9074.       DOUBLE PRECISION W(N),E(N),Z(NM,N)
  9075. C
  9076. C     THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
  9077. C     SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
  9078. C     TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
  9079. C     OF A REAL SYMMETRIC TRIDIAGONAL MATRIX.
  9080. C
  9081. C     ON INPUT
  9082. C
  9083. C        NM  MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
  9084. C        ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  9085. C        DIMENSION STATEMENT.
  9086. C
  9087. C        N  IS THE ORDER OF THE MATRIX.
  9088. C
  9089. C        W  CONTAINS THE DIAGONAL ELEMENTS OF THE REAL
  9090. C        SYMMETRIC TRIDIAGONAL MATRIX.
  9091. C
  9092. C        E  CONTAINS THE SUBDIAGONAL ELEMENTS OF THE MATRIX IN
  9093. C        ITS LAST N-1 POSITIONS.  E(1) IS ARBITRARY.
  9094. C
  9095. C        MATZ  IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
  9096. C        ONLY EIGENVALUES ARE DESIRED.  OTHERWISE IT IS SET TO
  9097. C        ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
  9098. C
  9099. C     ON OUTPUT
  9100. C
  9101. C        W  CONTAINS THE EIGENVALUES IN ASCENDING ORDER.
  9102. C
  9103. C        Z  CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO.
  9104. C
  9105. C        IERR  IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
  9106. C           COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR IMTQL1
  9107. C           AND IMTQL2.  THE NORMAL COMPLETION CODE IS ZERO.
  9108. C
  9109. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  9110. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  9111. C
  9112. C     THIS VERSION DATED AUGUST 1983.
  9113. C
  9114. C     ------------------------------------------------------------------
  9115. C
  9116.       IF (N .LE. NM) GO TO 10
  9117.       IERR = 10 * N
  9118.       GO TO 50
  9119. C
  9120.    10 IF (MATZ .NE. 0) GO TO 20
  9121. C     .......... FIND EIGENVALUES ONLY ..........
  9122.       CALL  IMTQL1(N,W,E,IERR)
  9123.       GO TO 50
  9124. C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
  9125.    20 DO 40 I = 1, N
  9126. C
  9127.          DO 30 J = 1, N
  9128.             Z(J,I) = 0.0D0
  9129.    30    CONTINUE
  9130. C
  9131.          Z(I,I) = 1.0D0
  9132.    40 CONTINUE
  9133. C
  9134.       CALL  IMTQL2(NM,N,W,E,Z,IERR)
  9135.    50 RETURN
  9136.       END
  9137.       SUBROUTINE RT(NM,N,A,W,MATZ,Z,FV1,IERR)
  9138. C
  9139.       INTEGER N,NM,IERR,MATZ
  9140.       DOUBLE PRECISION A(NM,3),W(N),Z(NM,N),FV1(N)
  9141. C
  9142. C     THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
  9143. C     SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
  9144. C     TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
  9145. C     OF A SPECIAL REAL TRIDIAGONAL MATRIX.
  9146. C
  9147. C     ON INPUT
  9148. C
  9149. C        NM  MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
  9150. C        ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  9151. C        DIMENSION STATEMENT.
  9152. C
  9153. C        N  IS THE ORDER OF THE MATRIX  A.
  9154. C
  9155. C        A  CONTAINS THE SPECIAL REAL TRIDIAGONAL MATRIX IN ITS
  9156. C        FIRST THREE COLUMNS.  THE SUBDIAGONAL ELEMENTS ARE STORED
  9157. C        IN THE LAST  N-1  POSITIONS OF THE FIRST COLUMN, THE
  9158. C        DIAGONAL ELEMENTS IN THE SECOND COLUMN, AND THE SUPERDIAGONAL
  9159. C        ELEMENTS IN THE FIRST  N-1  POSITIONS OF THE THIRD COLUMN.
  9160. C        ELEMENTS  A(1,1)  AND  A(N,3)  ARE ARBITRARY.
  9161. C
  9162. C        MATZ  IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
  9163. C        ONLY EIGENVALUES ARE DESIRED.  OTHERWISE IT IS SET TO
  9164. C        ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
  9165. C
  9166. C     ON OUTPUT
  9167. C
  9168. C        W  CONTAINS THE EIGENVALUES IN ASCENDING ORDER.
  9169. C
  9170. C        Z  CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO.
  9171. C
  9172. C        IERR  IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
  9173. C           COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR IMTQL1
  9174. C           AND IMTQL2.  THE NORMAL COMPLETION CODE IS ZERO.
  9175. C
  9176. C        FV1  IS A TEMPORARY STORAGE ARRAY.
  9177. C
  9178. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  9179. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  9180. C
  9181. C     THIS VERSION DATED AUGUST 1983.
  9182. C
  9183. C     ------------------------------------------------------------------
  9184. C
  9185.       IF (N .LE. NM) GO TO 10
  9186.       IERR = 10 * N
  9187.       GO TO 50
  9188. C
  9189.    10 IF (MATZ .NE. 0) GO TO 20
  9190. C     .......... FIND EIGENVALUES ONLY ..........
  9191.       CALL  FIGI(NM,N,A,W,FV1,FV1,IERR)
  9192.       IF (IERR .GT. 0) GO TO 50
  9193.       CALL  IMTQL1(N,W,FV1,IERR)
  9194.       GO TO 50
  9195. C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
  9196.    20 CALL  FIGI2(NM,N,A,W,FV1,Z,IERR)
  9197.       IF (IERR .NE. 0) GO TO 50
  9198.       CALL  IMTQL2(NM,N,W,FV1,Z,IERR)
  9199.    50 RETURN
  9200.       END
  9201.       SUBROUTINE SVD(NM,M,N,A,W,MATU,U,MATV,V,IERR,RV1)
  9202. C
  9203.       INTEGER I,J,K,L,M,N,II,I1,KK,K1,LL,L1,MN,NM,ITS,IERR
  9204.       DOUBLE PRECISION A(NM,N),W(N),U(NM,N),V(NM,N),RV1(N)
  9205.       DOUBLE PRECISION C,F,G,H,S,X,Y,Z,TST1,TST2,SCALE,PYTHAG
  9206.       LOGICAL MATU,MATV
  9207. C
  9208. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE SVD,
  9209. C     NUM. MATH. 14, 403-420(1970) BY GOLUB AND REINSCH.
  9210. C     HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 134-151(1971).
  9211. C
  9212. C     THIS SUBROUTINE DETERMINES THE SINGULAR VALUE DECOMPOSITION
  9213. C          T
  9214. C     A=USV  OF A REAL M BY N RECTANGULAR MATRIX.  HOUSEHOLDER
  9215. C     BIDIAGONALIZATION AND A VARIANT OF THE QR ALGORITHM ARE USED.
  9216. C
  9217. C     ON INPUT
  9218. C
  9219. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  9220. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  9221. C          DIMENSION STATEMENT.  NOTE THAT NM MUST BE AT LEAST
  9222. C          AS LARGE AS THE MAXIMUM OF M AND N.
  9223. C
  9224. C        M IS THE NUMBER OF ROWS OF A (AND U).
  9225. C
  9226. C        N IS THE NUMBER OF COLUMNS OF A (AND U) AND THE ORDER OF V.
  9227. C
  9228. C        A CONTAINS THE RECTANGULAR INPUT MATRIX TO BE DECOMPOSED.
  9229. C
  9230. C        MATU SHOULD BE SET TO .TRUE. IF THE U MATRIX IN THE
  9231. C          DECOMPOSITION IS DESIRED, AND TO .FALSE. OTHERWISE.
  9232. C
  9233. C        MATV SHOULD BE SET TO .TRUE. IF THE V MATRIX IN THE
  9234. C          DECOMPOSITION IS DESIRED, AND TO .FALSE. OTHERWISE.
  9235. C
  9236. C     ON OUTPUT
  9237. C
  9238. C        A IS UNALTERED (UNLESS OVERWRITTEN BY U OR V).
  9239. C
  9240. C        W CONTAINS THE N (NON-NEGATIVE) SINGULAR VALUES OF A (THE
  9241. C          DIAGONAL ELEMENTS OF S).  THEY ARE UNORDERED.  IF AN
  9242. C          ERROR EXIT IS MADE, THE SINGULAR VALUES SHOULD BE CORRECT
  9243. C          FOR INDICES IERR+1,IERR+2,...,N.
  9244. C
  9245. C        U CONTAINS THE MATRIX U (ORTHOGONAL COLUMN VECTORS) OF THE
  9246. C          DECOMPOSITION IF MATU HAS BEEN SET TO .TRUE.  OTHERWISE
  9247. C          U IS USED AS A TEMPORARY ARRAY.  U MAY COINCIDE WITH A.
  9248. C          IF AN ERROR EXIT IS MADE, THE COLUMNS OF U CORRESPONDING
  9249. C          TO INDICES OF CORRECT SINGULAR VALUES SHOULD BE CORRECT.
  9250. C
  9251. C        V CONTAINS THE MATRIX V (ORTHOGONAL) OF THE DECOMPOSITION IF
  9252. C          MATV HAS BEEN SET TO .TRUE.  OTHERWISE V IS NOT REFERENCED.
  9253. C          V MAY ALSO COINCIDE WITH A IF U IS NOT NEEDED.  IF AN ERROR
  9254. C          EXIT IS MADE, THE COLUMNS OF V CORRESPONDING TO INDICES OF
  9255. C          CORRECT SINGULAR VALUES SHOULD BE CORRECT.
  9256. C
  9257. C        IERR IS SET TO
  9258. C          ZERO       FOR NORMAL RETURN,
  9259. C          K          IF THE K-TH SINGULAR VALUE HAS NOT BEEN
  9260. C                     DETERMINED AFTER 30 ITERATIONS.
  9261. C
  9262. C        RV1 IS A TEMPORARY STORAGE ARRAY.
  9263. C
  9264. C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
  9265. C
  9266. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  9267. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  9268. C
  9269. C     THIS VERSION DATED AUGUST 1983.
  9270. C
  9271. C     ------------------------------------------------------------------
  9272. C
  9273.       IERR = 0
  9274. C
  9275.       DO 100 I = 1, M
  9276. C
  9277.          DO 100 J = 1, N
  9278.             U(I,J) = A(I,J)
  9279.   100 CONTINUE
  9280. C     .......... HOUSEHOLDER REDUCTION TO BIDIAGONAL FORM ..........
  9281.       G = 0.0D0
  9282.       SCALE = 0.0D0
  9283.       X = 0.0D0
  9284. C
  9285.       DO 300 I = 1, N
  9286.          L = I + 1
  9287.          RV1(I) = SCALE * G
  9288.          G = 0.0D0
  9289.          S = 0.0D0
  9290.          SCALE = 0.0D0
  9291.          IF (I .GT. M) GO TO 210
  9292. C
  9293.          DO 120 K = I, M
  9294.   120    SCALE = SCALE + DABS(U(K,I))
  9295. C
  9296.          IF (SCALE .EQ. 0.0D0) GO TO 210
  9297. C
  9298.          DO 130 K = I, M
  9299.             U(K,I) = U(K,I) / SCALE
  9300.             S = S + U(K,I)**2
  9301.   130    CONTINUE
  9302. C
  9303.          F = U(I,I)
  9304.          G = -DSIGN(DSQRT(S),F)
  9305.          H = F * G - S
  9306.          U(I,I) = F - G
  9307.          IF (I .EQ. N) GO TO 190
  9308. C
  9309.          DO 150 J = L, N
  9310.             S = 0.0D0
  9311. C
  9312.             DO 140 K = I, M
  9313.   140       S = S + U(K,I) * U(K,J)
  9314. C
  9315.             F = S / H
  9316. C
  9317.             DO 150 K = I, M
  9318.                U(K,J) = U(K,J) + F * U(K,I)
  9319.   150    CONTINUE
  9320. C
  9321.   190    DO 200 K = I, M
  9322.   200    U(K,I) = SCALE * U(K,I)
  9323. C
  9324.   210    W(I) = SCALE * G
  9325.          G = 0.0D0
  9326.          S = 0.0D0
  9327.          SCALE = 0.0D0
  9328.          IF (I .GT. M .OR. I .EQ. N) GO TO 290
  9329. C
  9330.          DO 220 K = L, N
  9331.   220    SCALE = SCALE + DABS(U(I,K))
  9332. C
  9333.          IF (SCALE .EQ. 0.0D0) GO TO 290
  9334. C
  9335.          DO 230 K = L, N
  9336.             U(I,K) = U(I,K) / SCALE
  9337.             S = S + U(I,K)**2
  9338.   230    CONTINUE
  9339. C
  9340.          F = U(I,L)
  9341.          G = -DSIGN(DSQRT(S),F)
  9342.          H = F * G - S
  9343.          U(I,L) = F - G
  9344. C
  9345.          DO 240 K = L, N
  9346.   240    RV1(K) = U(I,K) / H
  9347. C
  9348.          IF (I .EQ. M) GO TO 270
  9349. C
  9350.          DO 260 J = L, M
  9351.             S = 0.0D0
  9352. C
  9353.             DO 250 K = L, N
  9354.   250       S = S + U(J,K) * U(I,K)
  9355. C
  9356.             DO 260 K = L, N
  9357.                U(J,K) = U(J,K) + S * RV1(K)
  9358.   260    CONTINUE
  9359. C
  9360.   270    DO 280 K = L, N
  9361.   280    U(I,K) = SCALE * U(I,K)
  9362. C
  9363.   290    X = DMAX1(X,DABS(W(I))+DABS(RV1(I)))
  9364.   300 CONTINUE
  9365. C     .......... ACCUMULATION OF RIGHT-HAND TRANSFORMATIONS ..........
  9366.       IF (.NOT. MATV) GO TO 410
  9367. C     .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
  9368.       DO 400 II = 1, N
  9369.          I = N + 1 - II
  9370.          IF (I .EQ. N) GO TO 390
  9371.          IF (G .EQ. 0.0D0) GO TO 360
  9372. C
  9373.          DO 320 J = L, N
  9374. C     .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ..........
  9375.   320    V(J,I) = (U(I,J) / U(I,L)) / G
  9376. C
  9377.          DO 350 J = L, N
  9378.             S = 0.0D0
  9379. C
  9380.             DO 340 K = L, N
  9381.   340       S = S + U(I,K) * V(K,J)
  9382. C
  9383.             DO 350 K = L, N
  9384.                V(K,J) = V(K,J) + S * V(K,I)
  9385.   350    CONTINUE
  9386. C
  9387.   360    DO 380 J = L, N
  9388.             V(I,J) = 0.0D0
  9389.             V(J,I) = 0.0D0
  9390.   380    CONTINUE
  9391. C
  9392.   390    V(I,I) = 1.0D0
  9393.          G = RV1(I)
  9394.          L = I
  9395.   400 CONTINUE
  9396. C     .......... ACCUMULATION OF LEFT-HAND TRANSFORMATIONS ..........
  9397.   410 IF (.NOT. MATU) GO TO 510
  9398. C     ..........FOR I=MIN(M,N) STEP -1 UNTIL 1 DO -- ..........
  9399.       MN = N
  9400.       IF (M .LT. N) MN = M
  9401. C
  9402.       DO 500 II = 1, MN
  9403.          I = MN + 1 - II
  9404.          L = I + 1
  9405.          G = W(I)
  9406.          IF (I .EQ. N) GO TO 430
  9407. C
  9408.          DO 420 J = L, N
  9409.   420    U(I,J) = 0.0D0
  9410. C
  9411.   430    IF (G .EQ. 0.0D0) GO TO 475
  9412.          IF (I .EQ. MN) GO TO 460
  9413. C
  9414.          DO 450 J = L, N
  9415.             S = 0.0D0
  9416. C
  9417.             DO 440 K = L, M
  9418.   440       S = S + U(K,I) * U(K,J)
  9419. C     .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ..........
  9420.             F = (S / U(I,I)) / G
  9421. C
  9422.             DO 450 K = I, M
  9423.                U(K,J) = U(K,J) + F * U(K,I)
  9424.   450    CONTINUE
  9425. C
  9426.   460    DO 470 J = I, M
  9427.   470    U(J,I) = U(J,I) / G
  9428. C
  9429.          GO TO 490
  9430. C
  9431.   475    DO 480 J = I, M
  9432.   480    U(J,I) = 0.0D0
  9433. C
  9434.   490    U(I,I) = U(I,I) + 1.0D0
  9435.   500 CONTINUE
  9436. C     .......... DIAGONALIZATION OF THE BIDIAGONAL FORM ..........
  9437.   510 TST1 = X
  9438. C     .......... FOR K=N STEP -1 UNTIL 1 DO -- ..........
  9439.       DO 700 KK = 1, N
  9440.          K1 = N - KK
  9441.          K = K1 + 1
  9442.          ITS = 0
  9443. C     .......... TEST FOR SPLITTING.
  9444. C                FOR L=K STEP -1 UNTIL 1 DO -- ..........
  9445.   520    DO 530 LL = 1, K
  9446.             L1 = K - LL
  9447.             L = L1 + 1
  9448.             TST2 = TST1 + DABS(RV1(L))
  9449.             IF (TST2 .EQ. TST1) GO TO 565
  9450. C     .......... RV1(1) IS ALWAYS ZERO, SO THERE IS NO EXIT
  9451. C                THROUGH THE BOTTOM OF THE LOOP ..........
  9452.             TST2 = TST1 + DABS(W(L1))
  9453.             IF (TST2 .EQ. TST1) GO TO 540
  9454.   530    CONTINUE
  9455. C     .......... CANCELLATION OF RV1(L) IF L GREATER THAN 1 ..........
  9456.   540    C = 0.0D0
  9457.          S = 1.0D0
  9458. C
  9459.          DO 560 I = L, K
  9460.             F = S * RV1(I)
  9461.             RV1(I) = C * RV1(I)
  9462.             TST2 = TST1 + DABS(F)
  9463.             IF (TST2 .EQ. TST1) GO TO 565
  9464.             G = W(I)
  9465.             H = PYTHAG(F,G)
  9466.             W(I) = H
  9467.             C = G / H
  9468.             S = -F / H
  9469.             IF (.NOT. MATU) GO TO 560
  9470. C
  9471.             DO 550 J = 1, M
  9472.                Y = U(J,L1)
  9473.                Z = U(J,I)
  9474.                U(J,L1) = Y * C + Z * S
  9475.                U(J,I) = -Y * S + Z * C
  9476.   550       CONTINUE
  9477. C
  9478.   560    CONTINUE
  9479. C     .......... TEST FOR CONVERGENCE ..........
  9480.   565    Z = W(K)
  9481.          IF (L .EQ. K) GO TO 650
  9482. C     .......... SHIFT FROM BOTTOM 2 BY 2 MINOR ..........
  9483.          IF (ITS .EQ. 30) GO TO 1000
  9484.          ITS = ITS + 1
  9485.          X = W(L)
  9486.          Y = W(K1)
  9487.          G = RV1(K1)
  9488.          H = RV1(K)
  9489.          F = 0.5D0 * (((G + Z) / H) * ((G - Z) / Y) + Y / H - H / Y)
  9490.          G = PYTHAG(F,1.0D0)
  9491.          F = X - (Z / X) * Z + (H / X) * (Y / (F + DSIGN(G,F)) - H)
  9492. C     .......... NEXT QR TRANSFORMATION ..........
  9493.          C = 1.0D0
  9494.          S = 1.0D0
  9495. C
  9496.          DO 600 I1 = L, K1
  9497.             I = I1 + 1
  9498.             G = RV1(I)
  9499.             Y = W(I)
  9500.             H = S * G
  9501.             G = C * G
  9502.             Z = PYTHAG(F,H)
  9503.             RV1(I1) = Z
  9504.             C = F / Z
  9505.             S = H / Z
  9506.             F = X * C + G * S
  9507.             G = -X * S + G * C
  9508.             H = Y * S
  9509.             Y = Y * C
  9510.             IF (.NOT. MATV) GO TO 575
  9511. C
  9512.             DO 570 J = 1, N
  9513.                X = V(J,I1)
  9514.                Z = V(J,I)
  9515.                V(J,I1) = X * C + Z * S
  9516.                V(J,I) = -X * S + Z * C
  9517.   570       CONTINUE
  9518. C
  9519.   575       Z = PYTHAG(F,H)
  9520.             W(I1) = Z
  9521. C     .......... ROTATION CAN BE ARBITRARY IF Z IS ZERO ..........
  9522.             IF (Z .EQ. 0.0D0) GO TO 580
  9523.             C = F / Z
  9524.             S = H / Z
  9525.   580       F = C * G + S * Y
  9526.             X = -S * G + C * Y
  9527.             IF (.NOT. MATU) GO TO 600
  9528. C
  9529.             DO 590 J = 1, M
  9530.                Y = U(J,I1)
  9531.                Z = U(J,I)
  9532.                U(J,I1) = Y * C + Z * S
  9533.                U(J,I) = -Y * S + Z * C
  9534.   590       CONTINUE
  9535. C
  9536.   600    CONTINUE
  9537. C
  9538.          RV1(L) = 0.0D0
  9539.          RV1(K) = F
  9540.          W(K) = X
  9541.          GO TO 520
  9542. C     .......... CONVERGENCE ..........
  9543.   650    IF (Z .GE. 0.0D0) GO TO 700
  9544. C     .......... W(K) IS MADE NON-NEGATIVE ..........
  9545.          W(K) = -Z
  9546.          IF (.NOT. MATV) GO TO 700
  9547. C
  9548.          DO 690 J = 1, N
  9549.   690    V(J,K) = -V(J,K)
  9550. C
  9551.   700 CONTINUE
  9552. C
  9553.       GO TO 1001
  9554. C     .......... SET ERROR -- NO CONVERGENCE TO A
  9555. C                SINGULAR VALUE AFTER 30 ITERATIONS ..........
  9556.  1000 IERR = K
  9557.  1001 RETURN
  9558.       END
  9559.       SUBROUTINE TINVIT(NM,N,D,E,E2,M,W,IND,Z,
  9560.      X                  IERR,RV1,RV2,RV3,RV4,RV6)
  9561. C
  9562.       INTEGER I,J,M,N,P,Q,R,S,II,IP,JJ,NM,ITS,TAG,IERR,GROUP
  9563.       DOUBLE PRECISION D(N),E(N),E2(N),W(M),Z(NM,M),
  9564.      X       RV1(N),RV2(N),RV3(N),RV4(N),RV6(N)
  9565.       DOUBLE PRECISION U,V,UK,XU,X0,X1,EPS2,EPS3,EPS4,NORM,ORDER,EPSLON,
  9566.      X       PYTHAG
  9567.       INTEGER IND(M)
  9568. C
  9569. C     THIS SUBROUTINE IS A TRANSLATION OF THE INVERSE ITERATION TECH-
  9570. C     NIQUE IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON.
  9571. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971).
  9572. C
  9573. C     THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A TRIDIAGONAL
  9574. C     SYMMETRIC MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES,
  9575. C     USING INVERSE ITERATION.
  9576. C
  9577. C     ON INPUT
  9578. C
  9579. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  9580. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  9581. C          DIMENSION STATEMENT.
  9582. C
  9583. C        N IS THE ORDER OF THE MATRIX.
  9584. C
  9585. C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
  9586. C
  9587. C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
  9588. C          IN ITS LAST N-1 POSITIONS.  E(1) IS ARBITRARY.
  9589. C
  9590. C        E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E,
  9591. C          WITH ZEROS CORRESPONDING TO NEGLIGIBLE ELEMENTS OF E.
  9592. C          E(I) IS CONSIDERED NEGLIGIBLE IF IT IS NOT LARGER THAN
  9593. C          THE PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE SUM
  9594. C          OF THE MAGNITUDES OF D(I) AND D(I-1).  E2(1) MUST CONTAIN
  9595. C          0.0D0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, OR 2.0D0
  9596. C          IF THE EIGENVALUES ARE IN DESCENDING ORDER.  IF  BISECT,
  9597. C          TRIDIB, OR  IMTQLV  HAS BEEN USED TO FIND THE EIGENVALUES,
  9598. C          THEIR OUTPUT E2 ARRAY IS EXACTLY WHAT IS EXPECTED HERE.
  9599. C
  9600. C        M IS THE NUMBER OF SPECIFIED EIGENVALUES.
  9601. C
  9602. C        W CONTAINS THE M EIGENVALUES IN ASCENDING OR DESCENDING ORDER.
  9603. C
  9604. C        IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES
  9605. C          ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W --
  9606. C          1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM
  9607. C          THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC.
  9608. C
  9609. C     ON OUTPUT
  9610. C
  9611. C        ALL INPUT ARRAYS ARE UNALTERED.
  9612. C
  9613. C        Z CONTAINS THE ASSOCIATED SET OF ORTHONORMAL EIGENVECTORS.
  9614. C          ANY VECTOR WHICH FAILS TO CONVERGE IS SET TO ZERO.
  9615. C
  9616. C        IERR IS SET TO
  9617. C          ZERO       FOR NORMAL RETURN,
  9618. C          -R         IF THE EIGENVECTOR CORRESPONDING TO THE R-TH
  9619. C                     EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS.
  9620. C
  9621. C        RV1, RV2, RV3, RV4, AND RV6 ARE TEMPORARY STORAGE ARRAYS.
  9622. C
  9623. C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
  9624. C
  9625. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  9626. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  9627. C
  9628. C     THIS VERSION DATED AUGUST 1983.
  9629. C
  9630. C     ------------------------------------------------------------------
  9631. C
  9632.       IERR = 0
  9633.       IF (M .EQ. 0) GO TO 1001
  9634.       TAG = 0
  9635.       ORDER = 1.0D0 - E2(1)
  9636.       Q = 0
  9637. C     .......... ESTABLISH AND PROCESS NEXT SUBMATRIX ..........
  9638.   100 P = Q + 1
  9639. C
  9640.       DO 120 Q = P, N
  9641.          IF (Q .EQ. N) GO TO 140
  9642.          IF (E2(Q+1) .EQ. 0.0D0) GO TO 140
  9643.   120 CONTINUE
  9644. C     .......... FIND VECTORS BY INVERSE ITERATION ..........
  9645.   140 TAG = TAG + 1
  9646.       S = 0
  9647. C
  9648.       DO 920 R = 1, M
  9649.          IF (IND(R) .NE. TAG) GO TO 920
  9650.          ITS = 1
  9651.          X1 = W(R)
  9652.          IF (S .NE. 0) GO TO 510
  9653. C     .......... CHECK FOR ISOLATED ROOT ..........
  9654.          XU = 1.0D0
  9655.          IF (P .NE. Q) GO TO 490
  9656.          RV6(P) = 1.0D0
  9657.          GO TO 870
  9658.   490    NORM = DABS(D(P))
  9659.          IP = P + 1
  9660. C
  9661.          DO 500 I = IP, Q
  9662.   500    NORM = DMAX1(NORM, DABS(D(I))+DABS(E(I)))
  9663. C     .......... EPS2 IS THE CRITERION FOR GROUPING,
  9664. C                EPS3 REPLACES ZERO PIVOTS AND EQUAL
  9665. C                ROOTS ARE MODIFIED BY EPS3,
  9666. C                EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW ..........
  9667.          EPS2 = 1.0D-3 * NORM
  9668.          EPS3 = EPSLON(NORM)
  9669.          UK = Q - P + 1
  9670.          EPS4 = UK * EPS3
  9671.          UK = EPS4 / DSQRT(UK)
  9672.          S = P
  9673.   505    GROUP = 0
  9674.          GO TO 520
  9675. C     .......... LOOK FOR CLOSE OR COINCIDENT ROOTS ..........
  9676.   510    IF (DABS(X1-X0) .GE. EPS2) GO TO 505
  9677.          GROUP = GROUP + 1
  9678.          IF (ORDER * (X1 - X0) .LE. 0.0D0) X1 = X0 + ORDER * EPS3
  9679. C     .......... ELIMINATION WITH INTERCHANGES AND
  9680. C                INITIALIZATION OF VECTOR ..........
  9681.   520    V = 0.0D0
  9682. C
  9683.          DO 580 I = P, Q
  9684.             RV6(I) = UK
  9685.             IF (I .EQ. P) GO TO 560
  9686.             IF (DABS(E(I)) .LT. DABS(U)) GO TO 540
  9687. C     .......... WARNING -- A DIVIDE CHECK MAY OCCUR HERE IF
  9688. C                E2 ARRAY HAS NOT BEEN SPECIFIED CORRECTLY ..........
  9689.             XU = U / E(I)
  9690.             RV4(I) = XU
  9691.             RV1(I-1) = E(I)
  9692.             RV2(I-1) = D(I) - X1
  9693.             RV3(I-1) = 0.0D0
  9694.             IF (I .NE. Q) RV3(I-1) = E(I+1)
  9695.             U = V - XU * RV2(I-1)
  9696.             V = -XU * RV3(I-1)
  9697.             GO TO 580
  9698.   540       XU = E(I) / U
  9699.             RV4(I) = XU
  9700.             RV1(I-1) = U
  9701.             RV2(I-1) = V
  9702.             RV3(I-1) = 0.0D0
  9703.   560       U = D(I) - X1 - XU * V
  9704.             IF (I .NE. Q) V = E(I+1)
  9705.   580    CONTINUE
  9706. C
  9707.          IF (U .EQ. 0.0D0) U = EPS3
  9708.          RV1(Q) = U
  9709.          RV2(Q) = 0.0D0
  9710.          RV3(Q) = 0.0D0
  9711. C     .......... BACK SUBSTITUTION
  9712. C                FOR I=Q STEP -1 UNTIL P DO -- ..........
  9713.   600    DO 620 II = P, Q
  9714.             I = P + Q - II
  9715.             RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I)
  9716.             V = U
  9717.             U = RV6(I)
  9718.   620    CONTINUE
  9719. C     .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS
  9720. C                MEMBERS OF GROUP ..........
  9721.          IF (GROUP .EQ. 0) GO TO 700
  9722.          J = R
  9723. C
  9724.          DO 680 JJ = 1, GROUP
  9725.   630       J = J - 1
  9726.             IF (IND(J) .NE. TAG) GO TO 630
  9727.             XU = 0.0D0
  9728. C
  9729.             DO 640 I = P, Q
  9730.   640       XU = XU + RV6(I) * Z(I,J)
  9731. C
  9732.             DO 660 I = P, Q
  9733.   660       RV6(I) = RV6(I) - XU * Z(I,J)
  9734. C
  9735.   680    CONTINUE
  9736. C
  9737.   700    NORM = 0.0D0
  9738. C
  9739.          DO 720 I = P, Q
  9740.   720    NORM = NORM + DABS(RV6(I))
  9741. C
  9742.          IF (NORM .GE. 1.0D0) GO TO 840
  9743. C     .......... FORWARD SUBSTITUTION ..........
  9744.          IF (ITS .EQ. 5) GO TO 830
  9745.          IF (NORM .NE. 0.0D0) GO TO 740
  9746.          RV6(S) = EPS4
  9747.          S = S + 1
  9748.          IF (S .GT. Q) S = P
  9749.          GO TO 780
  9750.   740    XU = EPS4 / NORM
  9751. C
  9752.          DO 760 I = P, Q
  9753.   760    RV6(I) = RV6(I) * XU
  9754. C     .......... ELIMINATION OPERATIONS ON NEXT VECTOR
  9755. C                ITERATE ..........
  9756.   780    DO 820 I = IP, Q
  9757.             U = RV6(I)
  9758. C     .......... IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE
  9759. C                WAS PERFORMED EARLIER IN THE
  9760. C                TRIANGULARIZATION PROCESS ..........
  9761.             IF (RV1(I-1) .NE. E(I)) GO TO 800
  9762.             U = RV6(I-1)
  9763.             RV6(I-1) = RV6(I)
  9764.   800       RV6(I) = U - RV4(I) * RV6(I-1)
  9765.   820    CONTINUE
  9766. C
  9767.          ITS = ITS + 1
  9768.          GO TO 600
  9769. C     .......... SET ERROR -- NON-CONVERGED EIGENVECTOR ..........
  9770.   830    IERR = -R
  9771.          XU = 0.0D0
  9772.          GO TO 870
  9773. C     .......... NORMALIZE SO THAT SUM OF SQUARES IS
  9774. C                1 AND EXPAND TO FULL ORDER ..........
  9775.   840    U = 0.0D0
  9776. C
  9777.          DO 860 I = P, Q
  9778.   860    U = PYTHAG(U,RV6(I))
  9779. C
  9780.          XU = 1.0D0 / U
  9781. C
  9782.   870    DO 880 I = 1, N
  9783.   880    Z(I,R) = 0.0D0
  9784. C
  9785.          DO 900 I = P, Q
  9786.   900    Z(I,R) = RV6(I) * XU
  9787. C
  9788.          X0 = X1
  9789.   920 CONTINUE
  9790. C
  9791.       IF (Q .LT. N) GO TO 100
  9792.  1001 RETURN
  9793.       END
  9794.       SUBROUTINE TQL1(N,D,E,IERR)
  9795. C
  9796.       INTEGER I,J,L,M,N,II,L1,L2,MML,IERR
  9797.       DOUBLE PRECISION D(N),E(N)
  9798.       DOUBLE PRECISION C,C2,C3,DL1,EL1,F,G,H,P,R,S,S2,TST1,TST2,PYTHAG
  9799. C
  9800. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL1,
  9801. C     NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND
  9802. C     WILKINSON.
  9803. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971).
  9804. C
  9805. C     THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC
  9806. C     TRIDIAGONAL MATRIX BY THE QL METHOD.
  9807. C
  9808. C     ON INPUT
  9809. C
  9810. C        N IS THE ORDER OF THE MATRIX.
  9811. C
  9812. C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
  9813. C
  9814. C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
  9815. C          IN ITS LAST N-1 POSITIONS.  E(1) IS ARBITRARY.
  9816. C
  9817. C      ON OUTPUT
  9818. C
  9819. C        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
  9820. C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND
  9821. C          ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE
  9822. C          THE SMALLEST EIGENVALUES.
  9823. C
  9824. C        E HAS BEEN DESTROYED.
  9825. C
  9826. C        IERR IS SET TO
  9827. C          ZERO       FOR NORMAL RETURN,
  9828. C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
  9829. C                     DETERMINED AFTER 30 ITERATIONS.
  9830. C
  9831. C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
  9832. C
  9833. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  9834. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  9835. C
  9836. C     THIS VERSION DATED AUGUST 1983.
  9837. C
  9838. C     ------------------------------------------------------------------
  9839. C
  9840.       IERR = 0
  9841.       IF (N .EQ. 1) GO TO 1001
  9842. C
  9843.       DO 100 I = 2, N
  9844.   100 E(I-1) = E(I)
  9845. C
  9846.       F = 0.0D0
  9847.       TST1 = 0.0D0
  9848.       E(N) = 0.0D0
  9849. C
  9850.       DO 290 L = 1, N
  9851.          J = 0
  9852.          H = DABS(D(L)) + DABS(E(L))
  9853.          IF (TST1 .LT. H) TST1 = H
  9854. C     .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT ..........
  9855.          DO 110 M = L, N
  9856.             TST2 = TST1 + DABS(E(M))
  9857.             IF (TST2 .EQ. TST1) GO TO 120
  9858. C     .......... E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
  9859. C                THROUGH THE BOTTOM OF THE LOOP ..........
  9860.   110    CONTINUE
  9861. C
  9862.   120    IF (M .EQ. L) GO TO 210
  9863.   130    IF (J .EQ. 30) GO TO 1000
  9864.          J = J + 1
  9865. C     .......... FORM SHIFT ..........
  9866.          L1 = L + 1
  9867.          L2 = L1 + 1
  9868.          G = D(L)
  9869.          P = (D(L1) - G) / (2.0D0 * E(L))
  9870.          R = PYTHAG(P,1.0D0)
  9871.          D(L) = E(L) / (P + DSIGN(R,P))
  9872.          D(L1) = E(L) * (P + DSIGN(R,P))
  9873.          DL1 = D(L1)
  9874.          H = G - D(L)
  9875.          IF (L2 .GT. N) GO TO 145
  9876. C
  9877.          DO 140 I = L2, N
  9878.   140    D(I) = D(I) - H
  9879. C
  9880.   145    F = F + H
  9881. C     .......... QL TRANSFORMATION ..........
  9882.          P = D(M)
  9883.          C = 1.0D0
  9884.          C2 = C
  9885.          EL1 = E(L1)
  9886.          S = 0.0D0
  9887.          MML = M - L
  9888. C     .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
  9889.          DO 200 II = 1, MML
  9890.             C3 = C2
  9891.             C2 = C
  9892.             S2 = S
  9893.             I = M - II
  9894.             G = C * E(I)
  9895.             H = C * P
  9896.             R = PYTHAG(P,E(I))
  9897.             E(I+1) = S * R
  9898.             S = E(I) / R
  9899.             C = P / R
  9900.             P = C * D(I) - S * G
  9901.             D(I+1) = H + S * (C * G + S * D(I))
  9902.   200    CONTINUE
  9903. C
  9904.          P = -S * S2 * C3 * EL1 * E(L) / DL1
  9905.          E(L) = S * P
  9906.          D(L) = C * P
  9907.          TST2 = TST1 + DABS(E(L))
  9908.          IF (TST2 .GT. TST1) GO TO 130
  9909.   210    P = D(L) + F
  9910. C     .......... ORDER EIGENVALUES ..........
  9911.          IF (L .EQ. 1) GO TO 250
  9912. C     .......... FOR I=L STEP -1 UNTIL 2 DO -- ..........
  9913.          DO 230 II = 2, L
  9914.             I = L + 2 - II
  9915.             IF (P .GE. D(I-1)) GO TO 270
  9916.             D(I) = D(I-1)
  9917.   230    CONTINUE
  9918. C
  9919.   250    I = 1
  9920.   270    D(I) = P
  9921.   290 CONTINUE
  9922. C
  9923.       GO TO 1001
  9924. C     .......... SET ERROR -- NO CONVERGENCE TO AN
  9925. C                EIGENVALUE AFTER 30 ITERATIONS ..........
  9926.  1000 IERR = L
  9927.  1001 RETURN
  9928.       END
  9929.       SUBROUTINE TQL2(NM,N,D,E,Z,IERR)
  9930. C
  9931.       INTEGER I,J,K,L,M,N,II,L1,L2,NM,MML,IERR
  9932.       DOUBLE PRECISION D(N),E(N),Z(NM,N)
  9933.       DOUBLE PRECISION C,C2,C3,DL1,EL1,F,G,H,P,R,S,S2,TST1,TST2,PYTHAG
  9934. C
  9935. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2,
  9936. C     NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND
  9937. C     WILKINSON.
  9938. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971).
  9939. C
  9940. C     THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
  9941. C     OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD.
  9942. C     THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO
  9943. C     BE FOUND IF  TRED2  HAS BEEN USED TO REDUCE THIS
  9944. C     FULL MATRIX TO TRIDIAGONAL FORM.
  9945. C
  9946. C     ON INPUT
  9947. C
  9948. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  9949. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  9950. C          DIMENSION STATEMENT.
  9951. C
  9952. C        N IS THE ORDER OF THE MATRIX.
  9953. C
  9954. C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
  9955. C
  9956. C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
  9957. C          IN ITS LAST N-1 POSITIONS.  E(1) IS ARBITRARY.
  9958. C
  9959. C        Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
  9960. C          REDUCTION BY  TRED2, IF PERFORMED.  IF THE EIGENVECTORS
  9961. C          OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN
  9962. C          THE IDENTITY MATRIX.
  9963. C
  9964. C      ON OUTPUT
  9965. C
  9966. C        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
  9967. C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT
  9968. C          UNORDERED FOR INDICES 1,2,...,IERR-1.
  9969. C
  9970. C        E HAS BEEN DESTROYED.
  9971. C
  9972. C        Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC
  9973. C          TRIDIAGONAL (OR FULL) MATRIX.  IF AN ERROR EXIT IS MADE,
  9974. C          Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED
  9975. C          EIGENVALUES.
  9976. C
  9977. C        IERR IS SET TO
  9978. C          ZERO       FOR NORMAL RETURN,
  9979. C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
  9980. C                     DETERMINED AFTER 30 ITERATIONS.
  9981. C
  9982. C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
  9983. C
  9984. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  9985. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  9986. C
  9987. C     THIS VERSION DATED AUGUST 1983.
  9988. C
  9989. C     ------------------------------------------------------------------
  9990. C
  9991.       IERR = 0
  9992.       IF (N .EQ. 1) GO TO 1001
  9993. C
  9994.       DO 100 I = 2, N
  9995.   100 E(I-1) = E(I)
  9996. C
  9997.       F = 0.0D0
  9998.       TST1 = 0.0D0
  9999.       E(N) = 0.0D0
  10000. C
  10001.       DO 240 L = 1, N
  10002.          J = 0
  10003.          H = DABS(D(L)) + DABS(E(L))
  10004.          IF (TST1 .LT. H) TST1 = H
  10005. C     .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT ..........
  10006.          DO 110 M = L, N
  10007.             TST2 = TST1 + DABS(E(M))
  10008.             IF (TST2 .EQ. TST1) GO TO 120
  10009. C     .......... E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
  10010. C                THROUGH THE BOTTOM OF THE LOOP ..........
  10011.   110    CONTINUE
  10012. C
  10013.   120    IF (M .EQ. L) GO TO 220
  10014.   130    IF (J .EQ. 30) GO TO 1000
  10015.          J = J + 1
  10016. C     .......... FORM SHIFT ..........
  10017.          L1 = L + 1
  10018.          L2 = L1 + 1
  10019.          G = D(L)
  10020.          P = (D(L1) - G) / (2.0D0 * E(L))
  10021.          R = PYTHAG(P,1.0D0)
  10022.          D(L) = E(L) / (P + DSIGN(R,P))
  10023.          D(L1) = E(L) * (P + DSIGN(R,P))
  10024.          DL1 = D(L1)
  10025.          H = G - D(L)
  10026.          IF (L2 .GT. N) GO TO 145
  10027. C
  10028.          DO 140 I = L2, N
  10029.   140    D(I) = D(I) - H
  10030. C
  10031.   145    F = F + H
  10032. C     .......... QL TRANSFORMATION ..........
  10033.          P = D(M)
  10034.          C = 1.0D0
  10035.          C2 = C
  10036.          EL1 = E(L1)
  10037.          S = 0.0D0
  10038.          MML = M - L
  10039. C     .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
  10040.          DO 200 II = 1, MML
  10041.             C3 = C2
  10042.             C2 = C
  10043.             S2 = S
  10044.             I = M - II
  10045.             G = C * E(I)
  10046.             H = C * P
  10047.             R = PYTHAG(P,E(I))
  10048.             E(I+1) = S * R
  10049.             S = E(I) / R
  10050.             C = P / R
  10051.             P = C * D(I) - S * G
  10052.             D(I+1) = H + S * (C * G + S * D(I))
  10053. C     .......... FORM VECTOR ..........
  10054.             DO 180 K = 1, N
  10055.                H = Z(K,I+1)
  10056.                Z(K,I+1) = S * Z(K,I) + C * H
  10057.                Z(K,I) = C * Z(K,I) - S * H
  10058.   180       CONTINUE
  10059. C
  10060.   200    CONTINUE
  10061. C
  10062.          P = -S * S2 * C3 * EL1 * E(L) / DL1
  10063.          E(L) = S * P
  10064.          D(L) = C * P
  10065.          TST2 = TST1 + DABS(E(L))
  10066.          IF (TST2 .GT. TST1) GO TO 130
  10067.   220    D(L) = D(L) + F
  10068.   240 CONTINUE
  10069. C     .......... ORDER EIGENVALUES AND EIGENVECTORS ..........
  10070.       DO 300 II = 2, N
  10071.          I = II - 1
  10072.          K = I
  10073.          P = D(I)
  10074. C
  10075.          DO 260 J = II, N
  10076.             IF (D(J) .GE. P) GO TO 260
  10077.             K = J
  10078.             P = D(J)
  10079.   260    CONTINUE
  10080. C
  10081.          IF (K .EQ. I) GO TO 300
  10082.          D(K) = D(I)
  10083.          D(I) = P
  10084. C
  10085.          DO 280 J = 1, N
  10086.             P = Z(J,I)
  10087.             Z(J,I) = Z(J,K)
  10088.             Z(J,K) = P
  10089.   280    CONTINUE
  10090. C
  10091.   300 CONTINUE
  10092. C
  10093.       GO TO 1001
  10094. C     .......... SET ERROR -- NO CONVERGENCE TO AN
  10095. C                EIGENVALUE AFTER 30 ITERATIONS ..........
  10096.  1000 IERR = L
  10097.  1001 RETURN
  10098.       END
  10099.       SUBROUTINE TQLRAT(N,D,E2,IERR)
  10100. C
  10101.       INTEGER I,J,L,M,N,II,L1,MML,IERR
  10102.       DOUBLE PRECISION D(N),E2(N)
  10103.       DOUBLE PRECISION B,C,F,G,H,P,R,S,T,EPSLON,PYTHAG
  10104. C
  10105. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQLRAT,
  10106. C     ALGORITHM 464, COMM. ACM 16, 689(1973) BY REINSCH.
  10107. C
  10108. C     THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC
  10109. C     TRIDIAGONAL MATRIX BY THE RATIONAL QL METHOD.
  10110. C
  10111. C     ON INPUT
  10112. C
  10113. C        N IS THE ORDER OF THE MATRIX.
  10114. C
  10115. C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
  10116. C
  10117. C        E2 CONTAINS THE SQUARES OF THE SUBDIAGONAL ELEMENTS OF THE
  10118. C          INPUT MATRIX IN ITS LAST N-1 POSITIONS.  E2(1) IS ARBITRARY.
  10119. C
  10120. C      ON OUTPUT
  10121. C
  10122. C        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
  10123. C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND
  10124. C          ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE
  10125. C          THE SMALLEST EIGENVALUES.
  10126. C
  10127. C        E2 HAS BEEN DESTROYED.
  10128. C
  10129. C        IERR IS SET TO
  10130. C          ZERO       FOR NORMAL RETURN,
  10131. C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
  10132. C                     DETERMINED AFTER 30 ITERATIONS.
  10133. C
  10134. C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
  10135. C
  10136. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  10137. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  10138. C
  10139. C     THIS VERSION DATED AUGUST 1983.
  10140. C
  10141. C     ------------------------------------------------------------------
  10142. C
  10143.       IERR = 0
  10144.       IF (N .EQ. 1) GO TO 1001
  10145. C
  10146.       DO 100 I = 2, N
  10147.   100 E2(I-1) = E2(I)
  10148. C
  10149.       F = 0.0D0
  10150.       T = 0.0D0
  10151.       E2(N) = 0.0D0
  10152. C
  10153.       DO 290 L = 1, N
  10154.          J = 0
  10155.          H = DABS(D(L)) + DSQRT(E2(L))
  10156.          IF (T .GT. H) GO TO 105
  10157.          T = H
  10158.          B = EPSLON(T)
  10159.          C = B * B
  10160. C     .......... LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT ..........
  10161.   105    DO 110 M = L, N
  10162.             IF (E2(M) .LE. C) GO TO 120
  10163. C     .......... E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
  10164. C                THROUGH THE BOTTOM OF THE LOOP ..........
  10165.   110    CONTINUE
  10166. C
  10167.   120    IF (M .EQ. L) GO TO 210
  10168.   130    IF (J .EQ. 30) GO TO 1000
  10169.          J = J + 1
  10170. C     .......... FORM SHIFT ..........
  10171.          L1 = L + 1
  10172.          S = DSQRT(E2(L))
  10173.          G = D(L)
  10174.          P = (D(L1) - G) / (2.0D0 * S)
  10175.          R = PYTHAG(P,1.0D0)
  10176.          D(L) = S / (P + DSIGN(R,P))
  10177.          H = G - D(L)
  10178. C
  10179.          DO 140 I = L1, N
  10180.   140    D(I) = D(I) - H
  10181. C
  10182.          F = F + H
  10183. C     .......... RATIONAL QL TRANSFORMATION ..........
  10184.          G = D(M)
  10185.          IF (G .EQ. 0.0D0) G = B
  10186.          H = G
  10187.          S = 0.0D0
  10188.          MML = M - L
  10189. C     .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
  10190.          DO 200 II = 1, MML
  10191.             I = M - II
  10192.             P = G * H
  10193.             R = P + E2(I)
  10194.             E2(I+1) = S * R
  10195.             S = E2(I) / R
  10196.             D(I+1) = H + S * (H + D(I))
  10197.             G = D(I) - E2(I) / G
  10198.             IF (G .EQ. 0.0D0) G = B
  10199.             H = G * P / R
  10200.   200    CONTINUE
  10201. C
  10202.          E2(L) = S * G
  10203.          D(L) = H
  10204. C     .......... GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST ..........
  10205.          IF (H .EQ. 0.0D0) GO TO 210
  10206.          IF (DABS(E2(L)) .LE. DABS(C/H)) GO TO 210
  10207.          E2(L) = H * E2(L)
  10208.          IF (E2(L) .NE. 0.0D0) GO TO 130
  10209.   210    P = D(L) + F
  10210. C     .......... ORDER EIGENVALUES ..........
  10211.          IF (L .EQ. 1) GO TO 250
  10212. C     .......... FOR I=L STEP -1 UNTIL 2 DO -- ..........
  10213.          DO 230 II = 2, L
  10214.             I = L + 2 - II
  10215.             IF (P .GE. D(I-1)) GO TO 270
  10216.             D(I) = D(I-1)
  10217.   230    CONTINUE
  10218. C
  10219.   250    I = 1
  10220.   270    D(I) = P
  10221.   290 CONTINUE
  10222. C
  10223.       GO TO 1001
  10224. C     .......... SET ERROR -- NO CONVERGENCE TO AN
  10225. C                EIGENVALUE AFTER 30 ITERATIONS ..........
  10226.  1000 IERR = L
  10227.  1001 RETURN
  10228.       END
  10229.       SUBROUTINE TRBAK1(NM,N,A,E,M,Z)
  10230. C
  10231.       INTEGER I,J,K,L,M,N,NM
  10232.       DOUBLE PRECISION A(NM,N),E(N),Z(NM,M)
  10233.       DOUBLE PRECISION S
  10234. C
  10235. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK1,
  10236. C     NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
  10237. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
  10238. C
  10239. C     THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC
  10240. C     MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
  10241. C     SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY  TRED1.
  10242. C
  10243. C     ON INPUT
  10244. C
  10245. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  10246. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  10247. C          DIMENSION STATEMENT.
  10248. C
  10249. C        N IS THE ORDER OF THE MATRIX.
  10250. C
  10251. C        A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS-
  10252. C          FORMATIONS USED IN THE REDUCTION BY  TRED1
  10253. C          IN ITS STRICT LOWER TRIANGLE.
  10254. C
  10255. C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
  10256. C          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS ARBITRARY.
  10257. C
  10258. C        M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
  10259. C
  10260. C        Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED
  10261. C          IN ITS FIRST M COLUMNS.
  10262. C
  10263. C     ON OUTPUT
  10264. C
  10265. C        Z CONTAINS THE TRANSFORMED EIGENVECTORS
  10266. C          IN ITS FIRST M COLUMNS.
  10267. C
  10268. C     NOTE THAT TRBAK1 PRESERVES VECTOR EUCLIDEAN NORMS.
  10269. C
  10270. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  10271. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  10272. C
  10273. C     THIS VERSION DATED AUGUST 1983.
  10274. C
  10275. C     ------------------------------------------------------------------
  10276. C
  10277.       IF (M .EQ. 0) GO TO 200
  10278.       IF (N .EQ. 1) GO TO 200
  10279. C
  10280.       DO 140 I = 2, N
  10281.          L = I - 1
  10282.          IF (E(I) .EQ. 0.0D0) GO TO 140
  10283. C
  10284.          DO 130 J = 1, M
  10285.             S = 0.0D0
  10286. C
  10287.             DO 110 K = 1, L
  10288.   110       S = S + A(I,K) * Z(K,J)
  10289. C     .......... DIVISOR BELOW IS NEGATIVE OF H FORMED IN TRED1.
  10290. C                DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ..........
  10291.             S = (S / A(I,L)) / E(I)
  10292. C
  10293.             DO 120 K = 1, L
  10294.   120       Z(K,J) = Z(K,J) + S * A(I,K)
  10295. C
  10296.   130    CONTINUE
  10297. C
  10298.   140 CONTINUE
  10299. C
  10300.   200 RETURN
  10301.       END
  10302.       SUBROUTINE TRBAK3(NM,N,NV,A,M,Z)
  10303. C
  10304.       INTEGER I,J,K,L,M,N,IK,IZ,NM,NV
  10305.       DOUBLE PRECISION A(NV),Z(NM,M)
  10306.       DOUBLE PRECISION H,S
  10307. C
  10308. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK3,
  10309. C     NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
  10310. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
  10311. C
  10312. C     THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC
  10313. C     MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
  10314. C     SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY  TRED3.
  10315. C
  10316. C     ON INPUT
  10317. C
  10318. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  10319. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  10320. C          DIMENSION STATEMENT.
  10321. C
  10322. C        N IS THE ORDER OF THE MATRIX.
  10323. C
  10324. C        NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A
  10325. C          AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT.
  10326. C
  10327. C        A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANSFORMATIONS
  10328. C          USED IN THE REDUCTION BY  TRED3  IN ITS FIRST
  10329. C          N*(N+1)/2 POSITIONS.
  10330. C
  10331. C        M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
  10332. C
  10333. C        Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED
  10334. C          IN ITS FIRST M COLUMNS.
  10335. C
  10336. C     ON OUTPUT
  10337. C
  10338. C        Z CONTAINS THE TRANSFORMED EIGENVECTORS
  10339. C          IN ITS FIRST M COLUMNS.
  10340. C
  10341. C     NOTE THAT TRBAK3 PRESERVES VECTOR EUCLIDEAN NORMS.
  10342. C
  10343. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  10344. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  10345. C
  10346. C     THIS VERSION DATED AUGUST 1983.
  10347. C
  10348. C     ------------------------------------------------------------------
  10349. C
  10350.       IF (M .EQ. 0) GO TO 200
  10351.       IF (N .EQ. 1) GO TO 200
  10352. C
  10353.       DO 140 I = 2, N
  10354.          L = I - 1
  10355.          IZ = (I * L) / 2
  10356.          IK = IZ + I
  10357.          H = A(IK)
  10358.          IF (H .EQ. 0.0D0) GO TO 140
  10359. C
  10360.          DO 130 J = 1, M
  10361.             S = 0.0D0
  10362.             IK = IZ
  10363. C
  10364.             DO 110 K = 1, L
  10365.                IK = IK + 1
  10366.                S = S + A(IK) * Z(K,J)
  10367.   110       CONTINUE
  10368. C     .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ..........
  10369.             S = (S / H) / H
  10370.             IK = IZ
  10371. C
  10372.             DO 120 K = 1, L
  10373.                IK = IK + 1
  10374.                Z(K,J) = Z(K,J) - S * A(IK)
  10375.   120       CONTINUE
  10376. C
  10377.   130    CONTINUE
  10378. C
  10379.   140 CONTINUE
  10380. C
  10381.   200 RETURN
  10382.       END
  10383.       SUBROUTINE TRED1(NM,N,A,D,E,E2)
  10384. C
  10385.       INTEGER I,J,K,L,N,II,NM,JP1
  10386.       DOUBLE PRECISION A(NM,N),D(N),E(N),E2(N)
  10387.       DOUBLE PRECISION F,G,H,SCALE
  10388. C
  10389. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED1,
  10390. C     NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
  10391. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
  10392. C
  10393. C     THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX
  10394. C     TO A SYMMETRIC TRIDIAGONAL MATRIX USING
  10395. C     ORTHOGONAL SIMILARITY TRANSFORMATIONS.
  10396. C
  10397. C     ON INPUT
  10398. C
  10399. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  10400. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  10401. C          DIMENSION STATEMENT.
  10402. C
  10403. C        N IS THE ORDER OF THE MATRIX.
  10404. C
  10405. C        A CONTAINS THE REAL SYMMETRIC INPUT MATRIX.  ONLY THE
  10406. C          LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED.
  10407. C
  10408. C     ON OUTPUT
  10409. C
  10410. C        A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS-
  10411. C          FORMATIONS USED IN THE REDUCTION IN ITS STRICT LOWER
  10412. C          TRIANGLE.  THE FULL UPPER TRIANGLE OF A IS UNALTERED.
  10413. C
  10414. C        D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX.
  10415. C
  10416. C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
  10417. C          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS SET TO ZERO.
  10418. C
  10419. C        E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
  10420. C          E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
  10421. C
  10422. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  10423. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  10424. C
  10425. C     THIS VERSION DATED AUGUST 1983.
  10426. C
  10427. C     ------------------------------------------------------------------
  10428. C
  10429.       DO 100 I = 1, N
  10430.          D(I) = A(N,I)
  10431.          A(N,I) = A(I,I)
  10432.   100 CONTINUE
  10433. C     .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
  10434.       DO 300 II = 1, N
  10435.          I = N + 1 - II
  10436.          L = I - 1
  10437.          H = 0.0D0
  10438.          SCALE = 0.0D0
  10439.          IF (L .LT. 1) GO TO 130
  10440. C     .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) ..........
  10441.          DO 120 K = 1, L
  10442.   120    SCALE = SCALE + DABS(D(K))
  10443. C
  10444.          IF (SCALE .NE. 0.0D0) GO TO 140
  10445. C
  10446.          DO 125 J = 1, L
  10447.             D(J) = A(L,J)
  10448.             A(L,J) = A(I,J)
  10449.             A(I,J) = 0.0D0
  10450.   125    CONTINUE
  10451. C
  10452.   130    E(I) = 0.0D0
  10453.          E2(I) = 0.0D0
  10454.          GO TO 300
  10455. C
  10456.   140    DO 150 K = 1, L
  10457.             D(K) = D(K) / SCALE
  10458.             H = H + D(K) * D(K)
  10459.   150    CONTINUE
  10460. C
  10461.          E2(I) = SCALE * SCALE * H
  10462.          F = D(L)
  10463.          G = -DSIGN(DSQRT(H),F)
  10464.          E(I) = SCALE * G
  10465.          H = H - F * G
  10466.          D(L) = F - G
  10467.          IF (L .EQ. 1) GO TO 285
  10468. C     .......... FORM A*U ..........
  10469.          DO 170 J = 1, L
  10470.   170    E(J) = 0.0D0
  10471. C
  10472.          DO 240 J = 1, L
  10473.             F = D(J)
  10474.             G = E(J) + A(J,J) * F
  10475.             JP1 = J + 1
  10476.             IF (L .LT. JP1) GO TO 220
  10477. C
  10478.             DO 200 K = JP1, L
  10479.                G = G + A(K,J) * D(K)
  10480.                E(K) = E(K) + A(K,J) * F
  10481.   200       CONTINUE
  10482. C
  10483.   220       E(J) = G
  10484.   240    CONTINUE
  10485. C     .......... FORM P ..........
  10486.          F = 0.0D0
  10487. C
  10488.          DO 245 J = 1, L
  10489.             E(J) = E(J) / H
  10490.             F = F + E(J) * D(J)
  10491.   245    CONTINUE
  10492. C
  10493.          H = F / (H + H)
  10494. C     .......... FORM Q ..........
  10495.          DO 250 J = 1, L
  10496.   250    E(J) = E(J) - H * D(J)
  10497. C     .......... FORM REDUCED A ..........
  10498.          DO 280 J = 1, L
  10499.             F = D(J)
  10500.             G = E(J)
  10501. C
  10502.             DO 260 K = J, L
  10503.   260       A(K,J) = A(K,J) - F * E(K) - G * D(K)
  10504. C
  10505.   280    CONTINUE
  10506. C
  10507.   285    DO 290 J = 1, L
  10508.             F = D(J)
  10509.             D(J) = A(L,J)
  10510.             A(L,J) = A(I,J)
  10511.             A(I,J) = F * SCALE
  10512.   290    CONTINUE
  10513. C
  10514.   300 CONTINUE
  10515. C
  10516.       RETURN
  10517.       END
  10518.       SUBROUTINE TRED2(NM,N,A,D,E,Z)
  10519. C
  10520.       INTEGER I,J,K,L,N,II,NM,JP1
  10521.       DOUBLE PRECISION A(NM,N),D(N),E(N),Z(NM,N)
  10522.       DOUBLE PRECISION F,G,H,HH,SCALE
  10523. C
  10524. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED2,
  10525. C     NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
  10526. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
  10527. C
  10528. C     THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX TO A
  10529. C     SYMMETRIC TRIDIAGONAL MATRIX USING AND ACCUMULATING
  10530. C     ORTHOGONAL SIMILARITY TRANSFORMATIONS.
  10531. C
  10532. C     ON INPUT
  10533. C
  10534. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  10535. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  10536. C          DIMENSION STATEMENT.
  10537. C
  10538. C        N IS THE ORDER OF THE MATRIX.
  10539. C
  10540. C        A CONTAINS THE REAL SYMMETRIC INPUT MATRIX.  ONLY THE
  10541. C          LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED.
  10542. C
  10543. C     ON OUTPUT
  10544. C
  10545. C        D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX.
  10546. C
  10547. C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
  10548. C          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS SET TO ZERO.
  10549. C
  10550. C        Z CONTAINS THE ORTHOGONAL TRANSFORMATION MATRIX
  10551. C          PRODUCED IN THE REDUCTION.
  10552. C
  10553. C        A AND Z MAY COINCIDE.  IF DISTINCT, A IS UNALTERED.
  10554. C
  10555. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  10556. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  10557. C
  10558. C     THIS VERSION DATED AUGUST 1983.
  10559. C
  10560. C     ------------------------------------------------------------------
  10561. C
  10562.       DO 100 I = 1, N
  10563. C
  10564.          DO 80 J = I, N
  10565.    80    Z(J,I) = A(J,I)
  10566. C
  10567.          D(I) = A(N,I)
  10568.   100 CONTINUE
  10569. C
  10570.       IF (N .EQ. 1) GO TO 510
  10571. C     .......... FOR I=N STEP -1 UNTIL 2 DO -- ..........
  10572.       DO 300 II = 2, N
  10573.          I = N + 2 - II
  10574.          L = I - 1
  10575.          H = 0.0D0
  10576.          SCALE = 0.0D0
  10577.          IF (L .LT. 2) GO TO 130
  10578. C     .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) ..........
  10579.          DO 120 K = 1, L
  10580.   120    SCALE = SCALE + DABS(D(K))
  10581. C
  10582.          IF (SCALE .NE. 0.0D0) GO TO 140
  10583.   130    E(I) = D(L)
  10584. C
  10585.          DO 135 J = 1, L
  10586.             D(J) = Z(L,J)
  10587.             Z(I,J) = 0.0D0
  10588.             Z(J,I) = 0.0D0
  10589.   135    CONTINUE
  10590. C
  10591.          GO TO 290
  10592. C
  10593.   140    DO 150 K = 1, L
  10594.             D(K) = D(K) / SCALE
  10595.             H = H + D(K) * D(K)
  10596.   150    CONTINUE
  10597. C
  10598.          F = D(L)
  10599.          G = -DSIGN(DSQRT(H),F)
  10600.          E(I) = SCALE * G
  10601.          H = H - F * G
  10602.          D(L) = F - G
  10603. C     .......... FORM A*U ..........
  10604.          DO 170 J = 1, L
  10605.   170    E(J) = 0.0D0
  10606. C
  10607.          DO 240 J = 1, L
  10608.             F = D(J)
  10609.             Z(J,I) = F
  10610.             G = E(J) + Z(J,J) * F
  10611.             JP1 = J + 1
  10612.             IF (L .LT. JP1) GO TO 220
  10613. C
  10614.             DO 200 K = JP1, L
  10615.                G = G + Z(K,J) * D(K)
  10616.                E(K) = E(K) + Z(K,J) * F
  10617.   200       CONTINUE
  10618. C
  10619.   220       E(J) = G
  10620.   240    CONTINUE
  10621. C     .......... FORM P ..........
  10622.          F = 0.0D0
  10623. C
  10624.          DO 245 J = 1, L
  10625.             E(J) = E(J) / H
  10626.             F = F + E(J) * D(J)
  10627.   245    CONTINUE
  10628. C
  10629.          HH = F / (H + H)
  10630. C     .......... FORM Q ..........
  10631.          DO 250 J = 1, L
  10632.   250    E(J) = E(J) - HH * D(J)
  10633. C     .......... FORM REDUCED A ..........
  10634.          DO 280 J = 1, L
  10635.             F = D(J)
  10636.             G = E(J)
  10637. C
  10638.             DO 260 K = J, L
  10639.   260       Z(K,J) = Z(K,J) - F * E(K) - G * D(K)
  10640. C
  10641.             D(J) = Z(L,J)
  10642.             Z(I,J) = 0.0D0
  10643.   280    CONTINUE
  10644. C
  10645.   290    D(I) = H
  10646.   300 CONTINUE
  10647. C     .......... ACCUMULATION OF TRANSFORMATION MATRICES ..........
  10648.       DO 500 I = 2, N
  10649.          L = I - 1
  10650.          Z(N,L) = Z(L,L)
  10651.          Z(L,L) = 1.0D0
  10652.          H = D(I)
  10653.          IF (H .EQ. 0.0D0) GO TO 380
  10654. C
  10655.          DO 330 K = 1, L
  10656.   330    D(K) = Z(K,I) / H
  10657. C
  10658.          DO 360 J = 1, L
  10659.             G = 0.0D0
  10660. C
  10661.             DO 340 K = 1, L
  10662.   340       G = G + Z(K,I) * Z(K,J)
  10663. C
  10664.             DO 360 K = 1, L
  10665.                Z(K,J) = Z(K,J) - G * D(K)
  10666.   360    CONTINUE
  10667. C
  10668.   380    DO 400 K = 1, L
  10669.   400    Z(K,I) = 0.0D0
  10670. C
  10671.   500 CONTINUE
  10672. C
  10673.   510 DO 520 I = 1, N
  10674.          D(I) = Z(N,I)
  10675.          Z(N,I) = 0.0D0
  10676.   520 CONTINUE
  10677. C
  10678.       Z(N,N) = 1.0D0
  10679.       E(1) = 0.0D0
  10680.       RETURN
  10681.       END
  10682.       SUBROUTINE TRED3(N,NV,A,D,E,E2)
  10683. C
  10684.       INTEGER I,J,K,L,N,II,IZ,JK,NV,JM1
  10685.       DOUBLE PRECISION A(NV),D(N),E(N),E2(N)
  10686.       DOUBLE PRECISION F,G,H,HH,SCALE
  10687. C
  10688. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED3,
  10689. C     NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
  10690. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
  10691. C
  10692. C     THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX, STORED AS
  10693. C     A ONE-DIMENSIONAL ARRAY, TO A SYMMETRIC TRIDIAGONAL MATRIX
  10694. C     USING ORTHOGONAL SIMILARITY TRANSFORMATIONS.
  10695. C
  10696. C     ON INPUT
  10697. C
  10698. C        N IS THE ORDER OF THE MATRIX.
  10699. C
  10700. C        NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A
  10701. C          AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT.
  10702. C
  10703. C        A CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC
  10704. C          INPUT MATRIX, STORED ROW-WISE AS A ONE-DIMENSIONAL
  10705. C          ARRAY, IN ITS FIRST N*(N+1)/2 POSITIONS.
  10706. C
  10707. C     ON OUTPUT
  10708. C
  10709. C        A CONTAINS INFORMATION ABOUT THE ORTHOGONAL
  10710. C          TRANSFORMATIONS USED IN THE REDUCTION.
  10711. C
  10712. C        D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX.
  10713. C
  10714. C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
  10715. C          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS SET TO ZERO.
  10716. C
  10717. C        E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
  10718. C          E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
  10719. C
  10720. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  10721. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  10722. C
  10723. C     THIS VERSION DATED AUGUST 1983.
  10724. C
  10725. C     ------------------------------------------------------------------
  10726. C
  10727. C     .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
  10728.       DO 300 II = 1, N
  10729.          I = N + 1 - II
  10730.          L = I - 1
  10731.          IZ = (I * L) / 2
  10732.          H = 0.0D0
  10733.          SCALE = 0.0D0
  10734.          IF (L .LT. 1) GO TO 130
  10735. C     .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) ..........
  10736.          DO 120 K = 1, L
  10737.             IZ = IZ + 1
  10738.             D(K) = A(IZ)
  10739.             SCALE = SCALE + DABS(D(K))
  10740.   120    CONTINUE
  10741. C
  10742.          IF (SCALE .NE. 0.0D0) GO TO 140
  10743.   130    E(I) = 0.0D0
  10744.          E2(I) = 0.0D0
  10745.          GO TO 290
  10746. C
  10747.   140    DO 150 K = 1, L
  10748.             D(K) = D(K) / SCALE
  10749.             H = H + D(K) * D(K)
  10750.   150    CONTINUE
  10751. C
  10752.          E2(I) = SCALE * SCALE * H
  10753.          F = D(L)
  10754.          G = -DSIGN(DSQRT(H),F)
  10755.          E(I) = SCALE * G
  10756.          H = H - F * G
  10757.          D(L) = F - G
  10758.          A(IZ) = SCALE * D(L)
  10759.          IF (L .EQ. 1) GO TO 290
  10760.          JK = 1
  10761. C
  10762.          DO 240 J = 1, L
  10763.             F = D(J)
  10764.             G = 0.0D0
  10765.             JM1 = J - 1
  10766.             IF (JM1 .LT. 1) GO TO 220
  10767. C
  10768.             DO 200 K = 1, JM1
  10769.                G = G + A(JK) * D(K)
  10770.                E(K) = E(K) + A(JK) * F
  10771.                JK = JK + 1
  10772.   200       CONTINUE
  10773. C     
  10774.   220       E(J) = G + A(JK) * F
  10775.             JK = JK + 1
  10776.   240    CONTINUE
  10777. C     .......... FORM P ..........
  10778.          F = 0.0D0
  10779. C
  10780.          DO 245 J = 1, L
  10781.             E(J) = E(J) / H
  10782.             F = F + E(J) * D(J)
  10783.   245    CONTINUE
  10784. C
  10785.          HH = F / (H + H)
  10786. C     .......... FORM Q ..........
  10787.          DO 250 J = 1, L
  10788.   250    E(J) = E(J) - HH * D(J)
  10789. C
  10790.          JK = 1
  10791. C     .......... FORM REDUCED A ..........
  10792.          DO 280 J = 1, L
  10793.             F = D(J)
  10794.             G = E(J)
  10795. C
  10796.             DO 260 K = 1, J
  10797.                A(JK) = A(JK) - F * E(K) - G * D(K)
  10798.                JK = JK + 1
  10799.   260       CONTINUE
  10800. C
  10801.   280    CONTINUE
  10802. C
  10803.   290    D(I) = A(IZ+1)
  10804.          A(IZ+1) = SCALE * DSQRT(H)
  10805.   300 CONTINUE
  10806. C
  10807.       RETURN
  10808.       END
  10809.       SUBROUTINE TRIDIB(N,EPS1,D,E,E2,LB,UB,M11,M,W,IND,IERR,RV4,RV5)
  10810. C
  10811.       INTEGER I,J,K,L,M,N,P,Q,R,S,II,M1,M2,M11,M22,TAG,IERR,ISTURM
  10812.       DOUBLE PRECISION D(N),E(N),E2(N),W(M),RV4(N),RV5(N)
  10813.       DOUBLE PRECISION U,V,LB,T1,T2,UB,XU,X0,X1,EPS1,TST1,TST2,EPSLON
  10814.       INTEGER IND(M)
  10815. C
  10816. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BISECT,
  10817. C     NUM. MATH. 9, 386-393(1967) BY BARTH, MARTIN, AND WILKINSON.
  10818. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 249-256(1971).
  10819. C
  10820. C     THIS SUBROUTINE FINDS THOSE EIGENVALUES OF A TRIDIAGONAL
  10821. C     SYMMETRIC MATRIX BETWEEN SPECIFIED BOUNDARY INDICES,
  10822. C     USING BISECTION.
  10823. C
  10824. C     ON INPUT
  10825. C
  10826. C        N IS THE ORDER OF THE MATRIX.
  10827. C
  10828. C        EPS1 IS AN ABSOLUTE ERROR TOLERANCE FOR THE COMPUTED
  10829. C          EIGENVALUES.  IF THE INPUT EPS1 IS NON-POSITIVE,
  10830. C          IT IS RESET FOR EACH SUBMATRIX TO A DEFAULT VALUE,
  10831. C          NAMELY, MINUS THE PRODUCT OF THE RELATIVE MACHINE
  10832. C          PRECISION AND THE 1-NORM OF THE SUBMATRIX.
  10833. C
  10834. C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
  10835. C
  10836. C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
  10837. C          IN ITS LAST N-1 POSITIONS.  E(1) IS ARBITRARY.
  10838. C
  10839. C        E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
  10840. C          E2(1) IS ARBITRARY.
  10841. C
  10842. C        M11 SPECIFIES THE LOWER BOUNDARY INDEX FOR THE DESIRED
  10843. C          EIGENVALUES.
  10844. C
  10845. C        M SPECIFIES THE NUMBER OF EIGENVALUES DESIRED.  THE UPPER
  10846. C          BOUNDARY INDEX M22 IS THEN OBTAINED AS M22=M11+M-1.
  10847. C
  10848. C     ON OUTPUT
  10849. C
  10850. C        EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS
  10851. C          (LAST) DEFAULT VALUE.
  10852. C
  10853. C        D AND E ARE UNALTERED.
  10854. C
  10855. C        ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED
  10856. C          AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE
  10857. C          MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES.
  10858. C          E2(1) IS ALSO SET TO ZERO.
  10859. C
  10860. C        LB AND UB DEFINE AN INTERVAL CONTAINING EXACTLY THE DESIRED
  10861. C          EIGENVALUES.
  10862. C
  10863. C        W CONTAINS, IN ITS FIRST M POSITIONS, THE EIGENVALUES
  10864. C          BETWEEN INDICES M11 AND M22 IN ASCENDING ORDER.
  10865. C
  10866. C        IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES
  10867. C          ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W --
  10868. C          1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM
  10869. C          THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC..
  10870. C
  10871. C        IERR IS SET TO
  10872. C          ZERO       FOR NORMAL RETURN,
  10873. C          3*N+1      IF MULTIPLE EIGENVALUES AT INDEX M11 MAKE
  10874. C                     UNIQUE SELECTION IMPOSSIBLE,
  10875. C          3*N+2      IF MULTIPLE EIGENVALUES AT INDEX M22 MAKE
  10876. C                     UNIQUE SELECTION IMPOSSIBLE.
  10877. C
  10878. C        RV4 AND RV5 ARE TEMPORARY STORAGE ARRAYS.
  10879. C
  10880. C     NOTE THAT SUBROUTINE TQL1, IMTQL1, OR TQLRAT IS GENERALLY FASTER
  10881. C     THAN TRIDIB, IF MORE THAN N/4 EIGENVALUES ARE TO BE FOUND.
  10882. C
  10883. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  10884. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  10885. C
  10886. C     THIS VERSION DATED AUGUST 1983.
  10887. C
  10888. C     ------------------------------------------------------------------
  10889. C
  10890.       IERR = 0
  10891.       TAG = 0
  10892.       XU = D(1)
  10893.       X0 = D(1)
  10894.       U = 0.0D0
  10895. C     .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES AND DETERMINE AN
  10896. C                INTERVAL CONTAINING ALL THE EIGENVALUES ..........
  10897.       DO 40 I = 1, N
  10898.          X1 = U
  10899.          U = 0.0D0
  10900.          IF (I .NE. N) U = DABS(E(I+1))
  10901.          XU = DMIN1(D(I)-(X1+U),XU)
  10902.          X0 = DMAX1(D(I)+(X1+U),X0)
  10903.          IF (I .EQ. 1) GO TO 20
  10904.          TST1 = DABS(D(I)) + DABS(D(I-1))
  10905.          TST2 = TST1 + DABS(E(I))
  10906.          IF (TST2 .GT. TST1) GO TO 40
  10907.    20    E2(I) = 0.0D0
  10908.    40 CONTINUE
  10909. C
  10910.       X1 = N
  10911.       X1 = X1 * EPSLON(DMAX1(DABS(XU),DABS(X0)))
  10912.       XU = XU - X1
  10913.       T1 = XU
  10914.       X0 = X0 + X1
  10915.       T2 = X0
  10916. C     .......... DETERMINE AN INTERVAL CONTAINING EXACTLY
  10917. C                THE DESIRED EIGENVALUES ..........
  10918.       P = 1
  10919.       Q = N
  10920.       M1 = M11 - 1
  10921.       IF (M1 .EQ. 0) GO TO 75
  10922.       ISTURM = 1
  10923.    50 V = X1
  10924.       X1 = XU + (X0 - XU) * 0.5D0
  10925.       IF (X1 .EQ. V) GO TO 980
  10926.       GO TO 320
  10927.    60 IF (S - M1) 65, 73, 70
  10928.    65 XU = X1
  10929.       GO TO 50
  10930.    70 X0 = X1
  10931.       GO TO 50
  10932.    73 XU = X1
  10933.       T1 = X1
  10934.    75 M22 = M1 + M
  10935.       IF (M22 .EQ. N) GO TO 90
  10936.       X0 = T2
  10937.       ISTURM = 2
  10938.       GO TO 50
  10939.    80 IF (S - M22) 65, 85, 70
  10940.    85 T2 = X1
  10941.    90 Q = 0
  10942.       R = 0
  10943. C     .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING
  10944. C                INTERVAL BY THE GERSCHGORIN BOUNDS ..........
  10945.   100 IF (R .EQ. M) GO TO 1001
  10946.       TAG = TAG + 1
  10947.       P = Q + 1
  10948.       XU = D(P)
  10949.       X0 = D(P)
  10950.       U = 0.0D0
  10951. C
  10952.       DO 120 Q = P, N
  10953.          X1 = U
  10954.          U = 0.0D0
  10955.          V = 0.0D0
  10956.          IF (Q .EQ. N) GO TO 110
  10957.          U = DABS(E(Q+1))
  10958.          V = E2(Q+1)
  10959.   110    XU = DMIN1(D(Q)-(X1+U),XU)
  10960.          X0 = DMAX1(D(Q)+(X1+U),X0)
  10961.          IF (V .EQ. 0.0D0) GO TO 140
  10962.   120 CONTINUE
  10963. C
  10964.   140 X1 = EPSLON(DMAX1(DABS(XU),DABS(X0)))
  10965.       IF (EPS1 .LE. 0.0D0) EPS1 = -X1
  10966.       IF (P .NE. Q) GO TO 180
  10967. C     .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL ..........
  10968.       IF (T1 .GT. D(P) .OR. D(P) .GE. T2) GO TO 940
  10969.       M1 = P
  10970.       M2 = P
  10971.       RV5(P) = D(P)
  10972.       GO TO 900
  10973.   180 X1 = X1 * (Q - P + 1)
  10974.       LB = DMAX1(T1,XU-X1)
  10975.       UB = DMIN1(T2,X0+X1)
  10976.       X1 = LB
  10977.       ISTURM = 3
  10978.       GO TO 320
  10979.   200 M1 = S + 1
  10980.       X1 = UB
  10981.       ISTURM = 4
  10982.       GO TO 320
  10983.   220 M2 = S
  10984.       IF (M1 .GT. M2) GO TO 940
  10985. C     .......... FIND ROOTS BY BISECTION ..........
  10986.       X0 = UB
  10987.       ISTURM = 5
  10988. C
  10989.       DO 240 I = M1, M2
  10990.          RV5(I) = UB
  10991.          RV4(I) = LB
  10992.   240 CONTINUE
  10993. C     .......... LOOP FOR K-TH EIGENVALUE
  10994. C                FOR K=M2 STEP -1 UNTIL M1 DO --
  10995. C                (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) ..........
  10996.       K = M2
  10997.   250    XU = LB
  10998. C     .......... FOR I=K STEP -1 UNTIL M1 DO -- ..........
  10999.          DO 260 II = M1, K
  11000.             I = M1 + K - II
  11001.             IF (XU .GE. RV4(I)) GO TO 260
  11002.             XU = RV4(I)
  11003.             GO TO 280
  11004.   260    CONTINUE
  11005. C
  11006.   280    IF (X0 .GT. RV5(K)) X0 = RV5(K)
  11007. C     .......... NEXT BISECTION STEP ..........
  11008.   300    X1 = (XU + X0) * 0.5D0
  11009.          IF ((X0 - XU) .LE. DABS(EPS1)) GO TO 420
  11010.          TST1 = 2.0D0 * (DABS(XU) + DABS(X0))
  11011.          TST2 = TST1 + (X0 - XU)
  11012.          IF (TST2 .EQ. TST1) GO TO 420
  11013. C     .......... IN-LINE PROCEDURE FOR STURM SEQUENCE ..........
  11014.   320    S = P - 1
  11015.          U = 1.0D0
  11016. C
  11017.          DO 340 I = P, Q
  11018.             IF (U .NE. 0.0D0) GO TO 325
  11019.             V = DABS(E(I)) / EPSLON(1.0D0)
  11020.             IF (E2(I) .EQ. 0.0D0) V = 0.0D0
  11021.             GO TO 330
  11022.   325       V = E2(I) / U
  11023.   330       U = D(I) - X1 - V
  11024.             IF (U .LT. 0.0D0) S = S + 1
  11025.   340    CONTINUE
  11026. C
  11027.          GO TO (60,80,200,220,360), ISTURM
  11028. C     .......... REFINE INTERVALS ..........
  11029.   360    IF (S .GE. K) GO TO 400
  11030.          XU = X1
  11031.          IF (S .GE. M1) GO TO 380
  11032.          RV4(M1) = X1
  11033.          GO TO 300
  11034.   380    RV4(S+1) = X1
  11035.          IF (RV5(S) .GT. X1) RV5(S) = X1
  11036.          GO TO 300
  11037.   400    X0 = X1
  11038.          GO TO 300
  11039. C     .......... K-TH EIGENVALUE FOUND ..........
  11040.   420    RV5(K) = X1
  11041.       K = K - 1
  11042.       IF (K .GE. M1) GO TO 250
  11043. C     .......... ORDER EIGENVALUES TAGGED WITH THEIR
  11044. C                SUBMATRIX ASSOCIATIONS ..........
  11045.   900 S = R
  11046.       R = R + M2 - M1 + 1
  11047.       J = 1
  11048.       K = M1
  11049. C
  11050.       DO 920 L = 1, R
  11051.          IF (J .GT. S) GO TO 910
  11052.          IF (K .GT. M2) GO TO 940
  11053.          IF (RV5(K) .GE. W(L)) GO TO 915
  11054. C
  11055.          DO 905 II = J, S
  11056.             I = L + S - II
  11057.             W(I+1) = W(I)
  11058.             IND(I+1) = IND(I)
  11059.   905    CONTINUE
  11060. C
  11061.   910    W(L) = RV5(K)
  11062.          IND(L) = TAG
  11063.          K = K + 1
  11064.          GO TO 920
  11065.   915    J = J + 1
  11066.   920 CONTINUE
  11067. C
  11068.   940 IF (Q .LT. N) GO TO 100
  11069.       GO TO 1001
  11070. C     .......... SET ERROR -- INTERVAL CANNOT BE FOUND CONTAINING
  11071. C                EXACTLY THE DESIRED EIGENVALUES ..........
  11072.   980 IERR = 3 * N + ISTURM
  11073.  1001 LB = T1
  11074.       UB = T2
  11075.       RETURN
  11076.       END
  11077.       SUBROUTINE TSTURM(NM,N,EPS1,D,E,E2,LB,UB,MM,M,W,Z,
  11078.      X                  IERR,RV1,RV2,RV3,RV4,RV5,RV6)
  11079. C
  11080.       INTEGER I,J,K,M,N,P,Q,R,S,II,IP,JJ,MM,M1,M2,NM,ITS,
  11081.      X        IERR,GROUP,ISTURM
  11082.       DOUBLE PRECISION D(N),E(N),E2(N),W(MM),Z(NM,MM),
  11083.      X       RV1(N),RV2(N),RV3(N),RV4(N),RV5(N),RV6(N)
  11084.       DOUBLE PRECISION U,V,LB,T1,T2,UB,UK,XU,X0,X1,EPS1,EPS2,EPS3,EPS4,
  11085.      X       NORM,TST1,TST2,EPSLON,PYTHAG
  11086. C
  11087. C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRISTURM
  11088. C     BY PETERS AND WILKINSON.
  11089. C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971).
  11090. C
  11091. C     THIS SUBROUTINE FINDS THOSE EIGENVALUES OF A TRIDIAGONAL
  11092. C     SYMMETRIC MATRIX WHICH LIE IN A SPECIFIED INTERVAL AND THEIR
  11093. C     ASSOCIATED EIGENVECTORS, USING BISECTION AND INVERSE ITERATION.
  11094. C
  11095. C     ON INPUT
  11096. C
  11097. C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
  11098. C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
  11099. C          DIMENSION STATEMENT.
  11100. C
  11101. C        N IS THE ORDER OF THE MATRIX.
  11102. C
  11103. C        EPS1 IS AN ABSOLUTE ERROR TOLERANCE FOR THE COMPUTED
  11104. C          EIGENVALUES.  IT SHOULD BE CHOSEN COMMENSURATE WITH
  11105. C          RELATIVE PERTURBATIONS IN THE MATRIX ELEMENTS OF THE
  11106. C          ORDER OF THE RELATIVE MACHINE PRECISION.  IF THE
  11107. C          INPUT EPS1 IS NON-POSITIVE, IT IS RESET FOR EACH
  11108. C          SUBMATRIX TO A DEFAULT VALUE, NAMELY, MINUS THE
  11109. C          PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE
  11110. C          1-NORM OF THE SUBMATRIX.
  11111. C
  11112. C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
  11113. C
  11114. C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
  11115. C          IN ITS LAST N-1 POSITIONS.  E(1) IS ARBITRARY.
  11116. C
  11117. C        E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
  11118. C          E2(1) IS ARBITRARY.
  11119. C
  11120. C        LB AND UB DEFINE THE INTERVAL TO BE SEARCHED FOR EIGENVALUES.
  11121. C          IF LB IS NOT LESS THAN UB, NO EIGENVALUES WILL BE FOUND.
  11122. C
  11123. C        MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF
  11124. C          EIGENVALUES IN THE INTERVAL.  WARNING. IF MORE THAN
  11125. C          MM EIGENVALUES ARE DETERMINED TO LIE IN THE INTERVAL,
  11126. C          AN ERROR RETURN IS MADE WITH NO VALUES OR VECTORS FOUND.
  11127. C
  11128. C     ON OUTPUT
  11129. C
  11130. C        EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS
  11131. C          (LAST) DEFAULT VALUE.
  11132. C
  11133. C        D AND E ARE UNALTERED.
  11134. C
  11135. C        ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED
  11136. C          AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE
  11137. C          MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES.
  11138. C          E2(1) IS ALSO SET TO ZERO.
  11139. C
  11140. C        M IS THE NUMBER OF EIGENVALUES DETERMINED TO LIE IN (LB,UB).
  11141. C
  11142. C        W CONTAINS THE M EIGENVALUES IN ASCENDING ORDER IF THE MATRIX
  11143. C          DOES NOT SPLIT.  IF THE MATRIX SPLITS, THE EIGENVALUES ARE
  11144. C          IN ASCENDING ORDER FOR EACH SUBMATRIX.  IF A VECTOR ERROR
  11145. C          EXIT IS MADE, W CONTAINS THOSE VALUES ALREADY FOUND.
  11146. C
  11147. C        Z CONTAINS THE ASSOCIATED SET OF ORTHONORMAL EIGENVECTORS.
  11148. C          IF AN ERROR EXIT IS MADE, Z CONTAINS THOSE VECTORS
  11149. C          ALREADY FOUND.
  11150. C
  11151. C        IERR IS SET TO
  11152. C          ZERO       FOR NORMAL RETURN,
  11153. C          3*N+1      IF M EXCEEDS MM.
  11154. C          4*N+R      IF THE EIGENVECTOR CORRESPONDING TO THE R-TH
  11155. C                     EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS.
  11156. C
  11157. C        RV1, RV2, RV3, RV4, RV5, AND RV6 ARE TEMPORARY STORAGE ARRAYS.
  11158. C
  11159. C     THE ALGOL PROCEDURE STURMCNT CONTAINED IN TRISTURM
  11160. C     APPEARS IN TSTURM IN-LINE.
  11161. C
  11162. C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
  11163. C
  11164. C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
  11165. C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
  11166. C
  11167. C     THIS VERSION DATED AUGUST 1983.
  11168. C
  11169. C     ------------------------------------------------------------------
  11170. C
  11171.       IERR = 0
  11172.       T1 = LB
  11173.       T2 = UB
  11174. C     .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES ..........
  11175.       DO 40 I = 1, N
  11176.          IF (I .EQ. 1) GO TO 20
  11177.          TST1 = DABS(D(I)) + DABS(D(I-1))
  11178.          TST2 = TST1 + DABS(E(I))
  11179.          IF (TST2 .GT. TST1) GO TO 40
  11180.    20    E2(I) = 0.0D0
  11181.    40 CONTINUE
  11182. C     .......... DETERMINE THE NUMBER OF EIGENVALUES
  11183. C                IN THE INTERVAL ..........
  11184.       P = 1
  11185.       Q = N
  11186.       X1 = UB
  11187.       ISTURM = 1
  11188.       GO TO 320
  11189.    60 M = S
  11190.       X1 = LB
  11191.       ISTURM = 2
  11192.       GO TO 320
  11193.    80 M = M - S
  11194.       IF (M .GT. MM) GO TO 980
  11195.       Q = 0
  11196.       R = 0
  11197. C     .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING
  11198. C                INTERVAL BY THE GERSCHGORIN BOUNDS ..........
  11199.   100 IF (R .EQ. M) GO TO 1001
  11200.       P = Q + 1
  11201.       XU = D(P)
  11202.       X0 = D(P)
  11203.       U = 0.0D0
  11204. C
  11205.       DO 120 Q = P, N
  11206.          X1 = U
  11207.          U = 0.0D0
  11208.          V = 0.0D0
  11209.          IF (Q .EQ. N) GO TO 110
  11210.          U = DABS(E(Q+1))
  11211.          V = E2(Q+1)
  11212.   110    XU = DMIN1(D(Q)-(X1+U),XU)
  11213.          X0 = DMAX1(D(Q)+(X1+U),X0)
  11214.          IF (V .EQ. 0.0D0) GO TO 140
  11215.   120 CONTINUE
  11216. C
  11217.   140 X1 = EPSLON(DMAX1(DABS(XU),DABS(X0)))
  11218.       IF (EPS1 .LE. 0.0D0) EPS1 = -X1
  11219.       IF (P .NE. Q) GO TO 180
  11220. C     .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL ..........
  11221.       IF (T1 .GT. D(P) .OR. D(P) .GE. T2) GO TO 940
  11222.       R = R + 1
  11223. C
  11224.       DO 160 I = 1, N
  11225.   160 Z(I,R) = 0.0D0
  11226. C
  11227.       W(R) = D(P)
  11228.       Z(P,R) = 1.0D0
  11229.       GO TO 940
  11230.   180 U = Q-P+1
  11231.       X1 = U * X1
  11232.       LB = DMAX1(T1,XU-X1)
  11233.       UB = DMIN1(T2,X0+X1)
  11234.       X1 = LB
  11235.       ISTURM = 3
  11236.       GO TO 320
  11237.   200 M1 = S + 1
  11238.       X1 = UB
  11239.       ISTURM = 4
  11240.       GO TO 320
  11241.   220 M2 = S
  11242.       IF (M1 .GT. M2) GO TO 940
  11243. C     .......... FIND ROOTS BY BISECTION ..........
  11244.       X0 = UB
  11245.       ISTURM = 5
  11246. C
  11247.       DO 240 I = M1, M2
  11248.          RV5(I) = UB
  11249.          RV4(I) = LB
  11250.   240 CONTINUE
  11251. C     .......... LOOP FOR K-TH EIGENVALUE
  11252. C                FOR K=M2 STEP -1 UNTIL M1 DO --
  11253. C                (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) ..........
  11254.       K = M2
  11255.   250    XU = LB
  11256. C     .......... FOR I=K STEP -1 UNTIL M1 DO -- ..........
  11257.          DO 260 II = M1, K
  11258.             I = M1 + K - II
  11259.             IF (XU .GE. RV4(I)) GO TO 260
  11260.             XU = RV4(I)
  11261.             GO TO 280
  11262.   260    CONTINUE
  11263. C
  11264.   280    IF (X0 .GT. RV5(K)) X0 = RV5(K)
  11265. C     .......... NEXT BISECTION STEP ..........
  11266.   300    X1 = (XU + X0) * 0.5D0
  11267.          IF ((X0 - XU) .LE. DABS(EPS1)) GO TO 420
  11268.          TST1 = 2.0D0 * (DABS(XU) + DABS(X0))
  11269.          TST2 = TST1 + (X0 - XU)
  11270.          IF (TST2 .EQ. TST1) GO TO 420
  11271. C     .......... IN-LINE PROCEDURE FOR STURM SEQUENCE ..........
  11272.   320    S = P - 1
  11273.          U = 1.0D0
  11274. C
  11275.          DO 340 I = P, Q
  11276.             IF (U .NE. 0.0D0) GO TO 325
  11277.             V = DABS(E(I)) / EPSLON(1.0D0)
  11278.             IF (E2(I) .EQ. 0.0D0) V = 0.0D0
  11279.             GO TO 330
  11280.   325       V = E2(I) / U
  11281.   330       U = D(I) - X1 - V
  11282.             IF (U .LT. 0.0D0) S = S + 1
  11283.   340    CONTINUE
  11284. C
  11285.          GO TO (60,80,200,220,360), ISTURM
  11286. C     .......... REFINE INTERVALS ..........
  11287.   360    IF (S .GE. K) GO TO 400
  11288.          XU = X1
  11289.          IF (S .GE. M1) GO TO 380
  11290.          RV4(M1) = X1
  11291.          GO TO 300
  11292.   380    RV4(S+1) = X1
  11293.          IF (RV5(S) .GT. X1) RV5(S) = X1
  11294.          GO TO 300
  11295.   400    X0 = X1
  11296.          GO TO 300
  11297. C     .......... K-TH EIGENVALUE FOUND ..........
  11298.   420    RV5(K) = X1
  11299.       K = K - 1
  11300.       IF (K .GE. M1) GO TO 250
  11301. C     .......... FIND VECTORS BY INVERSE ITERATION ..........
  11302.       NORM = DABS(D(P))
  11303.       IP = P + 1
  11304. C
  11305.       DO 500 I = IP, Q
  11306.   500 NORM = DMAX1(NORM, DABS(D(I)) + DABS(E(I)))
  11307. C     .......... EPS2 IS THE CRITERION FOR GROUPING,
  11308. C                EPS3 REPLACES ZERO PIVOTS AND EQUAL
  11309. C                ROOTS ARE MODIFIED BY EPS3,
  11310. C                EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW ..........
  11311.       EPS2 = 1.0D-3 * NORM
  11312.       EPS3 = EPSLON(NORM)
  11313.       UK = Q - P + 1
  11314.       EPS4 = UK * EPS3
  11315.       UK = EPS4 / DSQRT(UK)
  11316.       GROUP = 0
  11317.       S = P
  11318. C
  11319.       DO 920 K = M1, M2
  11320.          R = R + 1
  11321.          ITS = 1
  11322.          W(R) = RV5(K)
  11323.          X1 = RV5(K)
  11324. C     .......... LOOK FOR CLOSE OR COINCIDENT ROOTS ..........
  11325.          IF (K .EQ. M1) GO TO 520
  11326.          IF (X1 - X0 .GE. EPS2) GROUP = -1
  11327.          GROUP = GROUP + 1
  11328.          IF (X1 .LE. X0) X1 = X0 + EPS3
  11329. C     .......... ELIMINATION WITH INTERCHANGES AND
  11330. C                INITIALIZATION OF VECTOR ..........
  11331.   520    V = 0.0D0
  11332. C
  11333.          DO 580 I = P, Q
  11334.             RV6(I) = UK
  11335.             IF (I .EQ. P) GO TO 560
  11336.             IF (DABS(E(I)) .LT. DABS(U)) GO TO 540
  11337.             XU = U / E(I)
  11338.             RV4(I) = XU
  11339.             RV1(I-1) = E(I)
  11340.             RV2(I-1) = D(I) - X1
  11341.             RV3(I-1) = 0.0D0
  11342.             IF (I .NE. Q) RV3(I-1) = E(I+1)
  11343.             U = V - XU * RV2(I-1)
  11344.             V = -XU * RV3(I-1)
  11345.             GO TO 580
  11346.   540       XU = E(I) / U
  11347.             RV4(I) = XU
  11348.             RV1(I-1) = U
  11349.             RV2(I-1) = V
  11350.             RV3(I-1) = 0.0D0
  11351.   560       U = D(I) - X1 - XU * V
  11352.             IF (I .NE. Q) V = E(I+1)
  11353.   580    CONTINUE
  11354. C
  11355.          IF (U .EQ. 0.0D0) U = EPS3
  11356.          RV1(Q) = U
  11357.          RV2(Q) = 0.0D0
  11358.          RV3(Q) = 0.0D0
  11359. C     .......... BACK SUBSTITUTION
  11360. C                FOR I=Q STEP -1 UNTIL P DO -- ..........
  11361.   600    DO 620 II = P, Q
  11362.             I = P + Q - II
  11363.             RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I)
  11364.             V = U
  11365.             U = RV6(I)
  11366.   620    CONTINUE
  11367. C     .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS
  11368. C                MEMBERS OF GROUP ..........
  11369.          IF (GROUP .EQ. 0) GO TO 700
  11370. C
  11371.          DO 680 JJ = 1, GROUP
  11372.             J = R - GROUP - 1 + JJ
  11373.             XU = 0.0D0
  11374. C
  11375.             DO 640 I = P, Q
  11376.   640       XU = XU + RV6(I) * Z(I,J)
  11377. C
  11378.             DO 660 I = P, Q
  11379.   660       RV6(I) = RV6(I) - XU * Z(I,J)
  11380. C
  11381.   680    CONTINUE
  11382. C
  11383.   700    NORM = 0.0D0
  11384. C
  11385.          DO 720 I = P, Q
  11386.   720    NORM = NORM + DABS(RV6(I))
  11387. C
  11388.          IF (NORM .GE. 1.0D0) GO TO 840
  11389. C     .......... FORWARD SUBSTITUTION ..........
  11390.          IF (ITS .EQ. 5) GO TO 960
  11391.          IF (NORM .NE. 0.0D0) GO TO 740
  11392.          RV6(S) = EPS4
  11393.          S = S + 1
  11394.          IF (S .GT. Q) S = P
  11395.          GO TO 780
  11396.   740    XU = EPS4 / NORM
  11397. C
  11398.          DO 760 I = P, Q
  11399.   760    RV6(I) = RV6(I) * XU
  11400. C     .......... ELIMINATION OPERATIONS ON NEXT VECTOR
  11401. C                ITERATE ..........
  11402.   780    DO 820 I = IP, Q
  11403.             U = RV6(I)
  11404. C     .......... IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE
  11405. C                WAS PERFORMED EARLIER IN THE
  11406. C                TRIANGULARIZATION PROCESS ..........
  11407.             IF (RV1(I-1) .NE. E(I)) GO TO 800
  11408.             U = RV6(I-1)
  11409.             RV6(I-1) = RV6(I)
  11410.   800       RV6(I) = U - RV4(I) * RV6(I-1)
  11411.   820    CONTINUE
  11412. C
  11413.          ITS = ITS + 1
  11414.          GO TO 600
  11415. C     .......... NORMALIZE SO THAT SUM OF SQUARES IS
  11416. C                1 AND EXPAND TO FULL ORDER ..........
  11417.   840    U = 0.0D0
  11418. C
  11419.          DO 860 I = P, Q
  11420.   860    U = PYTHAG(U,RV6(I))
  11421. C
  11422.          XU = 1.0D0 / U
  11423. C
  11424.          DO 880 I = 1, N
  11425.   880    Z(I,R) = 0.0D0
  11426. C
  11427.          DO 900 I = P, Q
  11428.   900    Z(I,R) = RV6(I) * XU
  11429. C
  11430.          X0 = X1
  11431.   920 CONTINUE
  11432. C
  11433.   940 IF (Q .LT. N) GO TO 100
  11434.       GO TO 1001
  11435. C     .......... SET ERROR -- NON-CONVERGED EIGENVECTOR ..........
  11436.   960 IERR = 4 * N + R
  11437.       GO TO 1001
  11438. C     .......... SET ERROR -- UNDERESTIMATE OF NUMBER OF
  11439. C                EIGENVALUES IN INTERVAL ..........
  11440.   980 IERR = 3 * N + 1
  11441.  1001 LB = T1
  11442.       UB = T2
  11443.       RETURN
  11444.       END
  11445.