1 SUBROUTINE CDIV(AR,AI,BR,BI,CR,CI) 2 DOUBLE PRECISION AR,AI,BR,BI,CR,CI 3C 4C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI) 5C 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 19C 20C (YR,YI) = COMPLEX DSQRT(XR,XI) 21C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI) 22C 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 36C 37C ESTIMATE UNIT ROUNDOFF IN QUANTITIES OF SIZE X. 38C 39 DOUBLE PRECISION A,B,C,EPS 40C 41C THIS PROGRAM SHOULD FUNCTION PROPERLY ON ALL SYSTEMS 42C SATISFYING THE FOLLOWING TWO ASSUMPTIONS, 43C 1. THE BASE USED IN REPRESENTING FLOATING POINT 44C NUMBERS IS NOT A POWER OF THREE. 45C 2. THE QUANTITY A IN STATEMENT 10 IS REPRESENTED TO 46C THE ACCURACY USED IN FLOATING POINT VARIABLES 47C THAT ARE STORED IN MEMORY. 48C THE STATEMENT NUMBER 10 AND THE GO TO 10 ARE INTENDED TO 49C FORCE OPTIMIZING COMPILERS TO GENERATE CODE SATISFYING 50C ASSUMPTION 2. 51C UNDER THESE ASSUMPTIONS, IT SHOULD BE TRUE THAT, 52C A IS NOT EXACTLY EQUAL TO FOUR-THIRDS, 53C B HAS A ZERO FOR ITS LAST BIT OR DIGIT, 54C C IS NOT EXACTLY EQUAL TO ONE, 55C EPS MEASURES THE SEPARATION OF 1.0 FROM 56C THE NEXT LARGER FLOATING POINT NUMBER. 57C THE DEVELOPERS OF EISPACK WOULD APPRECIATE BEING INFORMED 58C ABOUT ANY SYSTEMS WHERE THESE ASSUMPTIONS DO NOT HOLD. 59C 60C THIS VERSION DATED 4/6/83. 61C 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 72C 73C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW 74C 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) 91C 92 INTEGER I,J,M,N,NM,IERR 93 DOUBLE PRECISION T(NM,3),E(N),Z(NM,M) 94C 95C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A NONSYMMETRIC 96C TRIDIAGONAL MATRIX BY BACK TRANSFORMING THOSE OF THE 97C CORRESPONDING SYMMETRIC MATRIX DETERMINED BY FIGI. 98C 99C ON INPUT 100C 101C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 102C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 103C DIMENSION STATEMENT. 104C 105C N IS THE ORDER OF THE MATRIX. 106C 107C T CONTAINS THE NONSYMMETRIC MATRIX. ITS SUBDIAGONAL IS 108C STORED IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN, 109C ITS DIAGONAL IN THE N POSITIONS OF THE SECOND COLUMN, 110C AND ITS SUPERDIAGONAL IN THE FIRST N-1 POSITIONS OF 111C THE THIRD COLUMN. T(1,1) AND T(N,3) ARE ARBITRARY. 112C 113C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE SYMMETRIC 114C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. 115C 116C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. 117C 118C Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED 119C IN ITS FIRST M COLUMNS. 120C 121C ON OUTPUT 122C 123C T IS UNALTERED. 124C 125C E IS DESTROYED. 126C 127C Z CONTAINS THE TRANSFORMED EIGENVECTORS 128C IN ITS FIRST M COLUMNS. 129C 130C IERR IS SET TO 131C ZERO FOR NORMAL RETURN, 132C 2*N+I IF E(I) IS ZERO WITH T(I,1) OR T(I-1,3) NON-ZERO. 133C IN THIS CASE, THE SYMMETRIC MATRIX IS NOT SIMILAR 134C TO THE ORIGINAL MATRIX, AND THE EIGENVECTORS 135C CANNOT BE FOUND BY THIS PROGRAM. 136C 137C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 138C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 139C 140C THIS VERSION DATED AUGUST 1983. 141C 142C ------------------------------------------------------------------ 143C 144 IERR = 0 145 IF (M .EQ. 0) GO TO 1001 146 E(1) = 1.0D0 147 IF (N .EQ. 1) GO TO 1001 148C 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 156C 157 DO 120 J = 1, M 158C 159 DO 120 I = 2, N 160 Z(I,J) = Z(I,J) * E(I) 161 120 CONTINUE 162C 163 GO TO 1001 164C .......... SET ERROR -- EIGENVECTORS CANNOT BE 165C FOUND BY THIS PROGRAM .......... 166 1000 IERR = 2 * N + I 167 1001 RETURN 168 END 169 SUBROUTINE BALANC(NM,N,A,LOW,IGH,SCALE) 170C 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 175C 176C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALANCE, 177C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. 178C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). 179C 180C THIS SUBROUTINE BALANCES A REAL MATRIX AND ISOLATES 181C EIGENVALUES WHENEVER POSSIBLE. 182C 183C ON INPUT 184C 185C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 186C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 187C DIMENSION STATEMENT. 188C 189C N IS THE ORDER OF THE MATRIX. 190C 191C A CONTAINS THE INPUT MATRIX TO BE BALANCED. 192C 193C ON OUTPUT 194C 195C A CONTAINS THE BALANCED MATRIX. 196C 197C LOW AND IGH ARE TWO INTEGERS SUCH THAT A(I,J) 198C IS EQUAL TO ZERO IF 199C (1) I IS GREATER THAN J AND 200C (2) J=1,...,LOW-1 OR I=IGH+1,...,N. 201C 202C SCALE CONTAINS INFORMATION DETERMINING THE 203C PERMUTATIONS AND SCALING FACTORS USED. 204C 205C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH 206C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED 207C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS 208C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN 209C SCALE(J) = P(J), FOR J = 1,...,LOW-1 210C = D(J,J), J = LOW,...,IGH 211C = P(J) J = IGH+1,...,N. 212C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1, 213C THEN 1 TO LOW-1. 214C 215C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY. 216C 217C THE ALGOL PROCEDURE EXC CONTAINED IN BALANCE APPEARS IN 218C BALANC IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS 219C K,L HAVE BEEN REVERSED.) 220C 221C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 222C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 223C 224C THIS VERSION DATED AUGUST 1983. 225C 226C ------------------------------------------------------------------ 227C 228 RADIX = 16.0D0 229C 230 B2 = RADIX * RADIX 231 K = 1 232 L = N 233 GO TO 100 234C .......... IN-LINE PROCEDURE FOR ROW AND 235C COLUMN EXCHANGE .......... 236 20 SCALE(M) = J 237 IF (J .EQ. M) GO TO 50 238C 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 244C 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 250C 251 50 GO TO (80,130), IEXC 252C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE 253C AND PUSH THEM DOWN .......... 254 80 IF (L .EQ. 1) GO TO 280 255 L = L - 1 256C .......... FOR J=L STEP -1 UNTIL 1 DO -- .......... 257 100 DO 120 JJ = 1, L 258 J = L + 1 - JJ 259C 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 264C 265 M = L 266 IEXC = 1 267 GO TO 20 268 120 CONTINUE 269C 270 GO TO 140 271C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE 272C AND PUSH THEM LEFT .......... 273 130 K = K + 1 274C 275 140 DO 170 J = K, L 276C 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 281C 282 M = K 283 IEXC = 2 284 GO TO 20 285 170 CONTINUE 286C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L .......... 287 DO 180 I = K, L 288 180 SCALE(I) = 1.0D0 289C .......... ITERATIVE LOOP FOR NORM REDUCTION .......... 290 190 NOCONV = .FALSE. 291C 292 DO 270 I = K, L 293 C = 0.0D0 294 R = 0.0D0 295C 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 301C .......... 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 315C .......... 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. 320C 321 DO 250 J = K, N 322 250 A(I,J) = A(I,J) * G 323C 324 DO 260 J = 1, L 325 260 A(J,I) = A(J,I) * F 326C 327 270 CONTINUE 328C 329 IF (NOCONV) GO TO 190 330C 331 280 LOW = K 332 IGH = L 333 RETURN 334 END 335 SUBROUTINE BALBAK(NM,N,LOW,IGH,SCALE,M,Z) 336C 337 INTEGER I,J,K,M,N,II,NM,IGH,LOW 338 DOUBLE PRECISION SCALE(N),Z(NM,M) 339 DOUBLE PRECISION S 340C 341C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALBAK, 342C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. 343C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). 344C 345C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL GENERAL 346C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING 347C BALANCED MATRIX DETERMINED BY BALANC. 348C 349C ON INPUT 350C 351C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 352C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 353C DIMENSION STATEMENT. 354C 355C N IS THE ORDER OF THE MATRIX. 356C 357C LOW AND IGH ARE INTEGERS DETERMINED BY BALANC. 358C 359C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS 360C AND SCALING FACTORS USED BY BALANC. 361C 362C M IS THE NUMBER OF COLUMNS OF Z TO BE BACK TRANSFORMED. 363C 364C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGEN- 365C VECTORS TO BE BACK TRANSFORMED IN ITS FIRST M COLUMNS. 366C 367C ON OUTPUT 368C 369C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE 370C TRANSFORMED EIGENVECTORS IN ITS FIRST M COLUMNS. 371C 372C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 373C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 374C 375C THIS VERSION DATED AUGUST 1983. 376C 377C ------------------------------------------------------------------ 378C 379 IF (M .EQ. 0) GO TO 200 380 IF (IGH .EQ. LOW) GO TO 120 381C 382 DO 110 I = LOW, IGH 383 S = SCALE(I) 384C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED 385C IF THE FOREGOING STATEMENT IS REPLACED BY 386C S=1.0D0/SCALE(I). .......... 387 DO 100 J = 1, M 388 100 Z(I,J) = Z(I,J) * S 389C 390 110 CONTINUE 391C ......... FOR I=LOW-1 STEP -1 UNTIL 1, 392C 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 399C 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 405C 406 140 CONTINUE 407C 408 200 RETURN 409 END 410 SUBROUTINE BANDR(NM,N,MB,A,D,E,E2,MATZ,Z) 411C 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 integer*4 ii4 417C 418C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BANDRD, 419C NUM. MATH. 12, 231-241(1968) BY SCHWARZ. 420C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 273-283(1971). 421C 422C THIS SUBROUTINE REDUCES A REAL SYMMETRIC BAND MATRIX 423C TO A SYMMETRIC TRIDIAGONAL MATRIX USING AND OPTIONALLY 424C ACCUMULATING ORTHOGONAL SIMILARITY TRANSFORMATIONS. 425C 426C ON INPUT 427C 428C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 429C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 430C DIMENSION STATEMENT. 431C 432C N IS THE ORDER OF THE MATRIX. 433C 434C MB IS THE (HALF) BAND WIDTH OF THE MATRIX, DEFINED AS THE 435C NUMBER OF ADJACENT DIAGONALS, INCLUDING THE PRINCIPAL 436C DIAGONAL, REQUIRED TO SPECIFY THE NON-ZERO PORTION OF THE 437C LOWER TRIANGLE OF THE MATRIX. 438C 439C A CONTAINS THE LOWER TRIANGLE OF THE SYMMETRIC BAND INPUT 440C MATRIX STORED AS AN N BY MB ARRAY. ITS LOWEST SUBDIAGONAL 441C IS STORED IN THE LAST N+1-MB POSITIONS OF THE FIRST COLUMN, 442C ITS NEXT SUBDIAGONAL IN THE LAST N+2-MB POSITIONS OF THE 443C SECOND COLUMN, FURTHER SUBDIAGONALS SIMILARLY, AND FINALLY 444C ITS PRINCIPAL DIAGONAL IN THE N POSITIONS OF THE LAST COLUMN. 445C CONTENTS OF STORAGES NOT PART OF THE MATRIX ARE ARBITRARY. 446C 447C MATZ SHOULD BE SET TO .TRUE. IF THE TRANSFORMATION MATRIX IS 448C TO BE ACCUMULATED, AND TO .FALSE. OTHERWISE. 449C 450C ON OUTPUT 451C 452C A HAS BEEN DESTROYED, EXCEPT FOR ITS LAST TWO COLUMNS WHICH 453C CONTAIN A COPY OF THE TRIDIAGONAL MATRIX. 454C 455C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. 456C 457C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL 458C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. 459C 460C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. 461C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. 462C 463C Z CONTAINS THE ORTHOGONAL TRANSFORMATION MATRIX PRODUCED IN 464C THE REDUCTION IF MATZ HAS BEEN SET TO .TRUE. OTHERWISE, Z 465C IS NOT REFERENCED. 466C 467C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 468C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 469C 470C THIS VERSION DATED AUGUST 1983. 471C 472C ------------------------------------------------------------------ 473C 474 DMIN = 2.0D0**(-64) 475 DMINRT = 2.0D0**(-32) 476C .......... INITIALIZE DIAGONAL SCALING MATRIX .......... 477 DO 30 J = 1, N 478 30 D(J) = 1.0D0 479C 480 IF (.NOT. MATZ) GO TO 60 481C 482 DO 50 J = 1, N 483C 484 DO 40 K = 1, N 485 40 Z(J,K) = 0.0D0 486C 487 Z(J,J) = 1.0D0 488 50 CONTINUE 489C 490 60 M1 = MB - 1 491 ii4=m1-1 492 IF (ii4) 900, 800, 70 493 70 N2 = N - 2 494C 495 DO 700 K = 1, N2 496 MAXR = MIN0(M1,N-K) 497C .......... FOR R=MAXR STEP -1 UNTIL 2 DO -- .......... 498 DO 600 R1 = 2, MAXR 499 R = MAXR + 2 - R1 500 KR = K + R 501 MR = MB - R 502 G = A(KR,MR) 503 A(KR-1,1) = A(KR-1,MR+1) 504 UGL = K 505C 506 DO 500 J = KR, N, M1 507 J1 = J - 1 508 J2 = J1 - 1 509 IF (G .EQ. 0.0D0) GO TO 600 510 B1 = A(J1,1) / G 511 B2 = B1 * D(J1) / D(J) 512 S2 = 1.0D0 / (1.0D0 + B1 * B2) 513 IF (S2 .GE. 0.5D0 ) GO TO 450 514 B1 = G / A(J1,1) 515 B2 = B1 * D(J) / D(J1) 516 C2 = 1.0D0 - S2 517 D(J1) = C2 * D(J1) 518 D(J) = C2 * D(J) 519 F1 = 2.0D0 * A(J,M1) 520 F2 = B1 * A(J1,MB) 521 A(J,M1) = -B2 * (B1 * A(J,M1) - A(J,MB)) - F2 + A(J,M1) 522 A(J1,MB) = B2 * (B2 * A(J,MB) + F1) + A(J1,MB) 523 A(J,MB) = B1 * (F2 - F1) + A(J,MB) 524C 525 DO 200 L = UGL, J2 526 I2 = MB - J + L 527 U = A(J1,I2+1) + B2 * A(J,I2) 528 A(J,I2) = -B1 * A(J1,I2+1) + A(J,I2) 529 A(J1,I2+1) = U 530 200 CONTINUE 531C 532 UGL = J 533 A(J1,1) = A(J1,1) + B2 * G 534 IF (J .EQ. N) GO TO 350 535 MAXL = MIN0(M1,N-J1) 536C 537 DO 300 L = 2, MAXL 538 I1 = J1 + L 539 I2 = MB - L 540 U = A(I1,I2) + B2 * A(I1,I2+1) 541 A(I1,I2+1) = -B1 * A(I1,I2) + A(I1,I2+1) 542 A(I1,I2) = U 543 300 CONTINUE 544C 545 I1 = J + M1 546 IF (I1 .GT. N) GO TO 350 547 G = B2 * A(I1,1) 548 350 IF (.NOT. MATZ) GO TO 500 549C 550 DO 400 L = 1, N 551 U = Z(L,J1) + B2 * Z(L,J) 552 Z(L,J) = -B1 * Z(L,J1) + Z(L,J) 553 Z(L,J1) = U 554 400 CONTINUE 555C 556 GO TO 500 557C 558 450 U = D(J1) 559 D(J1) = S2 * D(J) 560 D(J) = S2 * U 561 F1 = 2.0D0 * A(J,M1) 562 F2 = B1 * A(J,MB) 563 U = B1 * (F2 - F1) + A(J1,MB) 564 A(J,M1) = B2 * (B1 * A(J,M1) - A(J1,MB)) + F2 - A(J,M1) 565 A(J1,MB) = B2 * (B2 * A(J1,MB) + F1) + A(J,MB) 566 A(J,MB) = U 567C 568 DO 460 L = UGL, J2 569 I2 = MB - J + L 570 U = B2 * A(J1,I2+1) + A(J,I2) 571 A(J,I2) = -A(J1,I2+1) + B1 * A(J,I2) 572 A(J1,I2+1) = U 573 460 CONTINUE 574C 575 UGL = J 576 A(J1,1) = B2 * A(J1,1) + G 577 IF (J .EQ. N) GO TO 480 578 MAXL = MIN0(M1,N-J1) 579C 580 DO 470 L = 2, MAXL 581 I1 = J1 + L 582 I2 = MB - L 583 U = B2 * A(I1,I2) + A(I1,I2+1) 584 A(I1,I2+1) = -A(I1,I2) + B1 * A(I1,I2+1) 585 A(I1,I2) = U 586 470 CONTINUE 587C 588 I1 = J + M1 589 IF (I1 .GT. N) GO TO 480 590 G = A(I1,1) 591 A(I1,1) = B1 * A(I1,1) 592 480 IF (.NOT. MATZ) GO TO 500 593C 594 DO 490 L = 1, N 595 U = B2 * Z(L,J1) + Z(L,J) 596 Z(L,J) = -Z(L,J1) + B1 * Z(L,J) 597 Z(L,J1) = U 598 490 CONTINUE 599C 600 500 CONTINUE 601C 602 600 CONTINUE 603C 604 IF (MOD(K,64) .NE. 0) GO TO 700 605C .......... RESCALE TO AVOID UNDERFLOW OR OVERFLOW .......... 606 DO 650 J = K, N 607 IF (D(J) .GE. DMIN) GO TO 650 608 MAXL = MAX0(1,MB+1-J) 609C 610 DO 610 L = MAXL, M1 611 610 A(J,L) = DMINRT * A(J,L) 612C 613 IF (J .EQ. N) GO TO 630 614 MAXL = MIN0(M1,N-J) 615C 616 DO 620 L = 1, MAXL 617 I1 = J + L 618 I2 = MB - L 619 A(I1,I2) = DMINRT * A(I1,I2) 620 620 CONTINUE 621C 622 630 IF (.NOT. MATZ) GO TO 645 623C 624 DO 640 L = 1, N 625 640 Z(L,J) = DMINRT * Z(L,J) 626C 627 645 A(J,MB) = DMIN * A(J,MB) 628 D(J) = D(J) / DMIN 629 650 CONTINUE 630C 631 700 CONTINUE 632C .......... FORM SQUARE ROOT OF SCALING MATRIX .......... 633 800 DO 810 J = 2, N 634 810 E(J) = DSQRT(D(J)) 635C 636 IF (.NOT. MATZ) GO TO 840 637C 638 DO 830 J = 1, N 639C 640 DO 820 K = 2, N 641 820 Z(J,K) = E(K) * Z(J,K) 642C 643 830 CONTINUE 644C 645 840 U = 1.0D0 646C 647 DO 850 J = 2, N 648 A(J,M1) = U * E(J) * A(J,M1) 649 U = E(J) 650 E2(J) = A(J,M1) ** 2 651 A(J,MB) = D(J) * A(J,MB) 652 D(J) = A(J,MB) 653 E(J) = A(J,M1) 654 850 CONTINUE 655C 656 D(1) = A(1,MB) 657 E(1) = 0.0D0 658 E2(1) = 0.0D0 659 GO TO 1001 660C 661 900 DO 950 J = 1, N 662 D(J) = A(J,MB) 663 E(J) = 0.0D0 664 E2(J) = 0.0D0 665 950 CONTINUE 666C 667 1001 RETURN 668 END 669 SUBROUTINE BANDV(NM,N,MBW,A,E21,M,W,Z,IERR,NV,RV,RV6) 670C 671 INTEGER I,J,K,M,N,R,II,IJ,JJ,KJ,MB,M1,NM,NV,IJ1,ITS,KJ1,MBW,M21, 672 X IERR,MAXJ,MAXK,GROUP 673 DOUBLE PRECISION A(NM,MBW),W(M),Z(NM,M),RV(NV),RV6(N) 674 DOUBLE PRECISION U,V,UK,XU,X0,X1,E21,EPS2,EPS3,EPS4,NORM,ORDER, 675 X EPSLON,PYTHAG 676C 677C THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A REAL SYMMETRIC 678C BAND MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES, USING INVERSE 679C ITERATION. THE SUBROUTINE MAY ALSO BE USED TO SOLVE SYSTEMS 680C OF LINEAR EQUATIONS WITH A SYMMETRIC OR NON-SYMMETRIC BAND 681C COEFFICIENT MATRIX. 682C 683C ON INPUT 684C 685C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 686C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 687C DIMENSION STATEMENT. 688C 689C N IS THE ORDER OF THE MATRIX. 690C 691C MBW IS THE NUMBER OF COLUMNS OF THE ARRAY A USED TO STORE THE 692C BAND MATRIX. IF THE MATRIX IS SYMMETRIC, MBW IS ITS (HALF) 693C BAND WIDTH, DENOTED MB AND DEFINED AS THE NUMBER OF ADJACENT 694C DIAGONALS, INCLUDING THE PRINCIPAL DIAGONAL, REQUIRED TO 695C SPECIFY THE NON-ZERO PORTION OF THE LOWER TRIANGLE OF THE 696C MATRIX. IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS 697C OF LINEAR EQUATIONS AND THE COEFFICIENT MATRIX IS NOT 698C SYMMETRIC, IT MUST HOWEVER HAVE THE SAME NUMBER OF ADJACENT 699C DIAGONALS ABOVE THE MAIN DIAGONAL AS BELOW, AND IN THIS 700C CASE, MBW=2*MB-1. 701C 702C A CONTAINS THE LOWER TRIANGLE OF THE SYMMETRIC BAND INPUT 703C MATRIX STORED AS AN N BY MB ARRAY. ITS LOWEST SUBDIAGONAL 704C IS STORED IN THE LAST N+1-MB POSITIONS OF THE FIRST COLUMN, 705C ITS NEXT SUBDIAGONAL IN THE LAST N+2-MB POSITIONS OF THE 706C SECOND COLUMN, FURTHER SUBDIAGONALS SIMILARLY, AND FINALLY 707C ITS PRINCIPAL DIAGONAL IN THE N POSITIONS OF COLUMN MB. 708C IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS OF LINEAR 709C EQUATIONS AND THE COEFFICIENT MATRIX IS NOT SYMMETRIC, A IS 710C N BY 2*MB-1 INSTEAD WITH LOWER TRIANGLE AS ABOVE AND WITH 711C ITS FIRST SUPERDIAGONAL STORED IN THE FIRST N-1 POSITIONS OF 712C COLUMN MB+1, ITS SECOND SUPERDIAGONAL IN THE FIRST N-2 713C POSITIONS OF COLUMN MB+2, FURTHER SUPERDIAGONALS SIMILARLY, 714C AND FINALLY ITS HIGHEST SUPERDIAGONAL IN THE FIRST N+1-MB 715C POSITIONS OF THE LAST COLUMN. 716C CONTENTS OF STORAGES NOT PART OF THE MATRIX ARE ARBITRARY. 717C 718C E21 SPECIFIES THE ORDERING OF THE EIGENVALUES AND CONTAINS 719C 0.0D0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, OR 720C 2.0D0 IF THE EIGENVALUES ARE IN DESCENDING ORDER. 721C IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS OF LINEAR 722C EQUATIONS, E21 SHOULD BE SET TO 1.0D0 IF THE COEFFICIENT 723C MATRIX IS SYMMETRIC AND TO -1.0D0 IF NOT. 724C 725C M IS THE NUMBER OF SPECIFIED EIGENVALUES OR THE NUMBER OF 726C SYSTEMS OF LINEAR EQUATIONS. 727C 728C W CONTAINS THE M EIGENVALUES IN ASCENDING OR DESCENDING ORDER. 729C IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS OF LINEAR 730C EQUATIONS (A-W(R)*I)*X(R)=B(R), WHERE I IS THE IDENTITY 731C MATRIX, W(R) SHOULD BE SET ACCORDINGLY, FOR R=1,2,...,M. 732C 733C Z CONTAINS THE CONSTANT MATRIX COLUMNS (B(R),R=1,2,...,M), IF 734C THE SUBROUTINE IS USED TO SOLVE SYSTEMS OF LINEAR EQUATIONS. 735C 736C NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER RV 737C AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT. 738C 739C ON OUTPUT 740C 741C A AND W ARE UNALTERED. 742C 743C Z CONTAINS THE ASSOCIATED SET OF ORTHOGONAL EIGENVECTORS. 744C ANY VECTOR WHICH FAILS TO CONVERGE IS SET TO ZERO. IF THE 745C SUBROUTINE IS USED TO SOLVE SYSTEMS OF LINEAR EQUATIONS, 746C Z CONTAINS THE SOLUTION MATRIX COLUMNS (X(R),R=1,2,...,M). 747C 748C IERR IS SET TO 749C ZERO FOR NORMAL RETURN, 750C -R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH 751C EIGENVALUE FAILS TO CONVERGE, OR IF THE R-TH 752C SYSTEM OF LINEAR EQUATIONS IS NEARLY SINGULAR. 753C 754C RV AND RV6 ARE TEMPORARY STORAGE ARRAYS. NOTE THAT RV IS 755C OF DIMENSION AT LEAST N*(2*MB-1). IF THE SUBROUTINE 756C IS BEING USED TO SOLVE SYSTEMS OF LINEAR EQUATIONS, THE 757C DETERMINANT (UP TO SIGN) OF A-W(M)*I IS AVAILABLE, UPON 758C RETURN, AS THE PRODUCT OF THE FIRST N ELEMENTS OF RV. 759C 760C CALLS PYTHAG FOR DSQRT(A*A + B*B) . 761C 762C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 763C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 764C 765C THIS VERSION DATED AUGUST 1983. 766C 767C ------------------------------------------------------------------ 768C 769 IERR = 0 770 IF (M .EQ. 0) GO TO 1001 771 MB = MBW 772 IF (E21 .LT. 0.0D0) MB = (MBW + 1) / 2 773 M1 = MB - 1 774 M21 = M1 + MB 775 ORDER = 1.0D0 - DABS(E21) 776C .......... FIND VECTORS BY INVERSE ITERATION .......... 777 DO 920 R = 1, M 778 ITS = 1 779 X1 = W(R) 780 IF (R .NE. 1) GO TO 100 781C .......... COMPUTE NORM OF MATRIX .......... 782 NORM = 0.0D0 783C 784 DO 60 J = 1, MB 785 JJ = MB + 1 - J 786 KJ = JJ + M1 787 IJ = 1 788 V = 0.0D0 789C 790 DO 40 I = JJ, N 791 V = V + DABS(A(I,J)) 792 IF (E21 .GE. 0.0D0) GO TO 40 793 V = V + DABS(A(IJ,KJ)) 794 IJ = IJ + 1 795 40 CONTINUE 796C 797 NORM = DMAX1(NORM,V) 798 60 CONTINUE 799C 800 IF (E21 .LT. 0.0D0) NORM = 0.5D0 * NORM 801C .......... EPS2 IS THE CRITERION FOR GROUPING, 802C EPS3 REPLACES ZERO PIVOTS AND EQUAL 803C ROOTS ARE MODIFIED BY EPS3, 804C EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW .......... 805 IF (NORM .EQ. 0.0D0) NORM = 1.0D0 806 EPS2 = 1.0D-3 * NORM * DABS(ORDER) 807 EPS3 = EPSLON(NORM) 808 UK = N 809 UK = DSQRT(UK) 810 EPS4 = UK * EPS3 811 80 GROUP = 0 812 GO TO 120 813C .......... LOOK FOR CLOSE OR COINCIDENT ROOTS .......... 814 100 IF (DABS(X1-X0) .GE. EPS2) GO TO 80 815 GROUP = GROUP + 1 816 IF (ORDER * (X1 - X0) .LE. 0.0D0) X1 = X0 + ORDER * EPS3 817C .......... EXPAND MATRIX, SUBTRACT EIGENVALUE, 818C AND INITIALIZE VECTOR .......... 819 120 DO 200 I = 1, N 820 IJ = I + MIN0(0,I-M1) * N 821 KJ = IJ + MB * N 822 IJ1 = KJ + M1 * N 823 IF (M1 .EQ. 0) GO TO 180 824C 825 DO 150 J = 1, M1 826 IF (IJ .GT. M1) GO TO 125 827 IF (IJ .GT. 0) GO TO 130 828 RV(IJ1) = 0.0D0 829 IJ1 = IJ1 + N 830 GO TO 130 831 125 RV(IJ) = A(I,J) 832 130 IJ = IJ + N 833 II = I + J 834 IF (II .GT. N) GO TO 150 835 JJ = MB - J 836 IF (E21 .GE. 0.0D0) GO TO 140 837 II = I 838 JJ = MB + J 839 140 RV(KJ) = A(II,JJ) 840 KJ = KJ + N 841 150 CONTINUE 842C 843 180 RV(IJ) = A(I,MB) - X1 844 RV6(I) = EPS4 845 IF (ORDER .EQ. 0.0D0) RV6(I) = Z(I,R) 846 200 CONTINUE 847C 848 IF (M1 .EQ. 0) GO TO 600 849C .......... ELIMINATION WITH INTERCHANGES .......... 850 DO 580 I = 1, N 851 II = I + 1 852 MAXK = MIN0(I+M1-1,N) 853 MAXJ = MIN0(N-I,M21-2) * N 854C 855 DO 360 K = I, MAXK 856 KJ1 = K 857 J = KJ1 + N 858 JJ = J + MAXJ 859C 860 DO 340 KJ = J, JJ, N 861 RV(KJ1) = RV(KJ) 862 KJ1 = KJ 863 340 CONTINUE 864C 865 RV(KJ1) = 0.0D0 866 360 CONTINUE 867C 868 IF (I .EQ. N) GO TO 580 869 U = 0.0D0 870 MAXK = MIN0(I+M1,N) 871 MAXJ = MIN0(N-II,M21-2) * N 872C 873 DO 450 J = I, MAXK 874 IF (DABS(RV(J)) .LT. DABS(U)) GO TO 450 875 U = RV(J) 876 K = J 877 450 CONTINUE 878C 879 J = I + N 880 JJ = J + MAXJ 881 IF (K .EQ. I) GO TO 520 882 KJ = K 883C 884 DO 500 IJ = I, JJ, N 885 V = RV(IJ) 886 RV(IJ) = RV(KJ) 887 RV(KJ) = V 888 KJ = KJ + N 889 500 CONTINUE 890C 891 IF (ORDER .NE. 0.0D0) GO TO 520 892 V = RV6(I) 893 RV6(I) = RV6(K) 894 RV6(K) = V 895 520 IF (U .EQ. 0.0D0) GO TO 580 896C 897 DO 560 K = II, MAXK 898 V = RV(K) / U 899 KJ = K 900C 901 DO 540 IJ = J, JJ, N 902 KJ = KJ + N 903 RV(KJ) = RV(KJ) - V * RV(IJ) 904 540 CONTINUE 905C 906 IF (ORDER .EQ. 0.0D0) RV6(K) = RV6(K) - V * RV6(I) 907 560 CONTINUE 908C 909 580 CONTINUE 910C .......... BACK SUBSTITUTION 911C FOR I=N STEP -1 UNTIL 1 DO -- .......... 912 600 DO 630 II = 1, N 913 I = N + 1 - II 914 MAXJ = MIN0(II,M21) 915 IF (MAXJ .EQ. 1) GO TO 620 916 IJ1 = I 917 J = IJ1 + N 918 JJ = J + (MAXJ - 2) * N 919C 920 DO 610 IJ = J, JJ, N 921 IJ1 = IJ1 + 1 922 RV6(I) = RV6(I) - RV(IJ) * RV6(IJ1) 923 610 CONTINUE 924C 925 620 V = RV(I) 926 IF (DABS(V) .GE. EPS3) GO TO 625 927C .......... SET ERROR -- NEARLY SINGULAR LINEAR SYSTEM .......... 928 IF (ORDER .EQ. 0.0D0) IERR = -R 929 V = DSIGN(EPS3,V) 930 625 RV6(I) = RV6(I) / V 931 630 CONTINUE 932C 933 XU = 1.0D0 934 IF (ORDER .EQ. 0.0D0) GO TO 870 935C .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS 936C MEMBERS OF GROUP .......... 937 IF (GROUP .EQ. 0) GO TO 700 938C 939 DO 680 JJ = 1, GROUP 940 J = R - GROUP - 1 + JJ 941 XU = 0.0D0 942C 943 DO 640 I = 1, N 944 640 XU = XU + RV6(I) * Z(I,J) 945C 946 DO 660 I = 1, N 947 660 RV6(I) = RV6(I) - XU * Z(I,J) 948C 949 680 CONTINUE 950C 951 700 NORM = 0.0D0 952C 953 DO 720 I = 1, N 954 720 NORM = NORM + DABS(RV6(I)) 955C 956 IF (NORM .GE. 0.1D0) GO TO 840 957C .......... IN-LINE PROCEDURE FOR CHOOSING 958C A NEW STARTING VECTOR .......... 959 IF (ITS .GE. N) GO TO 830 960 ITS = ITS + 1 961 XU = EPS4 / (UK + 1.0D0) 962 RV6(1) = EPS4 963C 964 DO 760 I = 2, N 965 760 RV6(I) = XU 966C 967 RV6(ITS) = RV6(ITS) - EPS4 * UK 968 GO TO 600 969C .......... SET ERROR -- NON-CONVERGED EIGENVECTOR .......... 970 830 IERR = -R 971 XU = 0.0D0 972 GO TO 870 973C .......... NORMALIZE SO THAT SUM OF SQUARES IS 974C 1 AND EXPAND TO FULL ORDER .......... 975 840 U = 0.0D0 976C 977 DO 860 I = 1, N 978 860 U = PYTHAG(U,RV6(I)) 979C 980 XU = 1.0D0 / U 981C 982 870 DO 900 I = 1, N 983 900 Z(I,R) = RV6(I) * XU 984C 985 X0 = X1 986 920 CONTINUE 987C 988 1001 RETURN 989 END 990 SUBROUTINE BISECT(N,EPS1,D,E,E2,LB,UB,MM,M,W,IND,IERR,RV4,RV5) 991C 992 INTEGER I,J,K,L,M,N,P,Q,R,S,II,MM,M1,M2,TAG,IERR,ISTURM 993 DOUBLE PRECISION D(N),E(N),E2(N),W(MM),RV4(N),RV5(N) 994 DOUBLE PRECISION U,V,LB,T1,T2,UB,XU,X0,X1,EPS1,TST1,TST2,EPSLON 995 INTEGER IND(MM) 996C 997C THIS SUBROUTINE IS A TRANSLATION OF THE BISECTION TECHNIQUE 998C IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON. 999C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). 1000C 1001C THIS SUBROUTINE FINDS THOSE EIGENVALUES OF A TRIDIAGONAL 1002C SYMMETRIC MATRIX WHICH LIE IN A SPECIFIED INTERVAL, 1003C USING BISECTION. 1004C 1005C ON INPUT 1006C 1007C N IS THE ORDER OF THE MATRIX. 1008C 1009C EPS1 IS AN ABSOLUTE ERROR TOLERANCE FOR THE COMPUTED 1010C EIGENVALUES. IF THE INPUT EPS1 IS NON-POSITIVE, 1011C IT IS RESET FOR EACH SUBMATRIX TO A DEFAULT VALUE, 1012C NAMELY, MINUS THE PRODUCT OF THE RELATIVE MACHINE 1013C PRECISION AND THE 1-NORM OF THE SUBMATRIX. 1014C 1015C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. 1016C 1017C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX 1018C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. 1019C 1020C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. 1021C E2(1) IS ARBITRARY. 1022C 1023C LB AND UB DEFINE THE INTERVAL TO BE SEARCHED FOR EIGENVALUES. 1024C IF LB IS NOT LESS THAN UB, NO EIGENVALUES WILL BE FOUND. 1025C 1026C MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF 1027C EIGENVALUES IN THE INTERVAL. WARNING. IF MORE THAN 1028C MM EIGENVALUES ARE DETERMINED TO LIE IN THE INTERVAL, 1029C AN ERROR RETURN IS MADE WITH NO EIGENVALUES FOUND. 1030C 1031C ON OUTPUT 1032C 1033C EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS 1034C (LAST) DEFAULT VALUE. 1035C 1036C D AND E ARE UNALTERED. 1037C 1038C ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED 1039C AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE 1040C MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES. 1041C E2(1) IS ALSO SET TO ZERO. 1042C 1043C M IS THE NUMBER OF EIGENVALUES DETERMINED TO LIE IN (LB,UB). 1044C 1045C W CONTAINS THE M EIGENVALUES IN ASCENDING ORDER. 1046C 1047C IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES 1048C ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W -- 1049C 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM 1050C THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC.. 1051C 1052C IERR IS SET TO 1053C ZERO FOR NORMAL RETURN, 1054C 3*N+1 IF M EXCEEDS MM. 1055C 1056C RV4 AND RV5 ARE TEMPORARY STORAGE ARRAYS. 1057C 1058C THE ALGOL PROCEDURE STURMCNT CONTAINED IN TRISTURM 1059C APPEARS IN BISECT IN-LINE. 1060C 1061C NOTE THAT SUBROUTINE TQL1 OR IMTQL1 IS GENERALLY FASTER THAN 1062C BISECT, IF MORE THAN N/4 EIGENVALUES ARE TO BE FOUND. 1063C 1064C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 1065C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 1066C 1067C THIS VERSION DATED AUGUST 1983. 1068C 1069C ------------------------------------------------------------------ 1070C 1071 IERR = 0 1072 TAG = 0 1073 T1 = LB 1074 T2 = UB 1075C .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES .......... 1076 DO 40 I = 1, N 1077 IF (I .EQ. 1) GO TO 20 1078 TST1 = DABS(D(I)) + DABS(D(I-1)) 1079 TST2 = TST1 + DABS(E(I)) 1080 IF (TST2 .GT. TST1) GO TO 40 1081 20 E2(I) = 0.0D0 1082 40 CONTINUE 1083C .......... DETERMINE THE NUMBER OF EIGENVALUES 1084C IN THE INTERVAL .......... 1085 P = 1 1086 Q = N 1087 X1 = UB 1088 ISTURM = 1 1089 GO TO 320 1090 60 M = S 1091 X1 = LB 1092 ISTURM = 2 1093 GO TO 320 1094 80 M = M - S 1095 IF (M .GT. MM) GO TO 980 1096 Q = 0 1097 R = 0 1098C .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING 1099C INTERVAL BY THE GERSCHGORIN BOUNDS .......... 1100 100 IF (R .EQ. M) GO TO 1001 1101 TAG = TAG + 1 1102 P = Q + 1 1103 XU = D(P) 1104 X0 = D(P) 1105 U = 0.0D0 1106C 1107 DO 120 Q = P, N 1108 X1 = U 1109 U = 0.0D0 1110 V = 0.0D0 1111 IF (Q .EQ. N) GO TO 110 1112 U = DABS(E(Q+1)) 1113 V = E2(Q+1) 1114 110 XU = DMIN1(D(Q)-(X1+U),XU) 1115 X0 = DMAX1(D(Q)+(X1+U),X0) 1116 IF (V .EQ. 0.0D0) GO TO 140 1117 120 CONTINUE 1118C 1119 140 X1 = EPSLON(DMAX1(DABS(XU),DABS(X0))) 1120 IF (EPS1 .LE. 0.0D0) EPS1 = -X1 1121 IF (P .NE. Q) GO TO 180 1122C .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL .......... 1123 IF (T1 .GT. D(P) .OR. D(P) .GE. T2) GO TO 940 1124 M1 = P 1125 M2 = P 1126 RV5(P) = D(P) 1127 GO TO 900 1128 180 X1 = X1 * (Q - P + 1) 1129 LB = DMAX1(T1,XU-X1) 1130 UB = DMIN1(T2,X0+X1) 1131 X1 = LB 1132 ISTURM = 3 1133 GO TO 320 1134 200 M1 = S + 1 1135 X1 = UB 1136 ISTURM = 4 1137 GO TO 320 1138 220 M2 = S 1139 IF (M1 .GT. M2) GO TO 940 1140C .......... FIND ROOTS BY BISECTION .......... 1141 X0 = UB 1142 ISTURM = 5 1143C 1144 DO 240 I = M1, M2 1145 RV5(I) = UB 1146 RV4(I) = LB 1147 240 CONTINUE 1148C .......... LOOP FOR K-TH EIGENVALUE 1149C FOR K=M2 STEP -1 UNTIL M1 DO -- 1150C (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) .......... 1151 K = M2 1152 250 XU = LB 1153C .......... FOR I=K STEP -1 UNTIL M1 DO -- .......... 1154 DO 260 II = M1, K 1155 I = M1 + K - II 1156 IF (XU .GE. RV4(I)) GO TO 260 1157 XU = RV4(I) 1158 GO TO 280 1159 260 CONTINUE 1160C 1161 280 IF (X0 .GT. RV5(K)) X0 = RV5(K) 1162C .......... NEXT BISECTION STEP .......... 1163 300 X1 = (XU + X0) * 0.5D0 1164 IF ((X0 - XU) .LE. DABS(EPS1)) GO TO 420 1165 TST1 = 2.0D0 * (DABS(XU) + DABS(X0)) 1166 TST2 = TST1 + (X0 - XU) 1167 IF (TST2 .EQ. TST1) GO TO 420 1168C .......... IN-LINE PROCEDURE FOR STURM SEQUENCE .......... 1169 320 S = P - 1 1170 U = 1.0D0 1171C 1172 DO 340 I = P, Q 1173 IF (U .NE. 0.0D0) GO TO 325 1174 V = DABS(E(I)) / EPSLON(1.0D0) 1175 IF (E2(I) .EQ. 0.0D0) V = 0.0D0 1176 GO TO 330 1177 325 V = E2(I) / U 1178 330 U = D(I) - X1 - V 1179 IF (U .LT. 0.0D0) S = S + 1 1180 340 CONTINUE 1181C 1182 GO TO (60,80,200,220,360), ISTURM 1183C .......... REFINE INTERVALS .......... 1184 360 IF (S .GE. K) GO TO 400 1185 XU = X1 1186 IF (S .GE. M1) GO TO 380 1187 RV4(M1) = X1 1188 GO TO 300 1189 380 RV4(S+1) = X1 1190 IF (RV5(S) .GT. X1) RV5(S) = X1 1191 GO TO 300 1192 400 X0 = X1 1193 GO TO 300 1194C .......... K-TH EIGENVALUE FOUND .......... 1195 420 RV5(K) = X1 1196 K = K - 1 1197 IF (K .GE. M1) GO TO 250 1198C .......... ORDER EIGENVALUES TAGGED WITH THEIR 1199C SUBMATRIX ASSOCIATIONS .......... 1200 900 S = R 1201 R = R + M2 - M1 + 1 1202 J = 1 1203 K = M1 1204C 1205 DO 920 L = 1, R 1206 IF (J .GT. S) GO TO 910 1207 IF (K .GT. M2) GO TO 940 1208 IF (RV5(K) .GE. W(L)) GO TO 915 1209C 1210 DO 905 II = J, S 1211 I = L + S - II 1212 W(I+1) = W(I) 1213 IND(I+1) = IND(I) 1214 905 CONTINUE 1215C 1216 910 W(L) = RV5(K) 1217 IND(L) = TAG 1218 K = K + 1 1219 GO TO 920 1220 915 J = J + 1 1221 920 CONTINUE 1222C 1223 940 IF (Q .LT. N) GO TO 100 1224 GO TO 1001 1225C .......... SET ERROR -- UNDERESTIMATE OF NUMBER OF 1226C EIGENVALUES IN INTERVAL .......... 1227 980 IERR = 3 * N + 1 1228 1001 LB = T1 1229 UB = T2 1230 RETURN 1231 END 1232 SUBROUTINE BQR(NM,N,MB,A,T,R,IERR,NV,RV) 1233C 1234 INTEGER I,J,K,L,M,N,II,IK,JK,JM,KJ,KK,KM,LL,MB,MK,MN,MZ, 1235 X M1,M2,M3,M4,NI,NM,NV,ITS,KJ1,M21,M31,IERR,IMULT 1236 DOUBLE PRECISION A(NM,MB),RV(NV) 1237 DOUBLE PRECISION F,G,Q,R,S,T,TST1,TST2,SCALE,PYTHAG 1238C 1239C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BQR, 1240C NUM. MATH. 16, 85-92(1970) BY MARTIN, REINSCH, AND WILKINSON. 1241C HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 266-272(1971). 1242C 1243C THIS SUBROUTINE FINDS THE EIGENVALUE OF SMALLEST (USUALLY) 1244C MAGNITUDE OF A REAL SYMMETRIC BAND MATRIX USING THE 1245C QR ALGORITHM WITH SHIFTS OF ORIGIN. CONSECUTIVE CALLS 1246C CAN BE MADE TO FIND FURTHER EIGENVALUES. 1247C 1248C ON INPUT 1249C 1250C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 1251C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 1252C DIMENSION STATEMENT. 1253C 1254C N IS THE ORDER OF THE MATRIX. 1255C 1256C MB IS THE (HALF) BAND WIDTH OF THE MATRIX, DEFINED AS THE 1257C NUMBER OF ADJACENT DIAGONALS, INCLUDING THE PRINCIPAL 1258C DIAGONAL, REQUIRED TO SPECIFY THE NON-ZERO PORTION OF THE 1259C LOWER TRIANGLE OF THE MATRIX. 1260C 1261C A CONTAINS THE LOWER TRIANGLE OF THE SYMMETRIC BAND INPUT 1262C MATRIX STORED AS AN N BY MB ARRAY. ITS LOWEST SUBDIAGONAL 1263C IS STORED IN THE LAST N+1-MB POSITIONS OF THE FIRST COLUMN, 1264C ITS NEXT SUBDIAGONAL IN THE LAST N+2-MB POSITIONS OF THE 1265C SECOND COLUMN, FURTHER SUBDIAGONALS SIMILARLY, AND FINALLY 1266C ITS PRINCIPAL DIAGONAL IN THE N POSITIONS OF THE LAST COLUMN. 1267C CONTENTS OF STORAGES NOT PART OF THE MATRIX ARE ARBITRARY. 1268C ON A SUBSEQUENT CALL, ITS OUTPUT CONTENTS FROM THE PREVIOUS 1269C CALL SHOULD BE PASSED. 1270C 1271C T SPECIFIES THE SHIFT (OF EIGENVALUES) APPLIED TO THE DIAGONAL 1272C OF A IN FORMING THE INPUT MATRIX. WHAT IS ACTUALLY DETERMINED 1273C IS THE EIGENVALUE OF A+TI (I IS THE IDENTITY MATRIX) NEAREST 1274C TO T. ON A SUBSEQUENT CALL, THE OUTPUT VALUE OF T FROM THE 1275C PREVIOUS CALL SHOULD BE PASSED IF THE NEXT NEAREST EIGENVALUE 1276C IS SOUGHT. 1277C 1278C R SHOULD BE SPECIFIED AS ZERO ON THE FIRST CALL, AND AS ITS 1279C OUTPUT VALUE FROM THE PREVIOUS CALL ON A SUBSEQUENT CALL. 1280C IT IS USED TO DETERMINE WHEN THE LAST ROW AND COLUMN OF 1281C THE TRANSFORMED BAND MATRIX CAN BE REGARDED AS NEGLIGIBLE. 1282C 1283C NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER RV 1284C AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT. 1285C 1286C ON OUTPUT 1287C 1288C A CONTAINS THE TRANSFORMED BAND MATRIX. THE MATRIX A+TI 1289C DERIVED FROM THE OUTPUT PARAMETERS IS SIMILAR TO THE 1290C INPUT A+TI TO WITHIN ROUNDING ERRORS. ITS LAST ROW AND 1291C COLUMN ARE NULL (IF IERR IS ZERO). 1292C 1293C T CONTAINS THE COMPUTED EIGENVALUE OF A+TI (IF IERR IS ZERO). 1294C 1295C R CONTAINS THE MAXIMUM OF ITS INPUT VALUE AND THE NORM OF THE 1296C LAST COLUMN OF THE INPUT MATRIX A. 1297C 1298C IERR IS SET TO 1299C ZERO FOR NORMAL RETURN, 1300C N IF THE EIGENVALUE HAS NOT BEEN 1301C DETERMINED AFTER 30 ITERATIONS. 1302C 1303C RV IS A TEMPORARY STORAGE ARRAY OF DIMENSION AT LEAST 1304C (2*MB**2+4*MB-3). THE FIRST (3*MB-2) LOCATIONS CORRESPOND 1305C TO THE ALGOL ARRAY B, THE NEXT (2*MB-1) LOCATIONS CORRESPOND 1306C TO THE ALGOL ARRAY H, AND THE FINAL (2*MB**2-MB) LOCATIONS 1307C CORRESPOND TO THE MB BY (2*MB-1) ALGOL ARRAY U. 1308C 1309C NOTE. FOR A SUBSEQUENT CALL, N SHOULD BE REPLACED BY N-1, BUT 1310C MB SHOULD NOT BE ALTERED EVEN WHEN IT EXCEEDS THE CURRENT N. 1311C 1312C CALLS PYTHAG FOR DSQRT(A*A + B*B) . 1313C 1314C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 1315C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 1316C 1317C THIS VERSION DATED AUGUST 1983. 1318C 1319C ------------------------------------------------------------------ 1320C 1321 IERR = 0 1322 M1 = MIN0(MB,N) 1323 M = M1 - 1 1324 M2 = M + M 1325 M21 = M2 + 1 1326 M3 = M21 + M 1327 M31 = M3 + 1 1328 M4 = M31 + M2 1329 MN = M + N 1330 MZ = MB - M1 1331 ITS = 0 1332C .......... TEST FOR CONVERGENCE .......... 1333 40 G = A(N,MB) 1334 IF (M .EQ. 0) GO TO 360 1335 F = 0.0D0 1336C 1337 DO 50 K = 1, M 1338 MK = K + MZ 1339 F = F + DABS(A(N,MK)) 1340 50 CONTINUE 1341C 1342 IF (ITS .EQ. 0 .AND. F .GT. R) R = F 1343 TST1 = R 1344 TST2 = TST1 + F 1345 IF (TST2 .LE. TST1) GO TO 360 1346 IF (ITS .EQ. 30) GO TO 1000 1347 ITS = ITS + 1 1348C .......... FORM SHIFT FROM BOTTOM 2 BY 2 MINOR .......... 1349 IF (F .GT. 0.25D0 * R .AND. ITS .LT. 5) GO TO 90 1350 F = A(N,MB-1) 1351 IF (F .EQ. 0.0D0) GO TO 70 1352 Q = (A(N-1,MB) - G) / (2.0D0 * F) 1353 S = PYTHAG(Q,1.0D0) 1354 G = G - F / (Q + DSIGN(S,Q)) 1355 70 T = T + G 1356C 1357 DO 80 I = 1, N 1358 80 A(I,MB) = A(I,MB) - G 1359C 1360 90 DO 100 K = M31, M4 1361 100 RV(K) = 0.0D0 1362C 1363 DO 350 II = 1, MN 1364 I = II - M 1365 NI = N - II 1366 IF (NI .LT. 0) GO TO 230 1367C .......... FORM COLUMN OF SHIFTED MATRIX A-G*I .......... 1368 L = MAX0(1,2-I) 1369C 1370 DO 110 K = 1, M3 1371 110 RV(K) = 0.0D0 1372C 1373 DO 120 K = L, M1 1374 KM = K + M 1375 MK = K + MZ 1376 RV(KM) = A(II,MK) 1377 120 CONTINUE 1378C 1379 LL = MIN0(M,NI) 1380 IF (LL .EQ. 0) GO TO 135 1381C 1382 DO 130 K = 1, LL 1383 KM = K + M21 1384 IK = II + K 1385 MK = MB - K 1386 RV(KM) = A(IK,MK) 1387 130 CONTINUE 1388C .......... PRE-MULTIPLY WITH HOUSEHOLDER REFLECTIONS .......... 1389 135 LL = M2 1390 IMULT = 0 1391C .......... MULTIPLICATION PROCEDURE .......... 1392 140 KJ = M4 - M1 1393C 1394 DO 170 J = 1, LL 1395 KJ = KJ + M1 1396 JM = J + M3 1397 IF (RV(JM) .EQ. 0.0D0) GO TO 170 1398 F = 0.0D0 1399C 1400 DO 150 K = 1, M1 1401 KJ = KJ + 1 1402 JK = J + K - 1 1403 F = F + RV(KJ) * RV(JK) 1404 150 CONTINUE 1405C 1406 F = F / RV(JM) 1407 KJ = KJ - M1 1408C 1409 DO 160 K = 1, M1 1410 KJ = KJ + 1 1411 JK = J + K - 1 1412 RV(JK) = RV(JK) - RV(KJ) * F 1413 160 CONTINUE 1414C 1415 KJ = KJ - M1 1416 170 CONTINUE 1417C 1418 IF (IMULT .NE. 0) GO TO 280 1419C .......... HOUSEHOLDER REFLECTION .......... 1420 F = RV(M21) 1421 S = 0.0D0 1422 RV(M4) = 0.0D0 1423 SCALE = 0.0D0 1424C 1425 DO 180 K = M21, M3 1426 180 SCALE = SCALE + DABS(RV(K)) 1427C 1428 IF (SCALE .EQ. 0.0D0) GO TO 210 1429C 1430 DO 190 K = M21, M3 1431 190 S = S + (RV(K)/SCALE)**2 1432C 1433 S = SCALE * SCALE * S 1434 G = -DSIGN(DSQRT(S),F) 1435 RV(M21) = G 1436 RV(M4) = S - F * G 1437 KJ = M4 + M2 * M1 + 1 1438 RV(KJ) = F - G 1439C 1440 DO 200 K = 2, M1 1441 KJ = KJ + 1 1442 KM = K + M2 1443 RV(KJ) = RV(KM) 1444 200 CONTINUE 1445C .......... SAVE COLUMN OF TRIANGULAR FACTOR R .......... 1446 210 DO 220 K = L, M1 1447 KM = K + M 1448 MK = K + MZ 1449 A(II,MK) = RV(KM) 1450 220 CONTINUE 1451C 1452 230 L = MAX0(1,M1+1-I) 1453 IF (I .LE. 0) GO TO 300 1454C .......... PERFORM ADDITIONAL STEPS .......... 1455 DO 240 K = 1, M21 1456 240 RV(K) = 0.0D0 1457C 1458 LL = MIN0(M1,NI+M1) 1459C .......... GET ROW OF TRIANGULAR FACTOR R .......... 1460 DO 250 KK = 1, LL 1461 K = KK - 1 1462 KM = K + M1 1463 IK = I + K 1464 MK = MB - K 1465 RV(KM) = A(IK,MK) 1466 250 CONTINUE 1467C .......... POST-MULTIPLY WITH HOUSEHOLDER REFLECTIONS .......... 1468 LL = M1 1469 IMULT = 1 1470 GO TO 140 1471C .......... STORE COLUMN OF NEW A MATRIX .......... 1472 280 DO 290 K = L, M1 1473 MK = K + MZ 1474 A(I,MK) = RV(K) 1475 290 CONTINUE 1476C .......... UPDATE HOUSEHOLDER REFLECTIONS .......... 1477 300 IF (L .GT. 1) L = L - 1 1478 KJ1 = M4 + L * M1 1479C 1480 DO 320 J = L, M2 1481 JM = J + M3 1482 RV(JM) = RV(JM+1) 1483C 1484 DO 320 K = 1, M1 1485 KJ1 = KJ1 + 1 1486 KJ = KJ1 - M1 1487 RV(KJ) = RV(KJ1) 1488 320 CONTINUE 1489C 1490 350 CONTINUE 1491C 1492 GO TO 40 1493C .......... CONVERGENCE .......... 1494 360 T = T + G 1495C 1496 DO 380 I = 1, N 1497 380 A(I,MB) = A(I,MB) - G 1498C 1499 DO 400 K = 1, M1 1500 MK = K + MZ 1501 A(N,MK) = 0.0D0 1502 400 CONTINUE 1503C 1504 GO TO 1001 1505C .......... SET ERROR -- NO CONVERGENCE TO 1506C EIGENVALUE AFTER 30 ITERATIONS .......... 1507 1000 IERR = N 1508 1001 RETURN 1509 END 1510 SUBROUTINE CBABK2(NM,N,LOW,IGH,SCALE,M,ZR,ZI) 1511C 1512 INTEGER I,J,K,M,N,II,NM,IGH,LOW 1513 DOUBLE PRECISION SCALE(N),ZR(NM,M),ZI(NM,M) 1514 DOUBLE PRECISION S 1515C 1516C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE 1517C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK, 1518C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. 1519C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). 1520C 1521C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL 1522C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING 1523C BALANCED MATRIX DETERMINED BY CBAL. 1524C 1525C ON INPUT 1526C 1527C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 1528C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 1529C DIMENSION STATEMENT. 1530C 1531C N IS THE ORDER OF THE MATRIX. 1532C 1533C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL. 1534C 1535C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS 1536C AND SCALING FACTORS USED BY CBAL. 1537C 1538C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. 1539C 1540C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, 1541C RESPECTIVELY, OF THE EIGENVECTORS TO BE 1542C BACK TRANSFORMED IN THEIR FIRST M COLUMNS. 1543C 1544C ON OUTPUT 1545C 1546C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, 1547C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS 1548C IN THEIR FIRST M COLUMNS. 1549C 1550C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 1551C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 1552C 1553C THIS VERSION DATED AUGUST 1983. 1554C 1555C ------------------------------------------------------------------ 1556C 1557 IF (M .EQ. 0) GO TO 200 1558 IF (IGH .EQ. LOW) GO TO 120 1559C 1560 DO 110 I = LOW, IGH 1561 S = SCALE(I) 1562C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED 1563C IF THE FOREGOING STATEMENT IS REPLACED BY 1564C S=1.0D0/SCALE(I). .......... 1565 DO 100 J = 1, M 1566 ZR(I,J) = ZR(I,J) * S 1567 ZI(I,J) = ZI(I,J) * S 1568 100 CONTINUE 1569C 1570 110 CONTINUE 1571C .......... FOR I=LOW-1 STEP -1 UNTIL 1, 1572C IGH+1 STEP 1 UNTIL N DO -- .......... 1573 120 DO 140 II = 1, N 1574 I = II 1575 IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140 1576 IF (I .LT. LOW) I = LOW - II 1577 K = SCALE(I) 1578 IF (K .EQ. I) GO TO 140 1579C 1580 DO 130 J = 1, M 1581 S = ZR(I,J) 1582 ZR(I,J) = ZR(K,J) 1583 ZR(K,J) = S 1584 S = ZI(I,J) 1585 ZI(I,J) = ZI(K,J) 1586 ZI(K,J) = S 1587 130 CONTINUE 1588C 1589 140 CONTINUE 1590C 1591 200 RETURN 1592 END 1593 SUBROUTINE CBAL(NM,N,AR,AI,LOW,IGH,SCALE) 1594C 1595 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC 1596 DOUBLE PRECISION AR(NM,N),AI(NM,N),SCALE(N) 1597 DOUBLE PRECISION C,F,G,R,S,B2,RADIX 1598 LOGICAL NOCONV 1599C 1600C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE 1601C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE, 1602C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. 1603C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). 1604C 1605C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES 1606C EIGENVALUES WHENEVER POSSIBLE. 1607C 1608C ON INPUT 1609C 1610C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 1611C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 1612C DIMENSION STATEMENT. 1613C 1614C N IS THE ORDER OF THE MATRIX. 1615C 1616C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, 1617C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED. 1618C 1619C ON OUTPUT 1620C 1621C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, 1622C RESPECTIVELY, OF THE BALANCED MATRIX. 1623C 1624C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J) 1625C ARE EQUAL TO ZERO IF 1626C (1) I IS GREATER THAN J AND 1627C (2) J=1,...,LOW-1 OR I=IGH+1,...,N. 1628C 1629C SCALE CONTAINS INFORMATION DETERMINING THE 1630C PERMUTATIONS AND SCALING FACTORS USED. 1631C 1632C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH 1633C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED 1634C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS 1635C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN 1636C SCALE(J) = P(J), FOR J = 1,...,LOW-1 1637C = D(J,J) J = LOW,...,IGH 1638C = P(J) J = IGH+1,...,N. 1639C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1, 1640C THEN 1 TO LOW-1. 1641C 1642C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY. 1643C 1644C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN 1645C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS 1646C K,L HAVE BEEN REVERSED.) 1647C 1648C ARITHMETIC IS REAL THROUGHOUT. 1649C 1650C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 1651C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 1652C 1653C THIS VERSION DATED AUGUST 1983. 1654C 1655C ------------------------------------------------------------------ 1656C 1657 RADIX = 16.0D0 1658C 1659 B2 = RADIX * RADIX 1660 K = 1 1661 L = N 1662 GO TO 100 1663C .......... IN-LINE PROCEDURE FOR ROW AND 1664C COLUMN EXCHANGE .......... 1665 20 SCALE(M) = J 1666 IF (J .EQ. M) GO TO 50 1667C 1668 DO 30 I = 1, L 1669 F = AR(I,J) 1670 AR(I,J) = AR(I,M) 1671 AR(I,M) = F 1672 F = AI(I,J) 1673 AI(I,J) = AI(I,M) 1674 AI(I,M) = F 1675 30 CONTINUE 1676C 1677 DO 40 I = K, N 1678 F = AR(J,I) 1679 AR(J,I) = AR(M,I) 1680 AR(M,I) = F 1681 F = AI(J,I) 1682 AI(J,I) = AI(M,I) 1683 AI(M,I) = F 1684 40 CONTINUE 1685C 1686 50 GO TO (80,130), IEXC 1687C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE 1688C AND PUSH THEM DOWN .......... 1689 80 IF (L .EQ. 1) GO TO 280 1690 L = L - 1 1691C .......... FOR J=L STEP -1 UNTIL 1 DO -- .......... 1692 100 DO 120 JJ = 1, L 1693 J = L + 1 - JJ 1694C 1695 DO 110 I = 1, L 1696 IF (I .EQ. J) GO TO 110 1697 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GO TO 120 1698 110 CONTINUE 1699C 1700 M = L 1701 IEXC = 1 1702 GO TO 20 1703 120 CONTINUE 1704C 1705 GO TO 140 1706C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE 1707C AND PUSH THEM LEFT .......... 1708 130 K = K + 1 1709C 1710 140 DO 170 J = K, L 1711C 1712 DO 150 I = K, L 1713 IF (I .EQ. J) GO TO 150 1714 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GO TO 170 1715 150 CONTINUE 1716C 1717 M = K 1718 IEXC = 2 1719 GO TO 20 1720 170 CONTINUE 1721C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L .......... 1722 DO 180 I = K, L 1723 180 SCALE(I) = 1.0D0 1724C .......... ITERATIVE LOOP FOR NORM REDUCTION .......... 1725 190 NOCONV = .FALSE. 1726C 1727 DO 270 I = K, L 1728 C = 0.0D0 1729 R = 0.0D0 1730C 1731 DO 200 J = K, L 1732 IF (J .EQ. I) GO TO 200 1733 C = C + DABS(AR(J,I)) + DABS(AI(J,I)) 1734 R = R + DABS(AR(I,J)) + DABS(AI(I,J)) 1735 200 CONTINUE 1736C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW .......... 1737 IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GO TO 270 1738 G = R / RADIX 1739 F = 1.0D0 1740 S = C + R 1741 210 IF (C .GE. G) GO TO 220 1742 F = F * RADIX 1743 C = C * B2 1744 GO TO 210 1745 220 G = R * RADIX 1746 230 IF (C .LT. G) GO TO 240 1747 F = F / RADIX 1748 C = C / B2 1749 GO TO 230 1750C .......... NOW BALANCE .......... 1751 240 IF ((C + R) / F .GE. 0.95D0 * S) GO TO 270 1752 G = 1.0D0 / F 1753 SCALE(I) = SCALE(I) * F 1754 NOCONV = .TRUE. 1755C 1756 DO 250 J = K, N 1757 AR(I,J) = AR(I,J) * G 1758 AI(I,J) = AI(I,J) * G 1759 250 CONTINUE 1760C 1761 DO 260 J = 1, L 1762 AR(J,I) = AR(J,I) * F 1763 AI(J,I) = AI(J,I) * F 1764 260 CONTINUE 1765C 1766 270 CONTINUE 1767C 1768 IF (NOCONV) GO TO 190 1769C 1770 280 LOW = K 1771 IGH = L 1772 RETURN 1773 END 1774 SUBROUTINE CG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR) 1775C 1776 INTEGER N,NM,IS1,IS2,IERR,MATZ 1777 DOUBLE PRECISION AR(NM,N),AI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N), 1778 X FV1(N),FV2(N),FV3(N) 1779C 1780C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF 1781C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) 1782C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) 1783C OF A COMPLEX GENERAL MATRIX. 1784C 1785C ON INPUT 1786C 1787C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL 1788C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 1789C DIMENSION STATEMENT. 1790C 1791C N IS THE ORDER OF THE MATRIX A=(AR,AI). 1792C 1793C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, 1794C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX. 1795C 1796C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF 1797C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO 1798C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. 1799C 1800C ON OUTPUT 1801C 1802C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, 1803C RESPECTIVELY, OF THE EIGENVALUES. 1804C 1805C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, 1806C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO. 1807C 1808C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR 1809C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR 1810C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO. 1811C 1812C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS. 1813C 1814C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 1815C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 1816C 1817C THIS VERSION DATED AUGUST 1983. 1818C 1819C ------------------------------------------------------------------ 1820C 1821 IF (N .LE. NM) GO TO 10 1822 IERR = 10 * N 1823 GO TO 50 1824C 1825 10 CALL CBAL(NM,N,AR,AI,IS1,IS2,FV1) 1826 CALL CORTH(NM,N,IS1,IS2,AR,AI,FV2,FV3) 1827 IF (MATZ .NE. 0) GO TO 20 1828C .......... FIND EIGENVALUES ONLY .......... 1829 CALL COMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR) 1830 GO TO 50 1831C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 1832 20 CALL COMQR2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR) 1833 IF (IERR .NE. 0) GO TO 50 1834 CALL CBABK2(NM,N,IS1,IS2,FV1,N,ZR,ZI) 1835 50 RETURN 1836 END 1837 SUBROUTINE CH(NM,N,AR,AI,W,MATZ,ZR,ZI,FV1,FV2,FM1,IERR) 1838C 1839 INTEGER I,J,N,NM,IERR,MATZ 1840 DOUBLE PRECISION AR(NM,N),AI(NM,N),W(N),ZR(NM,N),ZI(NM,N), 1841 X FV1(N),FV2(N),FM1(2,N) 1842C 1843C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF 1844C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) 1845C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) 1846C OF A COMPLEX HERMITIAN MATRIX. 1847C 1848C ON INPUT 1849C 1850C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL 1851C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 1852C DIMENSION STATEMENT. 1853C 1854C N IS THE ORDER OF THE MATRIX A=(AR,AI). 1855C 1856C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, 1857C RESPECTIVELY, OF THE COMPLEX HERMITIAN MATRIX. 1858C 1859C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF 1860C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO 1861C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. 1862C 1863C ON OUTPUT 1864C 1865C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. 1866C 1867C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, 1868C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO. 1869C 1870C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR 1871C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT 1872C AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. 1873C 1874C FV1, FV2, AND FM1 ARE TEMPORARY STORAGE ARRAYS. 1875C 1876C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 1877C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 1878C 1879C THIS VERSION DATED AUGUST 1983. 1880C 1881C ------------------------------------------------------------------ 1882C 1883 IF (N .LE. NM) GO TO 10 1884 IERR = 10 * N 1885 GO TO 50 1886C 1887 10 CALL HTRIDI(NM,N,AR,AI,W,FV1,FV2,FM1) 1888 IF (MATZ .NE. 0) GO TO 20 1889C .......... FIND EIGENVALUES ONLY .......... 1890 CALL TQLRATL(N,W,FV2,IERR) 1891 GO TO 50 1892C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 1893 20 DO 40 I = 1, N 1894C 1895 DO 30 J = 1, N 1896 ZR(J,I) = 0.0D0 1897 30 CONTINUE 1898C 1899 ZR(I,I) = 1.0D0 1900 40 CONTINUE 1901C 1902 CALL TQL2L(NM,N,W,FV1,ZR,IERR) 1903 IF (IERR .NE. 0) GO TO 50 1904 CALL HTRIBK(NM,N,AR,AI,FM1,N,ZR,ZI) 1905 50 RETURN 1906 END 1907 SUBROUTINE CINVIT(NM,N,AR,AI,WR,WI,SELECT,MM,M,ZR,ZI, 1908 X IERR,RM1,RM2,RV1,RV2) 1909C 1910 INTEGER I,J,K,M,N,S,II,MM,MP,NM,UK,IP1,ITS,KM1,IERR 1911 DOUBLE PRECISION AR(NM,N),AI(NM,N),WR(N),WI(N),ZR(NM,MM), 1912 X ZI(NM,MM),RM1(N,N),RM2(N,N),RV1(N),RV2(N) 1913 DOUBLE PRECISION X,Y,EPS3,NORM,NORMV,EPSLON,GROWTO,ILAMBD,PYTHAG, 1914 X RLAMBD,UKROOT 1915 LOGICAL SELECT(N) 1916C 1917C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE CX INVIT 1918C BY PETERS AND WILKINSON. 1919C HANDBOOK FOR AUTO. COMP. VOL.II-LINEAR ALGEBRA, 418-439(1971). 1920C 1921C THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A COMPLEX UPPER 1922C HESSENBERG MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES, 1923C USING INVERSE ITERATION. 1924C 1925C ON INPUT 1926C 1927C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 1928C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 1929C DIMENSION STATEMENT. 1930C 1931C N IS THE ORDER OF THE MATRIX. 1932C 1933C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, 1934C RESPECTIVELY, OF THE HESSENBERG MATRIX. 1935C 1936C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, RESPECTIVELY, 1937C OF THE EIGENVALUES OF THE MATRIX. THE EIGENVALUES MUST BE 1938C STORED IN A MANNER IDENTICAL TO THAT OF SUBROUTINE COMLR, 1939C WHICH RECOGNIZES POSSIBLE SPLITTING OF THE MATRIX. 1940C 1941C SELECT SPECIFIES THE EIGENVECTORS TO BE FOUND. THE 1942C EIGENVECTOR CORRESPONDING TO THE J-TH EIGENVALUE IS 1943C SPECIFIED BY SETTING SELECT(J) TO .TRUE.. 1944C 1945C MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF 1946C EIGENVECTORS TO BE FOUND. 1947C 1948C ON OUTPUT 1949C 1950C AR, AI, WI, AND SELECT ARE UNALTERED. 1951C 1952C WR MAY HAVE BEEN ALTERED SINCE CLOSE EIGENVALUES ARE PERTURBED 1953C SLIGHTLY IN SEARCHING FOR INDEPENDENT EIGENVECTORS. 1954C 1955C M IS THE NUMBER OF EIGENVECTORS ACTUALLY FOUND. 1956C 1957C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, RESPECTIVELY, 1958C OF THE EIGENVECTORS. THE EIGENVECTORS ARE NORMALIZED 1959C SO THAT THE COMPONENT OF LARGEST MAGNITUDE IS 1. 1960C ANY VECTOR WHICH FAILS THE ACCEPTANCE TEST IS SET TO ZERO. 1961C 1962C IERR IS SET TO 1963C ZERO FOR NORMAL RETURN, 1964C -(2*N+1) IF MORE THAN MM EIGENVECTORS HAVE BEEN SPECIFIED, 1965C -K IF THE ITERATION CORRESPONDING TO THE K-TH 1966C VALUE FAILS, 1967C -(N+K) IF BOTH ERROR SITUATIONS OCCUR. 1968C 1969C RM1, RM2, RV1, AND RV2 ARE TEMPORARY STORAGE ARRAYS. 1970C 1971C THE ALGOL PROCEDURE GUESSVEC APPEARS IN CINVIT IN LINE. 1972C 1973C CALLS CDIV FOR COMPLEX DIVISION. 1974C CALLS PYTHAG FOR DSQRT(A*A + B*B) . 1975C 1976C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 1977C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 1978C 1979C THIS VERSION DATED AUGUST 1983. 1980C 1981C ------------------------------------------------------------------ 1982C 1983 IERR = 0 1984 UK = 0 1985 S = 1 1986C 1987 DO 980 K = 1, N 1988 IF (.NOT. SELECT(K)) GO TO 980 1989 IF (S .GT. MM) GO TO 1000 1990 IF (UK .GE. K) GO TO 200 1991C .......... CHECK FOR POSSIBLE SPLITTING .......... 1992 DO 120 UK = K, N 1993 IF (UK .EQ. N) GO TO 140 1994 IF (AR(UK+1,UK) .EQ. 0.0D0 .AND. AI(UK+1,UK) .EQ. 0.0D0) 1995 X GO TO 140 1996 120 CONTINUE 1997C .......... COMPUTE INFINITY NORM OF LEADING UK BY UK 1998C (HESSENBERG) MATRIX .......... 1999 140 NORM = 0.0D0 2000 MP = 1 2001C 2002 DO 180 I = 1, UK 2003 X = 0.0D0 2004C 2005 DO 160 J = MP, UK 2006 160 X = X + PYTHAG(AR(I,J),AI(I,J)) 2007C 2008 IF (X .GT. NORM) NORM = X 2009 MP = I 2010 180 CONTINUE 2011C .......... EPS3 REPLACES ZERO PIVOT IN DECOMPOSITION 2012C AND CLOSE ROOTS ARE MODIFIED BY EPS3 .......... 2013 IF (NORM .EQ. 0.0D0) NORM = 1.0D0 2014 EPS3 = EPSLON(NORM) 2015C .......... GROWTO IS THE CRITERION FOR GROWTH .......... 2016 UKROOT = UK 2017 UKROOT = DSQRT(UKROOT) 2018 GROWTO = 0.1D0 / UKROOT 2019 200 RLAMBD = WR(K) 2020 ILAMBD = WI(K) 2021 IF (K .EQ. 1) GO TO 280 2022 KM1 = K - 1 2023 GO TO 240 2024C .......... PERTURB EIGENVALUE IF IT IS CLOSE 2025C TO ANY PREVIOUS EIGENVALUE .......... 2026 220 RLAMBD = RLAMBD + EPS3 2027C .......... FOR I=K-1 STEP -1 UNTIL 1 DO -- .......... 2028 240 DO 260 II = 1, KM1 2029 I = K - II 2030 IF (SELECT(I) .AND. DABS(WR(I)-RLAMBD) .LT. EPS3 .AND. 2031 X DABS(WI(I)-ILAMBD) .LT. EPS3) GO TO 220 2032 260 CONTINUE 2033C 2034 WR(K) = RLAMBD 2035C .......... FORM UPPER HESSENBERG (AR,AI)-(RLAMBD,ILAMBD)*I 2036C AND INITIAL COMPLEX VECTOR .......... 2037 280 MP = 1 2038C 2039 DO 320 I = 1, UK 2040C 2041 DO 300 J = MP, UK 2042 RM1(I,J) = AR(I,J) 2043 RM2(I,J) = AI(I,J) 2044 300 CONTINUE 2045C 2046 RM1(I,I) = RM1(I,I) - RLAMBD 2047 RM2(I,I) = RM2(I,I) - ILAMBD 2048 MP = I 2049 RV1(I) = EPS3 2050 320 CONTINUE 2051C .......... TRIANGULAR DECOMPOSITION WITH INTERCHANGES, 2052C REPLACING ZERO PIVOTS BY EPS3 .......... 2053 IF (UK .EQ. 1) GO TO 420 2054C 2055 DO 400 I = 2, UK 2056 MP = I - 1 2057 IF (PYTHAG(RM1(I,MP),RM2(I,MP)) .LE. 2058 X PYTHAG(RM1(MP,MP),RM2(MP,MP))) GO TO 360 2059C 2060 DO 340 J = MP, UK 2061 Y = RM1(I,J) 2062 RM1(I,J) = RM1(MP,J) 2063 RM1(MP,J) = Y 2064 Y = RM2(I,J) 2065 RM2(I,J) = RM2(MP,J) 2066 RM2(MP,J) = Y 2067 340 CONTINUE 2068C 2069 360 IF (RM1(MP,MP) .EQ. 0.0D0 .AND. RM2(MP,MP) .EQ. 0.0D0) 2070 X RM1(MP,MP) = EPS3 2071 CALL CDIV(RM1(I,MP),RM2(I,MP),RM1(MP,MP),RM2(MP,MP),X,Y) 2072 IF (X .EQ. 0.0D0 .AND. Y .EQ. 0.0D0) GO TO 400 2073C 2074 DO 380 J = I, UK 2075 RM1(I,J) = RM1(I,J) - X * RM1(MP,J) + Y * RM2(MP,J) 2076 RM2(I,J) = RM2(I,J) - X * RM2(MP,J) - Y * RM1(MP,J) 2077 380 CONTINUE 2078C 2079 400 CONTINUE 2080C 2081 420 IF (RM1(UK,UK) .EQ. 0.0D0 .AND. RM2(UK,UK) .EQ. 0.0D0) 2082 X RM1(UK,UK) = EPS3 2083 ITS = 0 2084C .......... BACK SUBSTITUTION 2085C FOR I=UK STEP -1 UNTIL 1 DO -- .......... 2086 660 DO 720 II = 1, UK 2087 I = UK + 1 - II 2088 X = RV1(I) 2089 Y = 0.0D0 2090 IF (I .EQ. UK) GO TO 700 2091 IP1 = I + 1 2092C 2093 DO 680 J = IP1, UK 2094 X = X - RM1(I,J) * RV1(J) + RM2(I,J) * RV2(J) 2095 Y = Y - RM1(I,J) * RV2(J) - RM2(I,J) * RV1(J) 2096 680 CONTINUE 2097C 2098 700 CALL CDIV(X,Y,RM1(I,I),RM2(I,I),RV1(I),RV2(I)) 2099 720 CONTINUE 2100C .......... ACCEPTANCE TEST FOR EIGENVECTOR 2101C AND NORMALIZATION .......... 2102 ITS = ITS + 1 2103 NORM = 0.0D0 2104 NORMV = 0.0D0 2105C 2106 DO 780 I = 1, UK 2107 X = PYTHAG(RV1(I),RV2(I)) 2108 IF (NORMV .GE. X) GO TO 760 2109 NORMV = X 2110 J = I 2111 760 NORM = NORM + X 2112 780 CONTINUE 2113C 2114 IF (NORM .LT. GROWTO) GO TO 840 2115C .......... ACCEPT VECTOR .......... 2116 X = RV1(J) 2117 Y = RV2(J) 2118C 2119 DO 820 I = 1, UK 2120 CALL CDIV(RV1(I),RV2(I),X,Y,ZR(I,S),ZI(I,S)) 2121 820 CONTINUE 2122C 2123 IF (UK .EQ. N) GO TO 940 2124 J = UK + 1 2125 GO TO 900 2126C .......... IN-LINE PROCEDURE FOR CHOOSING 2127C A NEW STARTING VECTOR .......... 2128 840 IF (ITS .GE. UK) GO TO 880 2129 X = UKROOT 2130 Y = EPS3 / (X + 1.0D0) 2131 RV1(1) = EPS3 2132C 2133 DO 860 I = 2, UK 2134 860 RV1(I) = Y 2135C 2136 J = UK - ITS + 1 2137 RV1(J) = RV1(J) - EPS3 * X 2138 GO TO 660 2139C .......... SET ERROR -- UNACCEPTED EIGENVECTOR .......... 2140 880 J = 1 2141 IERR = -K 2142C .......... SET REMAINING VECTOR COMPONENTS TO ZERO .......... 2143 900 DO 920 I = J, N 2144 ZR(I,S) = 0.0D0 2145 ZI(I,S) = 0.0D0 2146 920 CONTINUE 2147C 2148 940 S = S + 1 2149 980 CONTINUE 2150C 2151 GO TO 1001 2152C .......... SET ERROR -- UNDERESTIMATE OF EIGENVECTOR 2153C SPACE REQUIRED .......... 2154 1000 IF (IERR .NE. 0) IERR = IERR - N 2155 IF (IERR .EQ. 0) IERR = -(2 * N + 1) 2156 1001 M = S - 1 2157 RETURN 2158 END 2159 SUBROUTINE COMBAK(NM,LOW,IGH,AR,AI,INT,M,ZR,ZI) 2160C 2161 INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1 2162 DOUBLE PRECISION AR(NM,IGH),AI(NM,IGH),ZR(NM,M),ZI(NM,M) 2163 DOUBLE PRECISION XR,XI 2164 INTEGER INT(IGH) 2165C 2166C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMBAK, 2167C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. 2168C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). 2169C 2170C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL 2171C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING 2172C UPPER HESSENBERG MATRIX DETERMINED BY COMHES. 2173C 2174C ON INPUT 2175C 2176C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 2177C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 2178C DIMENSION STATEMENT. 2179C 2180C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING 2181C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, 2182C SET LOW=1 AND IGH EQUAL TO THE ORDER OF THE MATRIX. 2183C 2184C AR AND AI CONTAIN THE MULTIPLIERS WHICH WERE USED IN THE 2185C REDUCTION BY COMHES IN THEIR LOWER TRIANGLES 2186C BELOW THE SUBDIAGONAL. 2187C 2188C INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS 2189C INTERCHANGED IN THE REDUCTION BY COMHES. 2190C ONLY ELEMENTS LOW THROUGH IGH ARE USED. 2191C 2192C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. 2193C 2194C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, 2195C RESPECTIVELY, OF THE EIGENVECTORS TO BE 2196C BACK TRANSFORMED IN THEIR FIRST M COLUMNS. 2197C 2198C ON OUTPUT 2199C 2200C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, 2201C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS 2202C IN THEIR FIRST M COLUMNS. 2203C 2204C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 2205C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 2206C 2207C THIS VERSION DATED AUGUST 1983. 2208C 2209C ------------------------------------------------------------------ 2210C 2211 IF (M .EQ. 0) GO TO 200 2212 LA = IGH - 1 2213 KP1 = LOW + 1 2214 IF (LA .LT. KP1) GO TO 200 2215C .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... 2216 DO 140 MM = KP1, LA 2217 MP = LOW + IGH - MM 2218 MP1 = MP + 1 2219C 2220 DO 110 I = MP1, IGH 2221 XR = AR(I,MP-1) 2222 XI = AI(I,MP-1) 2223 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 110 2224C 2225 DO 100 J = 1, M 2226 ZR(I,J) = ZR(I,J) + XR * ZR(MP,J) - XI * ZI(MP,J) 2227 ZI(I,J) = ZI(I,J) + XR * ZI(MP,J) + XI * ZR(MP,J) 2228 100 CONTINUE 2229C 2230 110 CONTINUE 2231C 2232 I = INT(MP) 2233 IF (I .EQ. MP) GO TO 140 2234C 2235 DO 130 J = 1, M 2236 XR = ZR(I,J) 2237 ZR(I,J) = ZR(MP,J) 2238 ZR(MP,J) = XR 2239 XI = ZI(I,J) 2240 ZI(I,J) = ZI(MP,J) 2241 ZI(MP,J) = XI 2242 130 CONTINUE 2243C 2244 140 CONTINUE 2245C 2246 200 RETURN 2247 END 2248 SUBROUTINE COMHES(NM,N,LOW,IGH,AR,AI,INT) 2249C 2250 INTEGER I,J,M,N,LA,NM,IGH,KP1,LOW,MM1,MP1 2251 DOUBLE PRECISION AR(NM,N),AI(NM,N) 2252 DOUBLE PRECISION XR,XI,YR,YI 2253 INTEGER INT(IGH) 2254C 2255C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMHES, 2256C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. 2257C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). 2258C 2259C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE 2260C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS 2261C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY 2262C STABILIZED ELEMENTARY SIMILARITY TRANSFORMATIONS. 2263C 2264C ON INPUT 2265C 2266C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 2267C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 2268C DIMENSION STATEMENT. 2269C 2270C N IS THE ORDER OF THE MATRIX. 2271C 2272C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING 2273C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, 2274C SET LOW=1, IGH=N. 2275C 2276C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, 2277C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX. 2278C 2279C ON OUTPUT 2280C 2281C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, 2282C RESPECTIVELY, OF THE HESSENBERG MATRIX. THE 2283C MULTIPLIERS WHICH WERE USED IN THE REDUCTION 2284C ARE STORED IN THE REMAINING TRIANGLES UNDER THE 2285C HESSENBERG MATRIX. 2286C 2287C INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS 2288C INTERCHANGED IN THE REDUCTION. 2289C ONLY ELEMENTS LOW THROUGH IGH ARE USED. 2290C 2291C CALLS CDIV FOR COMPLEX DIVISION. 2292C 2293C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 2294C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 2295C 2296C THIS VERSION DATED AUGUST 1983. 2297C 2298C ------------------------------------------------------------------ 2299C 2300 LA = IGH - 1 2301 KP1 = LOW + 1 2302 IF (LA .LT. KP1) GO TO 200 2303C 2304 DO 180 M = KP1, LA 2305 MM1 = M - 1 2306 XR = 0.0D0 2307 XI = 0.0D0 2308 I = M 2309C 2310 DO 100 J = M, IGH 2311 IF (DABS(AR(J,MM1)) + DABS(AI(J,MM1)) 2312 X .LE. DABS(XR) + DABS(XI)) GO TO 100 2313 XR = AR(J,MM1) 2314 XI = AI(J,MM1) 2315 I = J 2316 100 CONTINUE 2317C 2318 INT(M) = I 2319 IF (I .EQ. M) GO TO 130 2320C .......... INTERCHANGE ROWS AND COLUMNS OF AR AND AI .......... 2321 DO 110 J = MM1, N 2322 YR = AR(I,J) 2323 AR(I,J) = AR(M,J) 2324 AR(M,J) = YR 2325 YI = AI(I,J) 2326 AI(I,J) = AI(M,J) 2327 AI(M,J) = YI 2328 110 CONTINUE 2329C 2330 DO 120 J = 1, IGH 2331 YR = AR(J,I) 2332 AR(J,I) = AR(J,M) 2333 AR(J,M) = YR 2334 YI = AI(J,I) 2335 AI(J,I) = AI(J,M) 2336 AI(J,M) = YI 2337 120 CONTINUE 2338C .......... END INTERCHANGE .......... 2339 130 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 180 2340 MP1 = M + 1 2341C 2342 DO 160 I = MP1, IGH 2343 YR = AR(I,MM1) 2344 YI = AI(I,MM1) 2345 IF (YR .EQ. 0.0D0 .AND. YI .EQ. 0.0D0) GO TO 160 2346 CALL CDIV(YR,YI,XR,XI,YR,YI) 2347 AR(I,MM1) = YR 2348 AI(I,MM1) = YI 2349C 2350 DO 140 J = M, N 2351 AR(I,J) = AR(I,J) - YR * AR(M,J) + YI * AI(M,J) 2352 AI(I,J) = AI(I,J) - YR * AI(M,J) - YI * AR(M,J) 2353 140 CONTINUE 2354C 2355 DO 150 J = 1, IGH 2356 AR(J,M) = AR(J,M) + YR * AR(J,I) - YI * AI(J,I) 2357 AI(J,M) = AI(J,M) + YR * AI(J,I) + YI * AR(J,I) 2358 150 CONTINUE 2359C 2360 160 CONTINUE 2361C 2362 180 CONTINUE 2363C 2364 200 RETURN 2365 END 2366 SUBROUTINE COMLR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR) 2367C 2368 INTEGER I,J,L,M,N,EN,LL,MM,NM,IGH,IM1,ITN,ITS,LOW,MP1,ENM1,IERR 2369 DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N) 2370 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,TST1,TST2 2371C 2372C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMLR, 2373C NUM. MATH. 12, 369-376(1968) BY MARTIN AND WILKINSON. 2374C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971). 2375C 2376C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX 2377C UPPER HESSENBERG MATRIX BY THE MODIFIED LR METHOD. 2378C 2379C ON INPUT 2380C 2381C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 2382C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 2383C DIMENSION STATEMENT. 2384C 2385C N IS THE ORDER OF THE MATRIX. 2386C 2387C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING 2388C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, 2389C SET LOW=1, IGH=N. 2390C 2391C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, 2392C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. 2393C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN THE 2394C MULTIPLIERS WHICH WERE USED IN THE REDUCTION BY COMHES, 2395C IF PERFORMED. 2396C 2397C ON OUTPUT 2398C 2399C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN 2400C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE 2401C CALLING COMLR IF SUBSEQUENT CALCULATION OF 2402C EIGENVECTORS IS TO BE PERFORMED. 2403C 2404C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, 2405C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR 2406C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT 2407C FOR INDICES IERR+1,...,N. 2408C 2409C IERR IS SET TO 2410C ZERO FOR NORMAL RETURN, 2411C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED 2412C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. 2413C 2414C CALLS CDIV FOR COMPLEX DIVISION. 2415C CALLS CSROOT FOR COMPLEX SQUARE ROOT. 2416C 2417C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 2418C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 2419C 2420C THIS VERSION DATED AUGUST 1983. 2421C 2422C ------------------------------------------------------------------ 2423C 2424 IERR = 0 2425C .......... STORE ROOTS ISOLATED BY CBAL .......... 2426 DO 200 I = 1, N 2427 IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200 2428 WR(I) = HR(I,I) 2429 WI(I) = HI(I,I) 2430 200 CONTINUE 2431C 2432 EN = IGH 2433 TR = 0.0D0 2434 TI = 0.0D0 2435 ITN = 30*N 2436C .......... SEARCH FOR NEXT EIGENVALUE .......... 2437 220 IF (EN .LT. LOW) GO TO 1001 2438 ITS = 0 2439 ENM1 = EN - 1 2440C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT 2441C FOR L=EN STEP -1 UNTIL LOW D0 -- .......... 2442 240 DO 260 LL = LOW, EN 2443 L = EN + LOW - LL 2444 IF (L .EQ. LOW) GO TO 300 2445 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1)) 2446 X + DABS(HR(L,L)) + DABS(HI(L,L)) 2447 TST2 = TST1 + DABS(HR(L,L-1)) + DABS(HI(L,L-1)) 2448 IF (TST2 .EQ. TST1) GO TO 300 2449 260 CONTINUE 2450C .......... FORM SHIFT .......... 2451 300 IF (L .EQ. EN) GO TO 660 2452 IF (ITN .EQ. 0) GO TO 1000 2453 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320 2454 SR = HR(EN,EN) 2455 SI = HI(EN,EN) 2456 XR = HR(ENM1,EN) * HR(EN,ENM1) - HI(ENM1,EN) * HI(EN,ENM1) 2457 XI = HR(ENM1,EN) * HI(EN,ENM1) + HI(ENM1,EN) * HR(EN,ENM1) 2458 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 340 2459 YR = (HR(ENM1,ENM1) - SR) / 2.0D0 2460 YI = (HI(ENM1,ENM1) - SI) / 2.0D0 2461 CALL CSROOT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI) 2462 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GO TO 310 2463 ZZR = -ZZR 2464 ZZI = -ZZI 2465 310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI) 2466 SR = SR - XR 2467 SI = SI - XI 2468 GO TO 340 2469C .......... FORM EXCEPTIONAL SHIFT .......... 2470 320 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2)) 2471 SI = DABS(HI(EN,ENM1)) + DABS(HI(ENM1,EN-2)) 2472C 2473 340 DO 360 I = LOW, EN 2474 HR(I,I) = HR(I,I) - SR 2475 HI(I,I) = HI(I,I) - SI 2476 360 CONTINUE 2477C 2478 TR = TR + SR 2479 TI = TI + SI 2480 ITS = ITS + 1 2481 ITN = ITN - 1 2482C .......... LOOK FOR TWO CONSECUTIVE SMALL 2483C SUB-DIAGONAL ELEMENTS .......... 2484 XR = DABS(HR(ENM1,ENM1)) + DABS(HI(ENM1,ENM1)) 2485 YR = DABS(HR(EN,ENM1)) + DABS(HI(EN,ENM1)) 2486 ZZR = DABS(HR(EN,EN)) + DABS(HI(EN,EN)) 2487C .......... FOR M=EN-1 STEP -1 UNTIL L DO -- .......... 2488 DO 380 MM = L, ENM1 2489 M = ENM1 + L - MM 2490 IF (M .EQ. L) GO TO 420 2491 YI = YR 2492 YR = DABS(HR(M,M-1)) + DABS(HI(M,M-1)) 2493 XI = ZZR 2494 ZZR = XR 2495 XR = DABS(HR(M-1,M-1)) + DABS(HI(M-1,M-1)) 2496 TST1 = ZZR / YI * (ZZR + XR + XI) 2497 TST2 = TST1 + YR 2498 IF (TST2 .EQ. TST1) GO TO 420 2499 380 CONTINUE 2500C .......... TRIANGULAR DECOMPOSITION H=L*R .......... 2501 420 MP1 = M + 1 2502C 2503 DO 520 I = MP1, EN 2504 IM1 = I - 1 2505 XR = HR(IM1,IM1) 2506 XI = HI(IM1,IM1) 2507 YR = HR(I,IM1) 2508 YI = HI(I,IM1) 2509 IF (DABS(XR) + DABS(XI) .GE. DABS(YR) + DABS(YI)) GO TO 460 2510C .......... INTERCHANGE ROWS OF HR AND HI .......... 2511 DO 440 J = IM1, EN 2512 ZZR = HR(IM1,J) 2513 HR(IM1,J) = HR(I,J) 2514 HR(I,J) = ZZR 2515 ZZI = HI(IM1,J) 2516 HI(IM1,J) = HI(I,J) 2517 HI(I,J) = ZZI 2518 440 CONTINUE 2519C 2520 CALL CDIV(XR,XI,YR,YI,ZZR,ZZI) 2521 WR(I) = 1.0D0 2522 GO TO 480 2523 460 CALL CDIV(YR,YI,XR,XI,ZZR,ZZI) 2524 WR(I) = -1.0D0 2525 480 HR(I,IM1) = ZZR 2526 HI(I,IM1) = ZZI 2527C 2528 DO 500 J = I, EN 2529 HR(I,J) = HR(I,J) - ZZR * HR(IM1,J) + ZZI * HI(IM1,J) 2530 HI(I,J) = HI(I,J) - ZZR * HI(IM1,J) - ZZI * HR(IM1,J) 2531 500 CONTINUE 2532C 2533 520 CONTINUE 2534C .......... COMPOSITION R*L=H .......... 2535 DO 640 J = MP1, EN 2536 XR = HR(J,J-1) 2537 XI = HI(J,J-1) 2538 HR(J,J-1) = 0.0D0 2539 HI(J,J-1) = 0.0D0 2540C .......... INTERCHANGE COLUMNS OF HR AND HI, 2541C IF NECESSARY .......... 2542 IF (WR(J) .LE. 0.0D0) GO TO 580 2543C 2544 DO 540 I = L, J 2545 ZZR = HR(I,J-1) 2546 HR(I,J-1) = HR(I,J) 2547 HR(I,J) = ZZR 2548 ZZI = HI(I,J-1) 2549 HI(I,J-1) = HI(I,J) 2550 HI(I,J) = ZZI 2551 540 CONTINUE 2552C 2553 580 DO 600 I = L, J 2554 HR(I,J-1) = HR(I,J-1) + XR * HR(I,J) - XI * HI(I,J) 2555 HI(I,J-1) = HI(I,J-1) + XR * HI(I,J) + XI * HR(I,J) 2556 600 CONTINUE 2557C 2558 640 CONTINUE 2559C 2560 GO TO 240 2561C .......... A ROOT FOUND .......... 2562 660 WR(EN) = HR(EN,EN) + TR 2563 WI(EN) = HI(EN,EN) + TI 2564 EN = ENM1 2565 GO TO 220 2566C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT 2567C CONVERGED AFTER 30*N ITERATIONS .......... 2568 1000 IERR = EN 2569 1001 RETURN 2570 END 2571 SUBROUTINE COMLR2(NM,N,LOW,IGH,INT,HR,HI,WR,WI,ZR,ZI,IERR) 2572C 2573 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NM,NN,IGH,IM1,IP1, 2574 X ITN,ITS,LOW,MP1,ENM1,IEND,IERR 2575 DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N) 2576 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2 2577 INTEGER INT(IGH) 2578C 2579C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMLR2, 2580C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. 2581C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). 2582C 2583C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS 2584C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE MODIFIED LR 2585C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX 2586C CAN ALSO BE FOUND IF COMHES HAS BEEN USED TO REDUCE 2587C THIS GENERAL MATRIX TO HESSENBERG FORM. 2588C 2589C ON INPUT 2590C 2591C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 2592C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 2593C DIMENSION STATEMENT. 2594C 2595C N IS THE ORDER OF THE MATRIX. 2596C 2597C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING 2598C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, 2599C SET LOW=1, IGH=N. 2600C 2601C INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS INTERCHANGED 2602C IN THE REDUCTION BY COMHES, IF PERFORMED. ONLY ELEMENTS 2603C LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS OF THE HESSEN- 2604C BERG MATRIX ARE DESIRED, SET INT(J)=J FOR THESE ELEMENTS. 2605C 2606C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, 2607C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. 2608C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN THE 2609C MULTIPLIERS WHICH WERE USED IN THE REDUCTION BY COMHES, 2610C IF PERFORMED. IF THE EIGENVECTORS OF THE HESSENBERG 2611C MATRIX ARE DESIRED, THESE ELEMENTS MUST BE SET TO ZERO. 2612C 2613C ON OUTPUT 2614C 2615C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN 2616C DESTROYED, BUT THE LOCATION HR(1,1) CONTAINS THE NORM 2617C OF THE TRIANGULARIZED MATRIX. 2618C 2619C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, 2620C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR 2621C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT 2622C FOR INDICES IERR+1,...,N. 2623C 2624C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, 2625C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS 2626C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF 2627C THE EIGENVECTORS HAS BEEN FOUND. 2628C 2629C IERR IS SET TO 2630C ZERO FOR NORMAL RETURN, 2631C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED 2632C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. 2633C 2634C 2635C CALLS CDIV FOR COMPLEX DIVISION. 2636C CALLS CSROOT FOR COMPLEX SQUARE ROOT. 2637C 2638C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 2639C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 2640C 2641C THIS VERSION DATED AUGUST 1983. 2642C 2643C ------------------------------------------------------------------ 2644C 2645 IERR = 0 2646C .......... INITIALIZE EIGENVECTOR MATRIX .......... 2647 DO 100 I = 1, N 2648C 2649 DO 100 J = 1, N 2650 ZR(I,J) = 0.0D0 2651 ZI(I,J) = 0.0D0 2652 IF (I .EQ. J) ZR(I,J) = 1.0D0 2653 100 CONTINUE 2654C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS 2655C FROM THE INFORMATION LEFT BY COMHES .......... 2656 IEND = IGH - LOW - 1 2657 IF (IEND .LE. 0) GO TO 180 2658C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... 2659 DO 160 II = 1, IEND 2660 I = IGH - II 2661 IP1 = I + 1 2662C 2663 DO 120 K = IP1, IGH 2664 ZR(K,I) = HR(K,I-1) 2665 ZI(K,I) = HI(K,I-1) 2666 120 CONTINUE 2667C 2668 J = INT(I) 2669 IF (I .EQ. J) GO TO 160 2670C 2671 DO 140 K = I, IGH 2672 ZR(I,K) = ZR(J,K) 2673 ZI(I,K) = ZI(J,K) 2674 ZR(J,K) = 0.0D0 2675 ZI(J,K) = 0.0D0 2676 140 CONTINUE 2677C 2678 ZR(J,I) = 1.0D0 2679 160 CONTINUE 2680C .......... STORE ROOTS ISOLATED BY CBAL .......... 2681 180 DO 200 I = 1, N 2682 IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200 2683 WR(I) = HR(I,I) 2684 WI(I) = HI(I,I) 2685 200 CONTINUE 2686C 2687 EN = IGH 2688 TR = 0.0D0 2689 TI = 0.0D0 2690 ITN = 30*N 2691C .......... SEARCH FOR NEXT EIGENVALUE .......... 2692 220 IF (EN .LT. LOW) GO TO 680 2693 ITS = 0 2694 ENM1 = EN - 1 2695C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT 2696C FOR L=EN STEP -1 UNTIL LOW DO -- .......... 2697 240 DO 260 LL = LOW, EN 2698 L = EN + LOW - LL 2699 IF (L .EQ. LOW) GO TO 300 2700 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1)) 2701 X + DABS(HR(L,L)) + DABS(HI(L,L)) 2702 TST2 = TST1 + DABS(HR(L,L-1)) + DABS(HI(L,L-1)) 2703 IF (TST2 .EQ. TST1) GO TO 300 2704 260 CONTINUE 2705C .......... FORM SHIFT .......... 2706 300 IF (L .EQ. EN) GO TO 660 2707 IF (ITN .EQ. 0) GO TO 1000 2708 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320 2709 SR = HR(EN,EN) 2710 SI = HI(EN,EN) 2711 XR = HR(ENM1,EN) * HR(EN,ENM1) - HI(ENM1,EN) * HI(EN,ENM1) 2712 XI = HR(ENM1,EN) * HI(EN,ENM1) + HI(ENM1,EN) * HR(EN,ENM1) 2713 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 340 2714 YR = (HR(ENM1,ENM1) - SR) / 2.0D0 2715 YI = (HI(ENM1,ENM1) - SI) / 2.0D0 2716 CALL CSROOT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI) 2717 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GO TO 310 2718 ZZR = -ZZR 2719 ZZI = -ZZI 2720 310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI) 2721 SR = SR - XR 2722 SI = SI - XI 2723 GO TO 340 2724C .......... FORM EXCEPTIONAL SHIFT .......... 2725 320 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2)) 2726 SI = DABS(HI(EN,ENM1)) + DABS(HI(ENM1,EN-2)) 2727C 2728 340 DO 360 I = LOW, EN 2729 HR(I,I) = HR(I,I) - SR 2730 HI(I,I) = HI(I,I) - SI 2731 360 CONTINUE 2732C 2733 TR = TR + SR 2734 TI = TI + SI 2735 ITS = ITS + 1 2736 ITN = ITN - 1 2737C .......... LOOK FOR TWO CONSECUTIVE SMALL 2738C SUB-DIAGONAL ELEMENTS .......... 2739 XR = DABS(HR(ENM1,ENM1)) + DABS(HI(ENM1,ENM1)) 2740 YR = DABS(HR(EN,ENM1)) + DABS(HI(EN,ENM1)) 2741 ZZR = DABS(HR(EN,EN)) + DABS(HI(EN,EN)) 2742C .......... FOR M=EN-1 STEP -1 UNTIL L DO -- .......... 2743 DO 380 MM = L, ENM1 2744 M = ENM1 + L - MM 2745 IF (M .EQ. L) GO TO 420 2746 YI = YR 2747 YR = DABS(HR(M,M-1)) + DABS(HI(M,M-1)) 2748 XI = ZZR 2749 ZZR = XR 2750 XR = DABS(HR(M-1,M-1)) + DABS(HI(M-1,M-1)) 2751 TST1 = ZZR / YI * (ZZR + XR + XI) 2752 TST2 = TST1 + YR 2753 IF (TST2 .EQ. TST1) GO TO 420 2754 380 CONTINUE 2755C .......... TRIANGULAR DECOMPOSITION H=L*R .......... 2756 420 MP1 = M + 1 2757C 2758 DO 520 I = MP1, EN 2759 IM1 = I - 1 2760 XR = HR(IM1,IM1) 2761 XI = HI(IM1,IM1) 2762 YR = HR(I,IM1) 2763 YI = HI(I,IM1) 2764 IF (DABS(XR) + DABS(XI) .GE. DABS(YR) + DABS(YI)) GO TO 460 2765C .......... INTERCHANGE ROWS OF HR AND HI .......... 2766 DO 440 J = IM1, N 2767 ZZR = HR(IM1,J) 2768 HR(IM1,J) = HR(I,J) 2769 HR(I,J) = ZZR 2770 ZZI = HI(IM1,J) 2771 HI(IM1,J) = HI(I,J) 2772 HI(I,J) = ZZI 2773 440 CONTINUE 2774C 2775 CALL CDIV(XR,XI,YR,YI,ZZR,ZZI) 2776 WR(I) = 1.0D0 2777 GO TO 480 2778 460 CALL CDIV(YR,YI,XR,XI,ZZR,ZZI) 2779 WR(I) = -1.0D0 2780 480 HR(I,IM1) = ZZR 2781 HI(I,IM1) = ZZI 2782C 2783 DO 500 J = I, N 2784 HR(I,J) = HR(I,J) - ZZR * HR(IM1,J) + ZZI * HI(IM1,J) 2785 HI(I,J) = HI(I,J) - ZZR * HI(IM1,J) - ZZI * HR(IM1,J) 2786 500 CONTINUE 2787C 2788 520 CONTINUE 2789C .......... COMPOSITION R*L=H .......... 2790 DO 640 J = MP1, EN 2791 XR = HR(J,J-1) 2792 XI = HI(J,J-1) 2793 HR(J,J-1) = 0.0D0 2794 HI(J,J-1) = 0.0D0 2795C .......... INTERCHANGE COLUMNS OF HR, HI, ZR, AND ZI, 2796C IF NECESSARY .......... 2797 IF (WR(J) .LE. 0.0D0) GO TO 580 2798C 2799 DO 540 I = 1, J 2800 ZZR = HR(I,J-1) 2801 HR(I,J-1) = HR(I,J) 2802 HR(I,J) = ZZR 2803 ZZI = HI(I,J-1) 2804 HI(I,J-1) = HI(I,J) 2805 HI(I,J) = ZZI 2806 540 CONTINUE 2807C 2808 DO 560 I = LOW, IGH 2809 ZZR = ZR(I,J-1) 2810 ZR(I,J-1) = ZR(I,J) 2811 ZR(I,J) = ZZR 2812 ZZI = ZI(I,J-1) 2813 ZI(I,J-1) = ZI(I,J) 2814 ZI(I,J) = ZZI 2815 560 CONTINUE 2816C 2817 580 DO 600 I = 1, J 2818 HR(I,J-1) = HR(I,J-1) + XR * HR(I,J) - XI * HI(I,J) 2819 HI(I,J-1) = HI(I,J-1) + XR * HI(I,J) + XI * HR(I,J) 2820 600 CONTINUE 2821C .......... ACCUMULATE TRANSFORMATIONS .......... 2822 DO 620 I = LOW, IGH 2823 ZR(I,J-1) = ZR(I,J-1) + XR * ZR(I,J) - XI * ZI(I,J) 2824 ZI(I,J-1) = ZI(I,J-1) + XR * ZI(I,J) + XI * ZR(I,J) 2825 620 CONTINUE 2826C 2827 640 CONTINUE 2828C 2829 GO TO 240 2830C .......... A ROOT FOUND .......... 2831 660 HR(EN,EN) = HR(EN,EN) + TR 2832 WR(EN) = HR(EN,EN) 2833 HI(EN,EN) = HI(EN,EN) + TI 2834 WI(EN) = HI(EN,EN) 2835 EN = ENM1 2836 GO TO 220 2837C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND 2838C VECTORS OF UPPER TRIANGULAR FORM .......... 2839 680 NORM = 0.0D0 2840C 2841 DO 720 I = 1, N 2842C 2843 DO 720 J = I, N 2844 TR = DABS(HR(I,J)) + DABS(HI(I,J)) 2845 IF (TR .GT. NORM) NORM = TR 2846 720 CONTINUE 2847C 2848 HR(1,1) = NORM 2849 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GO TO 1001 2850C .......... FOR EN=N STEP -1 UNTIL 2 DO -- .......... 2851 DO 800 NN = 2, N 2852 EN = N + 2 - NN 2853 XR = WR(EN) 2854 XI = WI(EN) 2855 HR(EN,EN) = 1.0D0 2856 HI(EN,EN) = 0.0D0 2857 ENM1 = EN - 1 2858C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... 2859 DO 780 II = 1, ENM1 2860 I = EN - II 2861 ZZR = 0.0D0 2862 ZZI = 0.0D0 2863 IP1 = I + 1 2864C 2865 DO 740 J = IP1, EN 2866 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN) 2867 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN) 2868 740 CONTINUE 2869C 2870 YR = XR - WR(I) 2871 YI = XI - WI(I) 2872 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GO TO 765 2873 TST1 = NORM 2874 YR = TST1 2875 760 YR = 0.01D0 * YR 2876 TST2 = NORM + YR 2877 IF (TST2 .GT. TST1) GO TO 760 2878 765 CONTINUE 2879 CALL CDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN)) 2880C .......... OVERFLOW CONTROL .......... 2881 TR = DABS(HR(I,EN)) + DABS(HI(I,EN)) 2882 IF (TR .EQ. 0.0D0) GO TO 780 2883 TST1 = TR 2884 TST2 = TST1 + 1.0D0/TST1 2885 IF (TST2 .GT. TST1) GO TO 780 2886 DO 770 J = I, EN 2887 HR(J,EN) = HR(J,EN)/TR 2888 HI(J,EN) = HI(J,EN)/TR 2889 770 CONTINUE 2890C 2891 780 CONTINUE 2892C 2893 800 CONTINUE 2894C .......... END BACKSUBSTITUTION .......... 2895 ENM1 = N - 1 2896C .......... VECTORS OF ISOLATED ROOTS .......... 2897 DO 840 I = 1, ENM1 2898 IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840 2899 IP1 = I + 1 2900C 2901 DO 820 J = IP1, N 2902 ZR(I,J) = HR(I,J) 2903 ZI(I,J) = HI(I,J) 2904 820 CONTINUE 2905C 2906 840 CONTINUE 2907C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE 2908C VECTORS OF ORIGINAL FULL MATRIX. 2909C FOR J=N STEP -1 UNTIL LOW+1 DO -- .......... 2910 DO 880 JJ = LOW, ENM1 2911 J = N + LOW - JJ 2912 M = MIN0(J,IGH) 2913C 2914 DO 880 I = LOW, IGH 2915 ZZR = 0.0D0 2916 ZZI = 0.0D0 2917C 2918 DO 860 K = LOW, M 2919 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J) 2920 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J) 2921 860 CONTINUE 2922C 2923 ZR(I,J) = ZZR 2924 ZI(I,J) = ZZI 2925 880 CONTINUE 2926C 2927 GO TO 1001 2928C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT 2929C CONVERGED AFTER 30*N ITERATIONS .......... 2930 1000 IERR = EN 2931 1001 RETURN 2932 END 2933 SUBROUTINE COMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR) 2934C 2935 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR 2936 DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N) 2937 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2, 2938 X PYTHAG 2939C 2940C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE 2941C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN 2942C AND WILKINSON. 2943C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971). 2944C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS 2945C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM. 2946C 2947C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX 2948C UPPER HESSENBERG MATRIX BY THE QR METHOD. 2949C 2950C ON INPUT 2951C 2952C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 2953C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 2954C DIMENSION STATEMENT. 2955C 2956C N IS THE ORDER OF THE MATRIX. 2957C 2958C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING 2959C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, 2960C SET LOW=1, IGH=N. 2961C 2962C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, 2963C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. 2964C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN 2965C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN 2966C THE REDUCTION BY CORTH, IF PERFORMED. 2967C 2968C ON OUTPUT 2969C 2970C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN 2971C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE 2972C CALLING COMQR IF SUBSEQUENT CALCULATION OF 2973C EIGENVECTORS IS TO BE PERFORMED. 2974C 2975C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, 2976C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR 2977C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT 2978C FOR INDICES IERR+1,...,N. 2979C 2980C IERR IS SET TO 2981C ZERO FOR NORMAL RETURN, 2982C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED 2983C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. 2984C 2985C CALLS CDIV FOR COMPLEX DIVISION. 2986C CALLS CSROOT FOR COMPLEX SQUARE ROOT. 2987C CALLS PYTHAG FOR DSQRT(A*A + B*B) . 2988C 2989C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 2990C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 2991C 2992C THIS VERSION DATED AUGUST 1983. 2993C 2994C ------------------------------------------------------------------ 2995C 2996 IERR = 0 2997 IF (LOW .EQ. IGH) GO TO 180 2998C .......... CREATE REAL SUBDIAGONAL ELEMENTS .......... 2999 L = LOW + 1 3000C 3001 DO 170 I = L, IGH 3002 LL = MIN0(I+1,IGH) 3003 IF (HI(I,I-1) .EQ. 0.0D0) GO TO 170 3004 NORM = PYTHAG(HR(I,I-1),HI(I,I-1)) 3005 YR = HR(I,I-1) / NORM 3006 YI = HI(I,I-1) / NORM 3007 HR(I,I-1) = NORM 3008 HI(I,I-1) = 0.0D0 3009C 3010 DO 155 J = I, IGH 3011 SI = YR * HI(I,J) - YI * HR(I,J) 3012 HR(I,J) = YR * HR(I,J) + YI * HI(I,J) 3013 HI(I,J) = SI 3014 155 CONTINUE 3015C 3016 DO 160 J = LOW, LL 3017 SI = YR * HI(J,I) + YI * HR(J,I) 3018 HR(J,I) = YR * HR(J,I) - YI * HI(J,I) 3019 HI(J,I) = SI 3020 160 CONTINUE 3021C 3022 170 CONTINUE 3023C .......... STORE ROOTS ISOLATED BY CBAL .......... 3024 180 DO 200 I = 1, N 3025 IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200 3026 WR(I) = HR(I,I) 3027 WI(I) = HI(I,I) 3028 200 CONTINUE 3029C 3030 EN = IGH 3031 TR = 0.0D0 3032 TI = 0.0D0 3033 ITN = 30*N 3034C .......... SEARCH FOR NEXT EIGENVALUE .......... 3035 220 IF (EN .LT. LOW) GO TO 1001 3036 ITS = 0 3037 ENM1 = EN - 1 3038C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT 3039C FOR L=EN STEP -1 UNTIL LOW D0 -- .......... 3040 240 DO 260 LL = LOW, EN 3041 L = EN + LOW - LL 3042 IF (L .EQ. LOW) GO TO 300 3043 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1)) 3044 X + DABS(HR(L,L)) + DABS(HI(L,L)) 3045 TST2 = TST1 + DABS(HR(L,L-1)) 3046 IF (TST2 .EQ. TST1) GO TO 300 3047 260 CONTINUE 3048C .......... FORM SHIFT .......... 3049 300 IF (L .EQ. EN) GO TO 660 3050 IF (ITN .EQ. 0) GO TO 1000 3051 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320 3052 SR = HR(EN,EN) 3053 SI = HI(EN,EN) 3054 XR = HR(ENM1,EN) * HR(EN,ENM1) 3055 XI = HI(ENM1,EN) * HR(EN,ENM1) 3056 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 340 3057 YR = (HR(ENM1,ENM1) - SR) / 2.0D0 3058 YI = (HI(ENM1,ENM1) - SI) / 2.0D0 3059 CALL CSROOT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI) 3060 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GO TO 310 3061 ZZR = -ZZR 3062 ZZI = -ZZI 3063 310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI) 3064 SR = SR - XR 3065 SI = SI - XI 3066 GO TO 340 3067C .......... FORM EXCEPTIONAL SHIFT .......... 3068 320 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2)) 3069 SI = 0.0D0 3070C 3071 340 DO 360 I = LOW, EN 3072 HR(I,I) = HR(I,I) - SR 3073 HI(I,I) = HI(I,I) - SI 3074 360 CONTINUE 3075C 3076 TR = TR + SR 3077 TI = TI + SI 3078 ITS = ITS + 1 3079 ITN = ITN - 1 3080C .......... REDUCE TO TRIANGLE (ROWS) .......... 3081 LP1 = L + 1 3082C 3083 DO 500 I = LP1, EN 3084 SR = HR(I,I-1) 3085 HR(I,I-1) = 0.0D0 3086 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR) 3087 XR = HR(I-1,I-1) / NORM 3088 WR(I-1) = XR 3089 XI = HI(I-1,I-1) / NORM 3090 WI(I-1) = XI 3091 HR(I-1,I-1) = NORM 3092 HI(I-1,I-1) = 0.0D0 3093 HI(I,I-1) = SR / NORM 3094C 3095 DO 490 J = I, EN 3096 YR = HR(I-1,J) 3097 YI = HI(I-1,J) 3098 ZZR = HR(I,J) 3099 ZZI = HI(I,J) 3100 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR 3101 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI 3102 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR 3103 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI 3104 490 CONTINUE 3105C 3106 500 CONTINUE 3107C 3108 SI = HI(EN,EN) 3109 IF (SI .EQ. 0.0D0) GO TO 540 3110 NORM = PYTHAG(HR(EN,EN),SI) 3111 SR = HR(EN,EN) / NORM 3112 SI = SI / NORM 3113 HR(EN,EN) = NORM 3114 HI(EN,EN) = 0.0D0 3115C .......... INVERSE OPERATION (COLUMNS) .......... 3116 540 DO 600 J = LP1, EN 3117 XR = WR(J-1) 3118 XI = WI(J-1) 3119C 3120 DO 580 I = L, J 3121 YR = HR(I,J-1) 3122 YI = 0.0D0 3123 ZZR = HR(I,J) 3124 ZZI = HI(I,J) 3125 IF (I .EQ. J) GO TO 560 3126 YI = HI(I,J-1) 3127 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI 3128 560 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR 3129 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR 3130 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI 3131 580 CONTINUE 3132C 3133 600 CONTINUE 3134C 3135 IF (SI .EQ. 0.0D0) GO TO 240 3136C 3137 DO 630 I = L, EN 3138 YR = HR(I,EN) 3139 YI = HI(I,EN) 3140 HR(I,EN) = SR * YR - SI * YI 3141 HI(I,EN) = SR * YI + SI * YR 3142 630 CONTINUE 3143C 3144 GO TO 240 3145C .......... A ROOT FOUND .......... 3146 660 WR(EN) = HR(EN,EN) + TR 3147 WI(EN) = HI(EN,EN) + TI 3148 EN = ENM1 3149 GO TO 220 3150C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT 3151C CONVERGED AFTER 30*N ITERATIONS .......... 3152 1000 IERR = EN 3153 1001 RETURN 3154 END 3155 SUBROUTINE COMQR2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR) 3156C 3157 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1, 3158 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR 3159 DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N), 3160 X ORTR(IGH),ORTI(IGH) 3161 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2, 3162 X PYTHAG 3163 integer*4 ii4 3164C 3165C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE 3166C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS 3167C AND WILKINSON. 3168C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). 3169C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS 3170C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM. 3171C 3172C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS 3173C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR 3174C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX 3175C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE 3176C THIS GENERAL MATRIX TO HESSENBERG FORM. 3177C 3178C ON INPUT 3179C 3180C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 3181C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 3182C DIMENSION STATEMENT. 3183C 3184C N IS THE ORDER OF THE MATRIX. 3185C 3186C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING 3187C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, 3188C SET LOW=1, IGH=N. 3189C 3190C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS- 3191C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED. 3192C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS 3193C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND 3194C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS. 3195C 3196C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, 3197C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. 3198C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER 3199C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE 3200C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF 3201C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE 3202C ARBITRARY. 3203C 3204C ON OUTPUT 3205C 3206C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI 3207C HAVE BEEN DESTROYED. 3208C 3209C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, 3210C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR 3211C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT 3212C FOR INDICES IERR+1,...,N. 3213C 3214C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, 3215C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS 3216C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF 3217C THE EIGENVECTORS HAS BEEN FOUND. 3218C 3219C IERR IS SET TO 3220C ZERO FOR NORMAL RETURN, 3221C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED 3222C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. 3223C 3224C CALLS CDIV FOR COMPLEX DIVISION. 3225C CALLS CSROOT FOR COMPLEX SQUARE ROOT. 3226C CALLS PYTHAG FOR DSQRT(A*A + B*B) . 3227C 3228C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 3229C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 3230C 3231C THIS VERSION DATED AUGUST 1983. 3232C 3233C ------------------------------------------------------------------ 3234C 3235 IERR = 0 3236C .......... INITIALIZE EIGENVECTOR MATRIX .......... 3237 DO 101 J = 1, N 3238C 3239 DO 100 I = 1, N 3240 ZR(I,J) = 0.0D0 3241 ZI(I,J) = 0.0D0 3242 100 CONTINUE 3243 ZR(J,J) = 1.0D0 3244 101 CONTINUE 3245C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS 3246C FROM THE INFORMATION LEFT BY CORTH .......... 3247 IEND = IGH - LOW - 1 3248 ii4=iend 3249 IF (ii4) 180, 150, 105 3250C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... 3251 105 DO 140 II = 1, IEND 3252 I = IGH - II 3253 IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GO TO 140 3254 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GO TO 140 3255C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH .......... 3256 NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I) 3257 IP1 = I + 1 3258C 3259 DO 110 K = IP1, IGH 3260 ORTR(K) = HR(K,I-1) 3261 ORTI(K) = HI(K,I-1) 3262 110 CONTINUE 3263C 3264 DO 130 J = I, IGH 3265 SR = 0.0D0 3266 SI = 0.0D0 3267C 3268 DO 115 K = I, IGH 3269 SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J) 3270 SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J) 3271 115 CONTINUE 3272C 3273 SR = SR / NORM 3274 SI = SI / NORM 3275C 3276 DO 120 K = I, IGH 3277 ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K) 3278 ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K) 3279 120 CONTINUE 3280C 3281 130 CONTINUE 3282C 3283 140 CONTINUE 3284C .......... CREATE REAL SUBDIAGONAL ELEMENTS .......... 3285 150 L = LOW + 1 3286C 3287 DO 170 I = L, IGH 3288 LL = MIN0(I+1,IGH) 3289 IF (HI(I,I-1) .EQ. 0.0D0) GO TO 170 3290 NORM = PYTHAG(HR(I,I-1),HI(I,I-1)) 3291 YR = HR(I,I-1) / NORM 3292 YI = HI(I,I-1) / NORM 3293 HR(I,I-1) = NORM 3294 HI(I,I-1) = 0.0D0 3295C 3296 DO 155 J = I, N 3297 SI = YR * HI(I,J) - YI * HR(I,J) 3298 HR(I,J) = YR * HR(I,J) + YI * HI(I,J) 3299 HI(I,J) = SI 3300 155 CONTINUE 3301C 3302 DO 160 J = 1, LL 3303 SI = YR * HI(J,I) + YI * HR(J,I) 3304 HR(J,I) = YR * HR(J,I) - YI * HI(J,I) 3305 HI(J,I) = SI 3306 160 CONTINUE 3307C 3308 DO 165 J = LOW, IGH 3309 SI = YR * ZI(J,I) + YI * ZR(J,I) 3310 ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I) 3311 ZI(J,I) = SI 3312 165 CONTINUE 3313C 3314 170 CONTINUE 3315C .......... STORE ROOTS ISOLATED BY CBAL .......... 3316 180 DO 200 I = 1, N 3317 IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200 3318 WR(I) = HR(I,I) 3319 WI(I) = HI(I,I) 3320 200 CONTINUE 3321C 3322 EN = IGH 3323 TR = 0.0D0 3324 TI = 0.0D0 3325 ITN = 30*N 3326C .......... SEARCH FOR NEXT EIGENVALUE .......... 3327 220 IF (EN .LT. LOW) GO TO 680 3328 ITS = 0 3329 ENM1 = EN - 1 3330C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT 3331C FOR L=EN STEP -1 UNTIL LOW DO -- .......... 3332 240 DO 260 LL = LOW, EN 3333 L = EN + LOW - LL 3334 IF (L .EQ. LOW) GO TO 300 3335 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1)) 3336 X + DABS(HR(L,L)) + DABS(HI(L,L)) 3337 TST2 = TST1 + DABS(HR(L,L-1)) 3338 IF (TST2 .EQ. TST1) GO TO 300 3339 260 CONTINUE 3340C .......... FORM SHIFT .......... 3341 300 IF (L .EQ. EN) GO TO 660 3342 IF (ITN .EQ. 0) GO TO 1000 3343 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320 3344 SR = HR(EN,EN) 3345 SI = HI(EN,EN) 3346 XR = HR(ENM1,EN) * HR(EN,ENM1) 3347 XI = HI(ENM1,EN) * HR(EN,ENM1) 3348 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 340 3349 YR = (HR(ENM1,ENM1) - SR) / 2.0D0 3350 YI = (HI(ENM1,ENM1) - SI) / 2.0D0 3351 CALL CSROOT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI) 3352 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GO TO 310 3353 ZZR = -ZZR 3354 ZZI = -ZZI 3355 310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI) 3356 SR = SR - XR 3357 SI = SI - XI 3358 GO TO 340 3359C .......... FORM EXCEPTIONAL SHIFT .......... 3360 320 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2)) 3361 SI = 0.0D0 3362C 3363 340 DO 360 I = LOW, EN 3364 HR(I,I) = HR(I,I) - SR 3365 HI(I,I) = HI(I,I) - SI 3366 360 CONTINUE 3367C 3368 TR = TR + SR 3369 TI = TI + SI 3370 ITS = ITS + 1 3371 ITN = ITN - 1 3372C .......... REDUCE TO TRIANGLE (ROWS) .......... 3373 LP1 = L + 1 3374C 3375 DO 500 I = LP1, EN 3376 SR = HR(I,I-1) 3377 HR(I,I-1) = 0.0D0 3378 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR) 3379 XR = HR(I-1,I-1) / NORM 3380 WR(I-1) = XR 3381 XI = HI(I-1,I-1) / NORM 3382 WI(I-1) = XI 3383 HR(I-1,I-1) = NORM 3384 HI(I-1,I-1) = 0.0D0 3385 HI(I,I-1) = SR / NORM 3386C 3387 DO 490 J = I, N 3388 YR = HR(I-1,J) 3389 YI = HI(I-1,J) 3390 ZZR = HR(I,J) 3391 ZZI = HI(I,J) 3392 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR 3393 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI 3394 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR 3395 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI 3396 490 CONTINUE 3397C 3398 500 CONTINUE 3399C 3400 SI = HI(EN,EN) 3401 IF (SI .EQ. 0.0D0) GO TO 540 3402 NORM = PYTHAG(HR(EN,EN),SI) 3403 SR = HR(EN,EN) / NORM 3404 SI = SI / NORM 3405 HR(EN,EN) = NORM 3406 HI(EN,EN) = 0.0D0 3407 IF (EN .EQ. N) GO TO 540 3408 IP1 = EN + 1 3409C 3410 DO 520 J = IP1, N 3411 YR = HR(EN,J) 3412 YI = HI(EN,J) 3413 HR(EN,J) = SR * YR + SI * YI 3414 HI(EN,J) = SR * YI - SI * YR 3415 520 CONTINUE 3416C .......... INVERSE OPERATION (COLUMNS) .......... 3417 540 DO 600 J = LP1, EN 3418 XR = WR(J-1) 3419 XI = WI(J-1) 3420C 3421 DO 580 I = 1, J 3422 YR = HR(I,J-1) 3423 YI = 0.0D0 3424 ZZR = HR(I,J) 3425 ZZI = HI(I,J) 3426 IF (I .EQ. J) GO TO 560 3427 YI = HI(I,J-1) 3428 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI 3429 560 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR 3430 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR 3431 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI 3432 580 CONTINUE 3433C 3434 DO 590 I = LOW, IGH 3435 YR = ZR(I,J-1) 3436 YI = ZI(I,J-1) 3437 ZZR = ZR(I,J) 3438 ZZI = ZI(I,J) 3439 ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR 3440 ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI 3441 ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR 3442 ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI 3443 590 CONTINUE 3444C 3445 600 CONTINUE 3446C 3447 IF (SI .EQ. 0.0D0) GO TO 240 3448C 3449 DO 630 I = 1, EN 3450 YR = HR(I,EN) 3451 YI = HI(I,EN) 3452 HR(I,EN) = SR * YR - SI * YI 3453 HI(I,EN) = SR * YI + SI * YR 3454 630 CONTINUE 3455C 3456 DO 640 I = LOW, IGH 3457 YR = ZR(I,EN) 3458 YI = ZI(I,EN) 3459 ZR(I,EN) = SR * YR - SI * YI 3460 ZI(I,EN) = SR * YI + SI * YR 3461 640 CONTINUE 3462C 3463 GO TO 240 3464C .......... A ROOT FOUND .......... 3465 660 HR(EN,EN) = HR(EN,EN) + TR 3466 WR(EN) = HR(EN,EN) 3467 HI(EN,EN) = HI(EN,EN) + TI 3468 WI(EN) = HI(EN,EN) 3469 EN = ENM1 3470 GO TO 220 3471C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND 3472C VECTORS OF UPPER TRIANGULAR FORM .......... 3473 680 NORM = 0.0D0 3474C 3475 DO 720 I = 1, N 3476C 3477 DO 720 J = I, N 3478 TR = DABS(HR(I,J)) + DABS(HI(I,J)) 3479 IF (TR .GT. NORM) NORM = TR 3480 720 CONTINUE 3481C 3482 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GO TO 1001 3483C .......... FOR EN=N STEP -1 UNTIL 2 DO -- .......... 3484 DO 800 NN = 2, N 3485 EN = N + 2 - NN 3486 XR = WR(EN) 3487 XI = WI(EN) 3488 HR(EN,EN) = 1.0D0 3489 HI(EN,EN) = 0.0D0 3490 ENM1 = EN - 1 3491C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... 3492 DO 780 II = 1, ENM1 3493 I = EN - II 3494 ZZR = 0.0D0 3495 ZZI = 0.0D0 3496 IP1 = I + 1 3497C 3498 DO 740 J = IP1, EN 3499 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN) 3500 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN) 3501 740 CONTINUE 3502C 3503 YR = XR - WR(I) 3504 YI = XI - WI(I) 3505 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GO TO 765 3506 TST1 = NORM 3507 YR = TST1 3508 760 YR = 0.01D0 * YR 3509 TST2 = NORM + YR 3510 IF (TST2 .GT. TST1) GO TO 760 3511 765 CONTINUE 3512 CALL CDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN)) 3513C .......... OVERFLOW CONTROL .......... 3514 TR = DABS(HR(I,EN)) + DABS(HI(I,EN)) 3515 IF (TR .EQ. 0.0D0) GO TO 780 3516 TST1 = TR 3517 TST2 = TST1 + 1.0D0/TST1 3518 IF (TST2 .GT. TST1) GO TO 780 3519 DO 770 J = I, EN 3520 HR(J,EN) = HR(J,EN)/TR 3521 HI(J,EN) = HI(J,EN)/TR 3522 770 CONTINUE 3523C 3524 780 CONTINUE 3525C 3526 800 CONTINUE 3527C .......... END BACKSUBSTITUTION .......... 3528 ENM1 = N - 1 3529C .......... VECTORS OF ISOLATED ROOTS .......... 3530 DO 840 I = 1, ENM1 3531 IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840 3532 IP1 = I + 1 3533C 3534 DO 820 J = IP1, N 3535 ZR(I,J) = HR(I,J) 3536 ZI(I,J) = HI(I,J) 3537 820 CONTINUE 3538C 3539 840 CONTINUE 3540C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE 3541C VECTORS OF ORIGINAL FULL MATRIX. 3542C FOR J=N STEP -1 UNTIL LOW+1 DO -- .......... 3543 DO 880 JJ = LOW, ENM1 3544 J = N + LOW - JJ 3545 M = MIN0(J,IGH) 3546C 3547 DO 880 I = LOW, IGH 3548 ZZR = 0.0D0 3549 ZZI = 0.0D0 3550C 3551 DO 860 K = LOW, M 3552 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J) 3553 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J) 3554 860 CONTINUE 3555C 3556 ZR(I,J) = ZZR 3557 ZI(I,J) = ZZI 3558 880 CONTINUE 3559C 3560 GO TO 1001 3561C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT 3562C CONVERGED AFTER 30*N ITERATIONS .......... 3563 1000 IERR = EN 3564 1001 RETURN 3565 END 3566 SUBROUTINE CORTB(NM,LOW,IGH,AR,AI,ORTR,ORTI,M,ZR,ZI) 3567C 3568 INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1 3569 DOUBLE PRECISION AR(NM,IGH),AI(NM,IGH),ORTR(IGH),ORTI(IGH), 3570 X ZR(NM,M),ZI(NM,M) 3571 DOUBLE PRECISION H,GI,GR 3572C 3573C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF 3574C THE ALGOL PROCEDURE ORTBAK, NUM. MATH. 12, 349-368(1968) 3575C BY MARTIN AND WILKINSON. 3576C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). 3577C 3578C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL 3579C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING 3580C UPPER HESSENBERG MATRIX DETERMINED BY CORTH. 3581C 3582C ON INPUT 3583C 3584C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 3585C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 3586C DIMENSION STATEMENT. 3587C 3588C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING 3589C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, 3590C SET LOW=1 AND IGH EQUAL TO THE ORDER OF THE MATRIX. 3591C 3592C AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY 3593C TRANSFORMATIONS USED IN THE REDUCTION BY CORTH 3594C IN THEIR STRICT LOWER TRIANGLES. 3595C 3596C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE 3597C TRANSFORMATIONS USED IN THE REDUCTION BY CORTH. 3598C ONLY ELEMENTS LOW THROUGH IGH ARE USED. 3599C 3600C M IS THE NUMBER OF COLUMNS OF ZR AND ZI TO BE BACK TRANSFORMED. 3601C 3602C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, 3603C RESPECTIVELY, OF THE EIGENVECTORS TO BE 3604C BACK TRANSFORMED IN THEIR FIRST M COLUMNS. 3605C 3606C ON OUTPUT 3607C 3608C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, 3609C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS 3610C IN THEIR FIRST M COLUMNS. 3611C 3612C ORTR AND ORTI HAVE BEEN ALTERED. 3613C 3614C NOTE THAT CORTB PRESERVES VECTOR EUCLIDEAN NORMS. 3615C 3616C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 3617C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 3618C 3619C THIS VERSION DATED AUGUST 1983. 3620C 3621C ------------------------------------------------------------------ 3622C 3623 IF (M .EQ. 0) GO TO 200 3624 LA = IGH - 1 3625 KP1 = LOW + 1 3626 IF (LA .LT. KP1) GO TO 200 3627C .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... 3628 DO 140 MM = KP1, LA 3629 MP = LOW + IGH - MM 3630 IF (AR(MP,MP-1) .EQ. 0.0D0 .AND. AI(MP,MP-1) .EQ. 0.0D0) 3631 X GO TO 140 3632C .......... H BELOW IS NEGATIVE OF H FORMED IN CORTH .......... 3633 H = AR(MP,MP-1) * ORTR(MP) + AI(MP,MP-1) * ORTI(MP) 3634 MP1 = MP + 1 3635C 3636 DO 100 I = MP1, IGH 3637 ORTR(I) = AR(I,MP-1) 3638 ORTI(I) = AI(I,MP-1) 3639 100 CONTINUE 3640C 3641 DO 130 J = 1, M 3642 GR = 0.0D0 3643 GI = 0.0D0 3644C 3645 DO 110 I = MP, IGH 3646 GR = GR + ORTR(I) * ZR(I,J) + ORTI(I) * ZI(I,J) 3647 GI = GI + ORTR(I) * ZI(I,J) - ORTI(I) * ZR(I,J) 3648 110 CONTINUE 3649C 3650 GR = GR / H 3651 GI = GI / H 3652C 3653 DO 120 I = MP, IGH 3654 ZR(I,J) = ZR(I,J) + GR * ORTR(I) - GI * ORTI(I) 3655 ZI(I,J) = ZI(I,J) + GR * ORTI(I) + GI * ORTR(I) 3656 120 CONTINUE 3657C 3658 130 CONTINUE 3659C 3660 140 CONTINUE 3661C 3662 200 RETURN 3663 END 3664 SUBROUTINE CORTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI) 3665C 3666 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW 3667 DOUBLE PRECISION AR(NM,N),AI(NM,N),ORTR(IGH),ORTI(IGH) 3668 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG 3669C 3670C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF 3671C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968) 3672C BY MARTIN AND WILKINSON. 3673C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). 3674C 3675C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE 3676C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS 3677C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY 3678C UNITARY SIMILARITY TRANSFORMATIONS. 3679C 3680C ON INPUT 3681C 3682C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 3683C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 3684C DIMENSION STATEMENT. 3685C 3686C N IS THE ORDER OF THE MATRIX. 3687C 3688C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING 3689C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, 3690C SET LOW=1, IGH=N. 3691C 3692C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, 3693C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX. 3694C 3695C ON OUTPUT 3696C 3697C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, 3698C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION 3699C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION 3700C IS STORED IN THE REMAINING TRIANGLES UNDER THE 3701C HESSENBERG MATRIX. 3702C 3703C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE 3704C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED. 3705C 3706C CALLS PYTHAG FOR DSQRT(A*A + B*B) . 3707C 3708C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 3709C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 3710C 3711C THIS VERSION DATED AUGUST 1983. 3712C 3713C ------------------------------------------------------------------ 3714C 3715 LA = IGH - 1 3716 KP1 = LOW + 1 3717 IF (LA .LT. KP1) GO TO 200 3718C 3719 DO 180 M = KP1, LA 3720 H = 0.0D0 3721 ORTR(M) = 0.0D0 3722 ORTI(M) = 0.0D0 3723 SCALE = 0.0D0 3724C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) .......... 3725 DO 90 I = M, IGH 3726 90 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1)) 3727C 3728 IF (SCALE .EQ. 0.0D0) GO TO 180 3729 MP = M + IGH 3730C .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... 3731 DO 100 II = M, IGH 3732 I = MP - II 3733 ORTR(I) = AR(I,M-1) / SCALE 3734 ORTI(I) = AI(I,M-1) / SCALE 3735 H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I) 3736 100 CONTINUE 3737C 3738 G = DSQRT(H) 3739 F = PYTHAG(ORTR(M),ORTI(M)) 3740 IF (F .EQ. 0.0D0) GO TO 103 3741 H = H + F * G 3742 G = G / F 3743 ORTR(M) = (1.0D0 + G) * ORTR(M) 3744 ORTI(M) = (1.0D0 + G) * ORTI(M) 3745 GO TO 105 3746C 3747 103 ORTR(M) = G 3748 AR(M,M-1) = SCALE 3749C .......... FORM (I-(U*UT)/H) * A .......... 3750 105 DO 130 J = M, N 3751 FR = 0.0D0 3752 FI = 0.0D0 3753C .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... 3754 DO 110 II = M, IGH 3755 I = MP - II 3756 FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J) 3757 FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J) 3758 110 CONTINUE 3759C 3760 FR = FR / H 3761 FI = FI / H 3762C 3763 DO 120 I = M, IGH 3764 AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I) 3765 AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I) 3766 120 CONTINUE 3767C 3768 130 CONTINUE 3769C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) .......... 3770 DO 160 I = 1, IGH 3771 FR = 0.0D0 3772 FI = 0.0D0 3773C .......... FOR J=IGH STEP -1 UNTIL M DO -- .......... 3774 DO 140 JJ = M, IGH 3775 J = MP - JJ 3776 FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J) 3777 FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J) 3778 140 CONTINUE 3779C 3780 FR = FR / H 3781 FI = FI / H 3782C 3783 DO 150 J = M, IGH 3784 AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J) 3785 AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J) 3786 150 CONTINUE 3787C 3788 160 CONTINUE 3789C 3790 ORTR(M) = SCALE * ORTR(M) 3791 ORTI(M) = SCALE * ORTI(M) 3792 AR(M,M-1) = -G * AR(M,M-1) 3793 AI(M,M-1) = -G * AI(M,M-1) 3794 180 CONTINUE 3795C 3796 200 RETURN 3797 END 3798 SUBROUTINE ELMBAK(NM,LOW,IGH,A,INT,M,Z) 3799C 3800 INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1 3801 DOUBLE PRECISION A(NM,IGH),Z(NM,M) 3802 DOUBLE PRECISION X 3803 INTEGER INT(IGH) 3804C 3805C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMBAK, 3806C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. 3807C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). 3808C 3809C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL GENERAL 3810C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING 3811C UPPER HESSENBERG MATRIX DETERMINED BY ELMHES. 3812C 3813C ON INPUT 3814C 3815C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 3816C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 3817C DIMENSION STATEMENT. 3818C 3819C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING 3820C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, 3821C SET LOW=1 AND IGH EQUAL TO THE ORDER OF THE MATRIX. 3822C 3823C A CONTAINS THE MULTIPLIERS WHICH WERE USED IN THE 3824C REDUCTION BY ELMHES IN ITS LOWER TRIANGLE 3825C BELOW THE SUBDIAGONAL. 3826C 3827C INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS 3828C INTERCHANGED IN THE REDUCTION BY ELMHES. 3829C ONLY ELEMENTS LOW THROUGH IGH ARE USED. 3830C 3831C M IS THE NUMBER OF COLUMNS OF Z TO BE BACK TRANSFORMED. 3832C 3833C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGEN- 3834C VECTORS TO BE BACK TRANSFORMED IN ITS FIRST M COLUMNS. 3835C 3836C ON OUTPUT 3837C 3838C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE 3839C TRANSFORMED EIGENVECTORS IN ITS FIRST M COLUMNS. 3840C 3841C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 3842C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 3843C 3844C THIS VERSION DATED AUGUST 1983. 3845C 3846C ------------------------------------------------------------------ 3847C 3848 IF (M .EQ. 0) GO TO 200 3849 LA = IGH - 1 3850 KP1 = LOW + 1 3851 IF (LA .LT. KP1) GO TO 200 3852C .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... 3853 DO 140 MM = KP1, LA 3854 MP = LOW + IGH - MM 3855 MP1 = MP + 1 3856C 3857 DO 110 I = MP1, IGH 3858 X = A(I,MP-1) 3859 IF (X .EQ. 0.0D0) GO TO 110 3860C 3861 DO 100 J = 1, M 3862 100 Z(I,J) = Z(I,J) + X * Z(MP,J) 3863C 3864 110 CONTINUE 3865C 3866 I = INT(MP) 3867 IF (I .EQ. MP) GO TO 140 3868C 3869 DO 130 J = 1, M 3870 X = Z(I,J) 3871 Z(I,J) = Z(MP,J) 3872 Z(MP,J) = X 3873 130 CONTINUE 3874C 3875 140 CONTINUE 3876C 3877 200 RETURN 3878 END 3879 SUBROUTINE ELMHES(NM,N,LOW,IGH,A,INT) 3880C 3881 INTEGER I,J,M,N,LA,NM,IGH,KP1,LOW,MM1,MP1 3882 DOUBLE PRECISION A(NM,N) 3883 DOUBLE PRECISION X,Y 3884 INTEGER INT(IGH) 3885C 3886C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMHES, 3887C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. 3888C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). 3889C 3890C GIVEN A REAL GENERAL MATRIX, THIS SUBROUTINE 3891C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS 3892C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY 3893C STABILIZED ELEMENTARY SIMILARITY TRANSFORMATIONS. 3894C 3895C ON INPUT 3896C 3897C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 3898C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 3899C DIMENSION STATEMENT. 3900C 3901C N IS THE ORDER OF THE MATRIX. 3902C 3903C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING 3904C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, 3905C SET LOW=1, IGH=N. 3906C 3907C A CONTAINS THE INPUT MATRIX. 3908C 3909C ON OUTPUT 3910C 3911C A CONTAINS THE HESSENBERG MATRIX. THE MULTIPLIERS 3912C WHICH WERE USED IN THE REDUCTION ARE STORED IN THE 3913C REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX. 3914C 3915C INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS 3916C INTERCHANGED IN THE REDUCTION. 3917C ONLY ELEMENTS LOW THROUGH IGH ARE USED. 3918C 3919C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 3920C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 3921C 3922C THIS VERSION DATED AUGUST 1983. 3923C 3924C ------------------------------------------------------------------ 3925C 3926 LA = IGH - 1 3927 KP1 = LOW + 1 3928 IF (LA .LT. KP1) GO TO 200 3929C 3930 DO 180 M = KP1, LA 3931 MM1 = M - 1 3932 X = 0.0D0 3933 I = M 3934C 3935 DO 100 J = M, IGH 3936 IF (DABS(A(J,MM1)) .LE. DABS(X)) GO TO 100 3937 X = A(J,MM1) 3938 I = J 3939 100 CONTINUE 3940C 3941 INT(M) = I 3942 IF (I .EQ. M) GO TO 130 3943C .......... INTERCHANGE ROWS AND COLUMNS OF A .......... 3944 DO 110 J = MM1, N 3945 Y = A(I,J) 3946 A(I,J) = A(M,J) 3947 A(M,J) = Y 3948 110 CONTINUE 3949C 3950 DO 120 J = 1, IGH 3951 Y = A(J,I) 3952 A(J,I) = A(J,M) 3953 A(J,M) = Y 3954 120 CONTINUE 3955C .......... END INTERCHANGE .......... 3956 130 IF (X .EQ. 0.0D0) GO TO 180 3957 MP1 = M + 1 3958C 3959 DO 160 I = MP1, IGH 3960 Y = A(I,MM1) 3961 IF (Y .EQ. 0.0D0) GO TO 160 3962 Y = Y / X 3963 A(I,MM1) = Y 3964C 3965 DO 140 J = M, N 3966 140 A(I,J) = A(I,J) - Y * A(M,J) 3967C 3968 DO 150 J = 1, IGH 3969 150 A(J,M) = A(J,M) + Y * A(J,I) 3970C 3971 160 CONTINUE 3972C 3973 180 CONTINUE 3974C 3975 200 RETURN 3976 END 3977 SUBROUTINE ELTRAN(NM,N,LOW,IGH,A,INT,Z) 3978C 3979 INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1 3980 DOUBLE PRECISION A(NM,IGH),Z(NM,N) 3981 INTEGER INT(IGH) 3982C 3983C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMTRANS, 3984C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. 3985C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). 3986C 3987C THIS SUBROUTINE ACCUMULATES THE STABILIZED ELEMENTARY 3988C SIMILARITY TRANSFORMATIONS USED IN THE REDUCTION OF A 3989C REAL GENERAL MATRIX TO UPPER HESSENBERG FORM BY ELMHES. 3990C 3991C ON INPUT 3992C 3993C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 3994C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 3995C DIMENSION STATEMENT. 3996C 3997C N IS THE ORDER OF THE MATRIX. 3998C 3999C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING 4000C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, 4001C SET LOW=1, IGH=N. 4002C 4003C A CONTAINS THE MULTIPLIERS WHICH WERE USED IN THE 4004C REDUCTION BY ELMHES IN ITS LOWER TRIANGLE 4005C BELOW THE SUBDIAGONAL. 4006C 4007C INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS 4008C INTERCHANGED IN THE REDUCTION BY ELMHES. 4009C ONLY ELEMENTS LOW THROUGH IGH ARE USED. 4010C 4011C ON OUTPUT 4012C 4013C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE 4014C REDUCTION BY ELMHES. 4015C 4016C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 4017C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 4018C 4019C THIS VERSION DATED AUGUST 1983. 4020C 4021C ------------------------------------------------------------------ 4022C 4023C .......... INITIALIZE Z TO IDENTITY MATRIX .......... 4024 DO 80 J = 1, N 4025C 4026 DO 60 I = 1, N 4027 60 Z(I,J) = 0.0D0 4028C 4029 Z(J,J) = 1.0D0 4030 80 CONTINUE 4031C 4032 KL = IGH - LOW - 1 4033 IF (KL .LT. 1) GO TO 200 4034C .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... 4035 DO 140 MM = 1, KL 4036 MP = IGH - MM 4037 MP1 = MP + 1 4038C 4039 DO 100 I = MP1, IGH 4040 100 Z(I,MP) = A(I,MP-1) 4041C 4042 I = INT(MP) 4043 IF (I .EQ. MP) GO TO 140 4044C 4045 DO 130 J = MP, IGH 4046 Z(MP,J) = Z(I,J) 4047 Z(I,J) = 0.0D0 4048 130 CONTINUE 4049C 4050 Z(I,MP) = 1.0D0 4051 140 CONTINUE 4052C 4053 200 RETURN 4054 END 4055 SUBROUTINE FIGI(NM,N,T,D,E,E2,IERR) 4056C 4057 INTEGER I,N,NM,IERR 4058 DOUBLE PRECISION T(NM,3),D(N),E(N),E2(N) 4059C 4060C GIVEN A NONSYMMETRIC TRIDIAGONAL MATRIX SUCH THAT THE PRODUCTS 4061C OF CORRESPONDING PAIRS OF OFF-DIAGONAL ELEMENTS ARE ALL 4062C NON-NEGATIVE, THIS SUBROUTINE REDUCES IT TO A SYMMETRIC 4063C TRIDIAGONAL MATRIX WITH THE SAME EIGENVALUES. IF, FURTHER, 4064C A ZERO PRODUCT ONLY OCCURS WHEN BOTH FACTORS ARE ZERO, 4065C THE REDUCED MATRIX IS SIMILAR TO THE ORIGINAL MATRIX. 4066C 4067C ON INPUT 4068C 4069C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 4070C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 4071C DIMENSION STATEMENT. 4072C 4073C N IS THE ORDER OF THE MATRIX. 4074C 4075C T CONTAINS THE INPUT MATRIX. ITS SUBDIAGONAL IS 4076C STORED IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN, 4077C ITS DIAGONAL IN THE N POSITIONS OF THE SECOND COLUMN, 4078C AND ITS SUPERDIAGONAL IN THE FIRST N-1 POSITIONS OF 4079C THE THIRD COLUMN. T(1,1) AND T(N,3) ARE ARBITRARY. 4080C 4081C ON OUTPUT 4082C 4083C T IS UNALTERED. 4084C 4085C D CONTAINS THE DIAGONAL ELEMENTS OF THE SYMMETRIC MATRIX. 4086C 4087C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE SYMMETRIC 4088C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS NOT SET. 4089C 4090C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. 4091C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. 4092C 4093C IERR IS SET TO 4094C ZERO FOR NORMAL RETURN, 4095C N+I IF T(I,1)*T(I-1,3) IS NEGATIVE, 4096C -(3*N+I) IF T(I,1)*T(I-1,3) IS ZERO WITH ONE FACTOR 4097C NON-ZERO. IN THIS CASE, THE EIGENVECTORS OF 4098C THE SYMMETRIC MATRIX ARE NOT SIMPLY RELATED 4099C TO THOSE OF T AND SHOULD NOT BE SOUGHT. 4100C 4101C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 4102C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 4103C 4104C THIS VERSION DATED AUGUST 1983. 4105C 4106C ------------------------------------------------------------------ 4107C 4108 IERR = 0 4109C 4110 DO 100 I = 1, N 4111 IF (I .EQ. 1) GO TO 90 4112 E2(I) = T(I,1) * T(I-1,3) 4113 IF (E2(I)) 1000, 60, 80 4114 60 IF (T(I,1) .EQ. 0.0D0 .AND. T(I-1,3) .EQ. 0.0D0) GO TO 80 4115C .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL 4116C ELEMENTS IS ZERO WITH ONE MEMBER NON-ZERO .......... 4117 IERR = -(3 * N + I) 4118 80 E(I) = DSQRT(E2(I)) 4119 90 D(I) = T(I,2) 4120 100 CONTINUE 4121C 4122 GO TO 1001 4123C .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL 4124C ELEMENTS IS NEGATIVE .......... 4125 1000 IERR = N + I 4126 1001 RETURN 4127 END 4128 SUBROUTINE FIGI2(NM,N,T,D,E,Z,IERR) 4129C 4130 INTEGER I,J,N,NM,IERR 4131 DOUBLE PRECISION T(NM,3),D(N),E(N),Z(NM,N) 4132 DOUBLE PRECISION H 4133C 4134C GIVEN A NONSYMMETRIC TRIDIAGONAL MATRIX SUCH THAT THE PRODUCTS 4135C OF CORRESPONDING PAIRS OF OFF-DIAGONAL ELEMENTS ARE ALL 4136C NON-NEGATIVE, AND ZERO ONLY WHEN BOTH FACTORS ARE ZERO, THIS 4137C SUBROUTINE REDUCES IT TO A SYMMETRIC TRIDIAGONAL MATRIX 4138C USING AND ACCUMULATING DIAGONAL SIMILARITY TRANSFORMATIONS. 4139C 4140C ON INPUT 4141C 4142C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 4143C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 4144C DIMENSION STATEMENT. 4145C 4146C N IS THE ORDER OF THE MATRIX. 4147C 4148C T CONTAINS THE INPUT MATRIX. ITS SUBDIAGONAL IS 4149C STORED IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN, 4150C ITS DIAGONAL IN THE N POSITIONS OF THE SECOND COLUMN, 4151C AND ITS SUPERDIAGONAL IN THE FIRST N-1 POSITIONS OF 4152C THE THIRD COLUMN. T(1,1) AND T(N,3) ARE ARBITRARY. 4153C 4154C ON OUTPUT 4155C 4156C T IS UNALTERED. 4157C 4158C D CONTAINS THE DIAGONAL ELEMENTS OF THE SYMMETRIC MATRIX. 4159C 4160C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE SYMMETRIC 4161C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS NOT SET. 4162C 4163C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN 4164C THE REDUCTION. 4165C 4166C IERR IS SET TO 4167C ZERO FOR NORMAL RETURN, 4168C N+I IF T(I,1)*T(I-1,3) IS NEGATIVE, 4169C 2*N+I IF T(I,1)*T(I-1,3) IS ZERO WITH 4170C ONE FACTOR NON-ZERO. 4171C 4172C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 4173C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 4174C 4175C THIS VERSION DATED AUGUST 1983. 4176C 4177C ------------------------------------------------------------------ 4178C 4179 IERR = 0 4180C 4181 DO 100 I = 1, N 4182C 4183 DO 50 J = 1, N 4184 50 Z(I,J) = 0.0D0 4185C 4186 IF (I .EQ. 1) GO TO 70 4187 H = T(I,1) * T(I-1,3) 4188 IF (H) 900, 60, 80 4189 60 IF (T(I,1) .NE. 0.0D0 .OR. T(I-1,3) .NE. 0.0D0) GO TO 1000 4190 E(I) = 0.0D0 4191 70 Z(I,I) = 1.0D0 4192 GO TO 90 4193 80 E(I) = DSQRT(H) 4194 Z(I,I) = Z(I-1,I-1) * E(I) / T(I-1,3) 4195 90 D(I) = T(I,2) 4196 100 CONTINUE 4197C 4198 GO TO 1001 4199C .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL 4200C ELEMENTS IS NEGATIVE .......... 4201 900 IERR = N + I 4202 GO TO 1001 4203C .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL 4204C ELEMENTS IS ZERO WITH ONE MEMBER NON-ZERO .......... 4205 1000 IERR = 2 * N + I 4206 1001 RETURN 4207 END 4208 SUBROUTINE HQR(NM,N,LOW,IGH,H,WR,WI,IERR) 4209C 4210 INTEGER I,J,K,L,M,N,EN,LL,MM,NA,NM,IGH,ITN,ITS,LOW,MP2,ENM2,IERR 4211 DOUBLE PRECISION H(NM,N),WR(N),WI(N) 4212 DOUBLE PRECISION P,Q,R,S,T,W,X,Y,ZZ,NORM,TST1,TST2 4213 LOGICAL NOTLAS 4214C 4215C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR, 4216C NUM. MATH. 14, 219-231(1970) BY MARTIN, PETERS, AND WILKINSON. 4217C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 359-371(1971). 4218C 4219C THIS SUBROUTINE FINDS THE EIGENVALUES OF A REAL 4220C UPPER HESSENBERG MATRIX BY THE QR METHOD. 4221C 4222C ON INPUT 4223C 4224C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 4225C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 4226C DIMENSION STATEMENT. 4227C 4228C N IS THE ORDER OF THE MATRIX. 4229C 4230C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING 4231C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, 4232C SET LOW=1, IGH=N. 4233C 4234C H CONTAINS THE UPPER HESSENBERG MATRIX. INFORMATION ABOUT 4235C THE TRANSFORMATIONS USED IN THE REDUCTION TO HESSENBERG 4236C FORM BY ELMHES OR ORTHES, IF PERFORMED, IS STORED 4237C IN THE REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX. 4238C 4239C ON OUTPUT 4240C 4241C H HAS BEEN DESTROYED. THEREFORE, IT MUST BE SAVED 4242C BEFORE CALLING HQR IF SUBSEQUENT CALCULATION AND 4243C BACK TRANSFORMATION OF EIGENVECTORS IS TO BE PERFORMED. 4244C 4245C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, 4246C RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES 4247C ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS 4248C OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE 4249C HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN 4250C ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT 4251C FOR INDICES IERR+1,...,N. 4252C 4253C IERR IS SET TO 4254C ZERO FOR NORMAL RETURN, 4255C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED 4256C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. 4257C 4258C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 4259C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 4260C 4261C THIS VERSION DATED AUGUST 1983. 4262C 4263C ------------------------------------------------------------------ 4264C 4265 IERR = 0 4266 NORM = 0.0D0 4267 K = 1 4268C .......... STORE ROOTS ISOLATED BY BALANC 4269C AND COMPUTE MATRIX NORM .......... 4270 DO 50 I = 1, N 4271C 4272 DO 40 J = K, N 4273 40 NORM = NORM + DABS(H(I,J)) 4274C 4275 K = I 4276 IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50 4277 WR(I) = H(I,I) 4278 WI(I) = 0.0D0 4279 50 CONTINUE 4280C 4281 EN = IGH 4282 T = 0.0D0 4283 ITN = 30*N 4284C .......... SEARCH FOR NEXT EIGENVALUES .......... 4285 60 IF (EN .LT. LOW) GO TO 1001 4286 ITS = 0 4287 NA = EN - 1 4288 ENM2 = NA - 1 4289C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT 4290C FOR L=EN STEP -1 UNTIL LOW DO -- .......... 4291 70 DO 80 LL = LOW, EN 4292 L = EN + LOW - LL 4293 IF (L .EQ. LOW) GO TO 100 4294 S = DABS(H(L-1,L-1)) + DABS(H(L,L)) 4295 IF (S .EQ. 0.0D0) S = NORM 4296 TST1 = S 4297 TST2 = TST1 + DABS(H(L,L-1)) 4298 IF (TST2 .EQ. TST1) GO TO 100 4299 80 CONTINUE 4300C .......... FORM SHIFT .......... 4301 100 X = H(EN,EN) 4302 IF (L .EQ. EN) GO TO 270 4303 Y = H(NA,NA) 4304 W = H(EN,NA) * H(NA,EN) 4305 IF (L .EQ. NA) GO TO 280 4306 IF (ITN .EQ. 0) GO TO 1000 4307 IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130 4308C .......... FORM EXCEPTIONAL SHIFT .......... 4309 T = T + X 4310C 4311 DO 120 I = LOW, EN 4312 120 H(I,I) = H(I,I) - X 4313C 4314 S = DABS(H(EN,NA)) + DABS(H(NA,ENM2)) 4315 X = 0.75D0 * S 4316 Y = X 4317 W = -0.4375D0 * S * S 4318 130 ITS = ITS + 1 4319 ITN = ITN - 1 4320C .......... LOOK FOR TWO CONSECUTIVE SMALL 4321C SUB-DIAGONAL ELEMENTS. 4322C FOR M=EN-2 STEP -1 UNTIL L DO -- .......... 4323 DO 140 MM = L, ENM2 4324 M = ENM2 + L - MM 4325 ZZ = H(M,M) 4326 R = X - ZZ 4327 S = Y - ZZ 4328 P = (R * S - W) / H(M+1,M) + H(M,M+1) 4329 Q = H(M+1,M+1) - ZZ - R - S 4330 R = H(M+2,M+1) 4331 S = DABS(P) + DABS(Q) + DABS(R) 4332 P = P / S 4333 Q = Q / S 4334 R = R / S 4335 IF (M .EQ. L) GO TO 150 4336 TST1 = DABS(P)*(DABS(H(M-1,M-1)) + DABS(ZZ) + DABS(H(M+1,M+1))) 4337 TST2 = TST1 + DABS(H(M,M-1))*(DABS(Q) + DABS(R)) 4338 IF (TST2 .EQ. TST1) GO TO 150 4339 140 CONTINUE 4340C 4341 150 MP2 = M + 2 4342C 4343 DO 160 I = MP2, EN 4344 H(I,I-2) = 0.0D0 4345 IF (I .EQ. MP2) GO TO 160 4346 H(I,I-3) = 0.0D0 4347 160 CONTINUE 4348C .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND 4349C COLUMNS M TO EN .......... 4350 DO 260 K = M, NA 4351 NOTLAS = K .NE. NA 4352 IF (K .EQ. M) GO TO 170 4353 P = H(K,K-1) 4354 Q = H(K+1,K-1) 4355 R = 0.0D0 4356 IF (NOTLAS) R = H(K+2,K-1) 4357 X = DABS(P) + DABS(Q) + DABS(R) 4358 IF (X .EQ. 0.0D0) GO TO 260 4359 P = P / X 4360 Q = Q / X 4361 R = R / X 4362 170 S = DSIGN(DSQRT(P*P+Q*Q+R*R),P) 4363 IF (K .EQ. M) GO TO 180 4364 H(K,K-1) = -S * X 4365 GO TO 190 4366 180 IF (L .NE. M) H(K,K-1) = -H(K,K-1) 4367 190 P = P + S 4368 X = P / S 4369 Y = Q / S 4370 ZZ = R / S 4371 Q = Q / P 4372 R = R / P 4373 IF (NOTLAS) GO TO 225 4374C .......... ROW MODIFICATION .......... 4375 DO 200 J = K, N 4376 P = H(K,J) + Q * H(K+1,J) 4377 H(K,J) = H(K,J) - P * X 4378 H(K+1,J) = H(K+1,J) - P * Y 4379 200 CONTINUE 4380C 4381 J = MIN0(EN,K+3) 4382C .......... COLUMN MODIFICATION .......... 4383 DO 210 I = 1, J 4384 P = X * H(I,K) + Y * H(I,K+1) 4385 H(I,K) = H(I,K) - P 4386 H(I,K+1) = H(I,K+1) - P * Q 4387 210 CONTINUE 4388 GO TO 255 4389 225 CONTINUE 4390C .......... ROW MODIFICATION .......... 4391 DO 230 J = K, N 4392 P = H(K,J) + Q * H(K+1,J) + R * H(K+2,J) 4393 H(K,J) = H(K,J) - P * X 4394 H(K+1,J) = H(K+1,J) - P * Y 4395 H(K+2,J) = H(K+2,J) - P * ZZ 4396 230 CONTINUE 4397C 4398 J = MIN0(EN,K+3) 4399C .......... COLUMN MODIFICATION .......... 4400 DO 240 I = 1, J 4401 P = X * H(I,K) + Y * H(I,K+1) + ZZ * H(I,K+2) 4402 H(I,K) = H(I,K) - P 4403 H(I,K+1) = H(I,K+1) - P * Q 4404 H(I,K+2) = H(I,K+2) - P * R 4405 240 CONTINUE 4406 255 CONTINUE 4407C 4408 260 CONTINUE 4409C 4410 GO TO 70 4411C .......... ONE ROOT FOUND .......... 4412 270 WR(EN) = X + T 4413 WI(EN) = 0.0D0 4414 EN = NA 4415 GO TO 60 4416C .......... TWO ROOTS FOUND .......... 4417 280 P = (Y - X) / 2.0D0 4418 Q = P * P + W 4419 ZZ = DSQRT(DABS(Q)) 4420 X = X + T 4421 IF (Q .LT. 0.0D0) GO TO 320 4422C .......... REAL PAIR .......... 4423 ZZ = P + DSIGN(ZZ,P) 4424 WR(NA) = X + ZZ 4425 WR(EN) = WR(NA) 4426 IF (ZZ .NE. 0.0D0) WR(EN) = X - W / ZZ 4427 WI(NA) = 0.0D0 4428 WI(EN) = 0.0D0 4429 GO TO 330 4430C .......... COMPLEX PAIR .......... 4431 320 WR(NA) = X + P 4432 WR(EN) = X + P 4433 WI(NA) = ZZ 4434 WI(EN) = -ZZ 4435 330 EN = ENM2 4436 GO TO 60 4437C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT 4438C CONVERGED AFTER 30*N ITERATIONS .......... 4439 1000 IERR = EN 4440 1001 RETURN 4441 END 4442 SUBROUTINE HQR2(NM,N,LOW,IGH,H,WR,WI,Z,IERR) 4443C 4444 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NA,NM,NN, 4445 X IGH,ITN,ITS,LOW,MP2,ENM2,IERR 4446 DOUBLE PRECISION H(NM,N),WR(N),WI(N),Z(NM,N) 4447 DOUBLE PRECISION P,Q,R,S,T,W,X,Y,RA,SA,VI,VR,ZZ,NORM,TST1,TST2 4448 LOGICAL NOTLAS 4449C 4450C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR2, 4451C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. 4452C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). 4453C 4454C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS 4455C OF A REAL UPPER HESSENBERG MATRIX BY THE QR METHOD. THE 4456C EIGENVECTORS OF A REAL GENERAL MATRIX CAN ALSO BE FOUND 4457C IF ELMHES AND ELTRAN OR ORTHES AND ORTRAN HAVE 4458C BEEN USED TO REDUCE THIS GENERAL MATRIX TO HESSENBERG FORM 4459C AND TO ACCUMULATE THE SIMILARITY TRANSFORMATIONS. 4460C 4461C ON INPUT 4462C 4463C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 4464C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 4465C DIMENSION STATEMENT. 4466C 4467C N IS THE ORDER OF THE MATRIX. 4468C 4469C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING 4470C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, 4471C SET LOW=1, IGH=N. 4472C 4473C H CONTAINS THE UPPER HESSENBERG MATRIX. 4474C 4475C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED BY ELTRAN 4476C AFTER THE REDUCTION BY ELMHES, OR BY ORTRAN AFTER THE 4477C REDUCTION BY ORTHES, IF PERFORMED. IF THE EIGENVECTORS 4478C OF THE HESSENBERG MATRIX ARE DESIRED, Z MUST CONTAIN THE 4479C IDENTITY MATRIX. 4480C 4481C ON OUTPUT 4482C 4483C H HAS BEEN DESTROYED. 4484C 4485C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, 4486C RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES 4487C ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS 4488C OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE 4489C HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN 4490C ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT 4491C FOR INDICES IERR+1,...,N. 4492C 4493C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS. 4494C IF THE I-TH EIGENVALUE IS REAL, THE I-TH COLUMN OF Z 4495C CONTAINS ITS EIGENVECTOR. IF THE I-TH EIGENVALUE IS COMPLEX 4496C WITH POSITIVE IMAGINARY PART, THE I-TH AND (I+1)-TH 4497C COLUMNS OF Z CONTAIN THE REAL AND IMAGINARY PARTS OF ITS 4498C EIGENVECTOR. THE EIGENVECTORS ARE UNNORMALIZED. IF AN 4499C ERROR EXIT IS MADE, NONE OF THE EIGENVECTORS HAS BEEN FOUND. 4500C 4501C IERR IS SET TO 4502C ZERO FOR NORMAL RETURN, 4503C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED 4504C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. 4505C 4506C CALLS CDIV FOR COMPLEX DIVISION. 4507C 4508C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 4509C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 4510C 4511C THIS VERSION DATED AUGUST 1983. 4512C 4513C ------------------------------------------------------------------ 4514C 4515 IERR = 0 4516 NORM = 0.0D0 4517 K = 1 4518C .......... STORE ROOTS ISOLATED BY BALANC 4519C AND COMPUTE MATRIX NORM .......... 4520 DO 50 I = 1, N 4521C 4522 DO 40 J = K, N 4523 40 NORM = NORM + DABS(H(I,J)) 4524C 4525 K = I 4526 IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50 4527 WR(I) = H(I,I) 4528 WI(I) = 0.0D0 4529 50 CONTINUE 4530C 4531 EN = IGH 4532 T = 0.0D0 4533 ITN = 30*N 4534C .......... SEARCH FOR NEXT EIGENVALUES .......... 4535 60 IF (EN .LT. LOW) GO TO 340 4536 ITS = 0 4537 NA = EN - 1 4538 ENM2 = NA - 1 4539C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT 4540C FOR L=EN STEP -1 UNTIL LOW DO -- .......... 4541 70 DO 80 LL = LOW, EN 4542 L = EN + LOW - LL 4543 IF (L .EQ. LOW) GO TO 100 4544 S = DABS(H(L-1,L-1)) + DABS(H(L,L)) 4545 IF (S .EQ. 0.0D0) S = NORM 4546 TST1 = S 4547 TST2 = TST1 + DABS(H(L,L-1)) 4548 IF (TST2 .EQ. TST1) GO TO 100 4549 80 CONTINUE 4550C .......... FORM SHIFT .......... 4551 100 X = H(EN,EN) 4552 IF (L .EQ. EN) GO TO 270 4553 Y = H(NA,NA) 4554 W = H(EN,NA) * H(NA,EN) 4555 IF (L .EQ. NA) GO TO 280 4556 IF (ITN .EQ. 0) GO TO 1000 4557 IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130 4558C .......... FORM EXCEPTIONAL SHIFT .......... 4559 T = T + X 4560C 4561 DO 120 I = LOW, EN 4562 120 H(I,I) = H(I,I) - X 4563C 4564 S = DABS(H(EN,NA)) + DABS(H(NA,ENM2)) 4565 X = 0.75D0 * S 4566 Y = X 4567 W = -0.4375D0 * S * S 4568 130 ITS = ITS + 1 4569 ITN = ITN - 1 4570C .......... LOOK FOR TWO CONSECUTIVE SMALL 4571C SUB-DIAGONAL ELEMENTS. 4572C FOR M=EN-2 STEP -1 UNTIL L DO -- .......... 4573 DO 140 MM = L, ENM2 4574 M = ENM2 + L - MM 4575 ZZ = H(M,M) 4576 R = X - ZZ 4577 S = Y - ZZ 4578 P = (R * S - W) / H(M+1,M) + H(M,M+1) 4579 Q = H(M+1,M+1) - ZZ - R - S 4580 R = H(M+2,M+1) 4581 S = DABS(P) + DABS(Q) + DABS(R) 4582 P = P / S 4583 Q = Q / S 4584 R = R / S 4585 IF (M .EQ. L) GO TO 150 4586 TST1 = DABS(P)*(DABS(H(M-1,M-1)) + DABS(ZZ) + DABS(H(M+1,M+1))) 4587 TST2 = TST1 + DABS(H(M,M-1))*(DABS(Q) + DABS(R)) 4588 IF (TST2 .EQ. TST1) GO TO 150 4589 140 CONTINUE 4590C 4591 150 MP2 = M + 2 4592C 4593 DO 160 I = MP2, EN 4594 H(I,I-2) = 0.0D0 4595 IF (I .EQ. MP2) GO TO 160 4596 H(I,I-3) = 0.0D0 4597 160 CONTINUE 4598C .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND 4599C COLUMNS M TO EN .......... 4600 DO 260 K = M, NA 4601 NOTLAS = K .NE. NA 4602 IF (K .EQ. M) GO TO 170 4603 P = H(K,K-1) 4604 Q = H(K+1,K-1) 4605 R = 0.0D0 4606 IF (NOTLAS) R = H(K+2,K-1) 4607 X = DABS(P) + DABS(Q) + DABS(R) 4608 IF (X .EQ. 0.0D0) GO TO 260 4609 P = P / X 4610 Q = Q / X 4611 R = R / X 4612 170 S = DSIGN(DSQRT(P*P+Q*Q+R*R),P) 4613 IF (K .EQ. M) GO TO 180 4614 H(K,K-1) = -S * X 4615 GO TO 190 4616 180 IF (L .NE. M) H(K,K-1) = -H(K,K-1) 4617 190 P = P + S 4618 X = P / S 4619 Y = Q / S 4620 ZZ = R / S 4621 Q = Q / P 4622 R = R / P 4623 IF (NOTLAS) GO TO 225 4624C .......... ROW MODIFICATION .......... 4625 DO 200 J = K, N 4626 P = H(K,J) + Q * H(K+1,J) 4627 H(K,J) = H(K,J) - P * X 4628 H(K+1,J) = H(K+1,J) - P * Y 4629 200 CONTINUE 4630C 4631 J = MIN0(EN,K+3) 4632C .......... COLUMN MODIFICATION .......... 4633 DO 210 I = 1, J 4634 P = X * H(I,K) + Y * H(I,K+1) 4635 H(I,K) = H(I,K) - P 4636 H(I,K+1) = H(I,K+1) - P * Q 4637 210 CONTINUE 4638C .......... ACCUMULATE TRANSFORMATIONS .......... 4639 DO 220 I = LOW, IGH 4640 P = X * Z(I,K) + Y * Z(I,K+1) 4641 Z(I,K) = Z(I,K) - P 4642 Z(I,K+1) = Z(I,K+1) - P * Q 4643 220 CONTINUE 4644 GO TO 255 4645 225 CONTINUE 4646C .......... ROW MODIFICATION .......... 4647 DO 230 J = K, N 4648 P = H(K,J) + Q * H(K+1,J) + R * H(K+2,J) 4649 H(K,J) = H(K,J) - P * X 4650 H(K+1,J) = H(K+1,J) - P * Y 4651 H(K+2,J) = H(K+2,J) - P * ZZ 4652 230 CONTINUE 4653C 4654 J = MIN0(EN,K+3) 4655C .......... COLUMN MODIFICATION .......... 4656 DO 240 I = 1, J 4657 P = X * H(I,K) + Y * H(I,K+1) + ZZ * H(I,K+2) 4658 H(I,K) = H(I,K) - P 4659 H(I,K+1) = H(I,K+1) - P * Q 4660 H(I,K+2) = H(I,K+2) - P * R 4661 240 CONTINUE 4662C .......... ACCUMULATE TRANSFORMATIONS .......... 4663 DO 250 I = LOW, IGH 4664 P = X * Z(I,K) + Y * Z(I,K+1) + ZZ * Z(I,K+2) 4665 Z(I,K) = Z(I,K) - P 4666 Z(I,K+1) = Z(I,K+1) - P * Q 4667 Z(I,K+2) = Z(I,K+2) - P * R 4668 250 CONTINUE 4669 255 CONTINUE 4670C 4671 260 CONTINUE 4672C 4673 GO TO 70 4674C .......... ONE ROOT FOUND .......... 4675 270 H(EN,EN) = X + T 4676 WR(EN) = H(EN,EN) 4677 WI(EN) = 0.0D0 4678 EN = NA 4679 GO TO 60 4680C .......... TWO ROOTS FOUND .......... 4681 280 P = (Y - X) / 2.0D0 4682 Q = P * P + W 4683 ZZ = DSQRT(DABS(Q)) 4684 H(EN,EN) = X + T 4685 X = H(EN,EN) 4686 H(NA,NA) = Y + T 4687 IF (Q .LT. 0.0D0) GO TO 320 4688C .......... REAL PAIR .......... 4689 ZZ = P + DSIGN(ZZ,P) 4690 WR(NA) = X + ZZ 4691 WR(EN) = WR(NA) 4692 IF (ZZ .NE. 0.0D0) WR(EN) = X - W / ZZ 4693 WI(NA) = 0.0D0 4694 WI(EN) = 0.0D0 4695 X = H(EN,NA) 4696 S = DABS(X) + DABS(ZZ) 4697 P = X / S 4698 Q = ZZ / S 4699 R = DSQRT(P*P+Q*Q) 4700 P = P / R 4701 Q = Q / R 4702C .......... ROW MODIFICATION .......... 4703 DO 290 J = NA, N 4704 ZZ = H(NA,J) 4705 H(NA,J) = Q * ZZ + P * H(EN,J) 4706 H(EN,J) = Q * H(EN,J) - P * ZZ 4707 290 CONTINUE 4708C .......... COLUMN MODIFICATION .......... 4709 DO 300 I = 1, EN 4710 ZZ = H(I,NA) 4711 H(I,NA) = Q * ZZ + P * H(I,EN) 4712 H(I,EN) = Q * H(I,EN) - P * ZZ 4713 300 CONTINUE 4714C .......... ACCUMULATE TRANSFORMATIONS .......... 4715 DO 310 I = LOW, IGH 4716 ZZ = Z(I,NA) 4717 Z(I,NA) = Q * ZZ + P * Z(I,EN) 4718 Z(I,EN) = Q * Z(I,EN) - P * ZZ 4719 310 CONTINUE 4720C 4721 GO TO 330 4722C .......... COMPLEX PAIR .......... 4723 320 WR(NA) = X + P 4724 WR(EN) = X + P 4725 WI(NA) = ZZ 4726 WI(EN) = -ZZ 4727 330 EN = ENM2 4728 GO TO 60 4729C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND 4730C VECTORS OF UPPER TRIANGULAR FORM .......... 4731 340 IF (NORM .EQ. 0.0D0) GO TO 1001 4732C .......... FOR EN=N STEP -1 UNTIL 1 DO -- .......... 4733 DO 800 NN = 1, N 4734 EN = N + 1 - NN 4735 P = WR(EN) 4736 Q = WI(EN) 4737 NA = EN - 1 4738 IF (Q) 710, 600, 800 4739C .......... REAL VECTOR .......... 4740 600 M = EN 4741 H(EN,EN) = 1.0D0 4742 IF (NA .EQ. 0) GO TO 800 4743C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... 4744 DO 700 II = 1, NA 4745 I = EN - II 4746 W = H(I,I) - P 4747 R = 0.0D0 4748C 4749 DO 610 J = M, EN 4750 610 R = R + H(I,J) * H(J,EN) 4751C 4752 IF (WI(I) .GE. 0.0D0) GO TO 630 4753 ZZ = W 4754 S = R 4755 GO TO 700 4756 630 M = I 4757 IF (WI(I) .NE. 0.0D0) GO TO 640 4758 T = W 4759 IF (T .NE. 0.0D0) GO TO 635 4760 TST1 = NORM 4761 T = TST1 4762 632 T = 0.01D0 * T 4763 TST2 = NORM + T 4764 IF (TST2 .GT. TST1) GO TO 632 4765 635 H(I,EN) = -R / T 4766 GO TO 680 4767C .......... SOLVE REAL EQUATIONS .......... 4768 640 X = H(I,I+1) 4769 Y = H(I+1,I) 4770 Q = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) 4771 T = (X * S - ZZ * R) / Q 4772 H(I,EN) = T 4773 IF (DABS(X) .LE. DABS(ZZ)) GO TO 650 4774 H(I+1,EN) = (-R - W * T) / X 4775 GO TO 680 4776 650 H(I+1,EN) = (-S - Y * T) / ZZ 4777C 4778C .......... OVERFLOW CONTROL .......... 4779 680 T = DABS(H(I,EN)) 4780 IF (T .EQ. 0.0D0) GO TO 700 4781 TST1 = T 4782 TST2 = TST1 + 1.0D0/TST1 4783 IF (TST2 .GT. TST1) GO TO 700 4784 DO 690 J = I, EN 4785 H(J,EN) = H(J,EN)/T 4786 690 CONTINUE 4787C 4788 700 CONTINUE 4789C .......... END REAL VECTOR .......... 4790 GO TO 800 4791C .......... COMPLEX VECTOR .......... 4792 710 M = NA 4793C .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT 4794C EIGENVECTOR MATRIX IS TRIANGULAR .......... 4795 IF (DABS(H(EN,NA)) .LE. DABS(H(NA,EN))) GO TO 720 4796 H(NA,NA) = Q / H(EN,NA) 4797 H(NA,EN) = -(H(EN,EN) - P) / H(EN,NA) 4798 GO TO 730 4799 720 CALL CDIV(0.0D0,-H(NA,EN),H(NA,NA)-P,Q,H(NA,NA),H(NA,EN)) 4800 730 H(EN,NA) = 0.0D0 4801 H(EN,EN) = 1.0D0 4802 ENM2 = NA - 1 4803 IF (ENM2 .EQ. 0) GO TO 800 4804C .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- .......... 4805 DO 795 II = 1, ENM2 4806 I = NA - II 4807 W = H(I,I) - P 4808 RA = 0.0D0 4809 SA = 0.0D0 4810C 4811 DO 760 J = M, EN 4812 RA = RA + H(I,J) * H(J,NA) 4813 SA = SA + H(I,J) * H(J,EN) 4814 760 CONTINUE 4815C 4816 IF (WI(I) .GE. 0.0D0) GO TO 770 4817 ZZ = W 4818 R = RA 4819 S = SA 4820 GO TO 795 4821 770 M = I 4822 IF (WI(I) .NE. 0.0D0) GO TO 780 4823 CALL CDIV(-RA,-SA,W,Q,H(I,NA),H(I,EN)) 4824 GO TO 790 4825C .......... SOLVE COMPLEX EQUATIONS .......... 4826 780 X = H(I,I+1) 4827 Y = H(I+1,I) 4828 VR = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) - Q * Q 4829 VI = (WR(I) - P) * 2.0D0 * Q 4830 IF (VR .NE. 0.0D0 .OR. VI .NE. 0.0D0) GO TO 784 4831 TST1 = NORM * (DABS(W) + DABS(Q) + DABS(X) 4832 X + DABS(Y) + DABS(ZZ)) 4833 VR = TST1 4834 783 VR = 0.01D0 * VR 4835 TST2 = TST1 + VR 4836 IF (TST2 .GT. TST1) GO TO 783 4837 784 CALL CDIV(X*R-ZZ*RA+Q*SA,X*S-ZZ*SA-Q*RA,VR,VI, 4838 X H(I,NA),H(I,EN)) 4839 IF (DABS(X) .LE. DABS(ZZ) + DABS(Q)) GO TO 785 4840 H(I+1,NA) = (-RA - W * H(I,NA) + Q * H(I,EN)) / X 4841 H(I+1,EN) = (-SA - W * H(I,EN) - Q * H(I,NA)) / X 4842 GO TO 790 4843 785 CALL CDIV(-R-Y*H(I,NA),-S-Y*H(I,EN),ZZ,Q, 4844 X H(I+1,NA),H(I+1,EN)) 4845C 4846C .......... OVERFLOW CONTROL .......... 4847 790 T = DMAX1(DABS(H(I,NA)), DABS(H(I,EN))) 4848 IF (T .EQ. 0.0D0) GO TO 795 4849 TST1 = T 4850 TST2 = TST1 + 1.0D0/TST1 4851 IF (TST2 .GT. TST1) GO TO 795 4852 DO 792 J = I, EN 4853 H(J,NA) = H(J,NA)/T 4854 H(J,EN) = H(J,EN)/T 4855 792 CONTINUE 4856C 4857 795 CONTINUE 4858C .......... END COMPLEX VECTOR .......... 4859 800 CONTINUE 4860C .......... END BACK SUBSTITUTION. 4861C VECTORS OF ISOLATED ROOTS .......... 4862 DO 840 I = 1, N 4863 IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840 4864C 4865 DO 820 J = I, N 4866 820 Z(I,J) = H(I,J) 4867C 4868 840 CONTINUE 4869C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE 4870C VECTORS OF ORIGINAL FULL MATRIX. 4871C FOR J=N STEP -1 UNTIL LOW DO -- .......... 4872 DO 880 JJ = LOW, N 4873 J = N + LOW - JJ 4874 M = MIN0(J,IGH) 4875C 4876 DO 880 I = LOW, IGH 4877 ZZ = 0.0D0 4878C 4879 DO 860 K = LOW, M 4880 860 ZZ = ZZ + Z(I,K) * H(K,J) 4881C 4882 Z(I,J) = ZZ 4883 880 CONTINUE 4884C 4885 GO TO 1001 4886C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT 4887C CONVERGED AFTER 30*N ITERATIONS .......... 4888 1000 IERR = EN 4889 1001 RETURN 4890 END 4891 SUBROUTINE HTRIB3(NM,N,A,TAU,M,ZR,ZI) 4892C 4893 INTEGER I,J,K,L,M,N,NM 4894 DOUBLE PRECISION A(NM,N),TAU(2,N),ZR(NM,M),ZI(NM,M) 4895 DOUBLE PRECISION H,S,SI 4896C 4897C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF 4898C THE ALGOL PROCEDURE TRBAK3, NUM. MATH. 11, 181-195(1968) 4899C BY MARTIN, REINSCH, AND WILKINSON. 4900C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). 4901C 4902C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX HERMITIAN 4903C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING 4904C REAL SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY HTRID3. 4905C 4906C ON INPUT 4907C 4908C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 4909C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 4910C DIMENSION STATEMENT. 4911C 4912C N IS THE ORDER OF THE MATRIX. 4913C 4914C A CONTAINS INFORMATION ABOUT THE UNITARY TRANSFORMATIONS 4915C USED IN THE REDUCTION BY HTRID3. 4916C 4917C TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. 4918C 4919C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. 4920C 4921C ZR CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED 4922C IN ITS FIRST M COLUMNS. 4923C 4924C ON OUTPUT 4925C 4926C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, 4927C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS 4928C IN THEIR FIRST M COLUMNS. 4929C 4930C NOTE THAT THE LAST COMPONENT OF EACH RETURNED VECTOR 4931C IS REAL AND THAT VECTOR EUCLIDEAN NORMS ARE PRESERVED. 4932C 4933C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 4934C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 4935C 4936C THIS VERSION DATED AUGUST 1983. 4937C 4938C ------------------------------------------------------------------ 4939C 4940 IF (M .EQ. 0) GO TO 200 4941C .......... TRANSFORM THE EIGENVECTORS OF THE REAL SYMMETRIC 4942C TRIDIAGONAL MATRIX TO THOSE OF THE HERMITIAN 4943C TRIDIAGONAL MATRIX. .......... 4944 DO 50 K = 1, N 4945C 4946 DO 50 J = 1, M 4947 ZI(K,J) = -ZR(K,J) * TAU(2,K) 4948 ZR(K,J) = ZR(K,J) * TAU(1,K) 4949 50 CONTINUE 4950C 4951 IF (N .EQ. 1) GO TO 200 4952C .......... RECOVER AND APPLY THE HOUSEHOLDER MATRICES .......... 4953 DO 140 I = 2, N 4954 L = I - 1 4955 H = A(I,I) 4956 IF (H .EQ. 0.0D0) GO TO 140 4957C 4958 DO 130 J = 1, M 4959 S = 0.0D0 4960 SI = 0.0D0 4961C 4962 DO 110 K = 1, L 4963 S = S + A(I,K) * ZR(K,J) - A(K,I) * ZI(K,J) 4964 SI = SI + A(I,K) * ZI(K,J) + A(K,I) * ZR(K,J) 4965 110 CONTINUE 4966C .......... DOUBLE DIVISIONS AVOID POSSIBLE UNDERFLOW .......... 4967 S = (S / H) / H 4968 SI = (SI / H) / H 4969C 4970 DO 120 K = 1, L 4971 ZR(K,J) = ZR(K,J) - S * A(I,K) - SI * A(K,I) 4972 ZI(K,J) = ZI(K,J) - SI * A(I,K) + S * A(K,I) 4973 120 CONTINUE 4974C 4975 130 CONTINUE 4976C 4977 140 CONTINUE 4978C 4979 200 RETURN 4980 END 4981 SUBROUTINE HTRIBK(NM,N,AR,AI,TAU,M,ZR,ZI) 4982C 4983 INTEGER I,J,K,L,M,N,NM 4984 DOUBLE PRECISION AR(NM,N),AI(NM,N),TAU(2,N),ZR(NM,M),ZI(NM,M) 4985 DOUBLE PRECISION H,S,SI 4986C 4987C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF 4988C THE ALGOL PROCEDURE TRBAK1, NUM. MATH. 11, 181-195(1968) 4989C BY MARTIN, REINSCH, AND WILKINSON. 4990C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). 4991C 4992C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX HERMITIAN 4993C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING 4994C REAL SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY HTRIDI. 4995C 4996C ON INPUT 4997C 4998C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 4999C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 5000C DIMENSION STATEMENT. 5001C 5002C N IS THE ORDER OF THE MATRIX. 5003C 5004C AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY TRANS- 5005C FORMATIONS USED IN THE REDUCTION BY HTRIDI IN THEIR 5006C FULL LOWER TRIANGLES EXCEPT FOR THE DIAGONAL OF AR. 5007C 5008C TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. 5009C 5010C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. 5011C 5012C ZR CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED 5013C IN ITS FIRST M COLUMNS. 5014C 5015C ON OUTPUT 5016C 5017C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, 5018C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS 5019C IN THEIR FIRST M COLUMNS. 5020C 5021C NOTE THAT THE LAST COMPONENT OF EACH RETURNED VECTOR 5022C IS REAL AND THAT VECTOR EUCLIDEAN NORMS ARE PRESERVED. 5023C 5024C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 5025C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 5026C 5027C THIS VERSION DATED AUGUST 1983. 5028C 5029C ------------------------------------------------------------------ 5030C 5031 IF (M .EQ. 0) GO TO 200 5032C .......... TRANSFORM THE EIGENVECTORS OF THE REAL SYMMETRIC 5033C TRIDIAGONAL MATRIX TO THOSE OF THE HERMITIAN 5034C TRIDIAGONAL MATRIX. .......... 5035 DO 50 K = 1, N 5036C 5037 DO 50 J = 1, M 5038 ZI(K,J) = -ZR(K,J) * TAU(2,K) 5039 ZR(K,J) = ZR(K,J) * TAU(1,K) 5040 50 CONTINUE 5041C 5042 IF (N .EQ. 1) GO TO 200 5043C .......... RECOVER AND APPLY THE HOUSEHOLDER MATRICES .......... 5044 DO 140 I = 2, N 5045 L = I - 1 5046 H = AI(I,I) 5047 IF (H .EQ. 0.0D0) GO TO 140 5048C 5049 DO 130 J = 1, M 5050 S = 0.0D0 5051 SI = 0.0D0 5052C 5053 DO 110 K = 1, L 5054 S = S + AR(I,K) * ZR(K,J) - AI(I,K) * ZI(K,J) 5055 SI = SI + AR(I,K) * ZI(K,J) + AI(I,K) * ZR(K,J) 5056 110 CONTINUE 5057C .......... DOUBLE DIVISIONS AVOID POSSIBLE UNDERFLOW .......... 5058 S = (S / H) / H 5059 SI = (SI / H) / H 5060C 5061 DO 120 K = 1, L 5062 ZR(K,J) = ZR(K,J) - S * AR(I,K) - SI * AI(I,K) 5063 ZI(K,J) = ZI(K,J) - SI * AR(I,K) + S * AI(I,K) 5064 120 CONTINUE 5065C 5066 130 CONTINUE 5067C 5068 140 CONTINUE 5069C 5070 200 RETURN 5071 END 5072 SUBROUTINE HTRID3(NM,N,A,D,E,E2,TAU) 5073C 5074 INTEGER I,J,K,L,N,II,NM,JM1,JP1 5075 DOUBLE PRECISION A(NM,N),D(N),E(N),E2(N),TAU(2,N) 5076 DOUBLE PRECISION F,G,H,FI,GI,HH,SI,SCALE,PYTHAG 5077C 5078C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF 5079C THE ALGOL PROCEDURE TRED3L, NUM. MATH. 11, 181-195(1968) 5080C BY MARTIN, REINSCH, AND WILKINSON. 5081C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). 5082C 5083C THIS SUBROUTINE REDUCES A COMPLEX HERMITIAN MATRIX, STORED AS 5084C A SINGLE SQUARE ARRAY, TO A REAL SYMMETRIC TRIDIAGONAL MATRIX 5085C USING UNITARY SIMILARITY TRANSFORMATIONS. 5086C 5087C ON INPUT 5088C 5089C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 5090C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 5091C DIMENSION STATEMENT. 5092C 5093C N IS THE ORDER OF THE MATRIX. 5094C 5095C A CONTAINS THE LOWER TRIANGLE OF THE COMPLEX HERMITIAN INPUT 5096C MATRIX. THE REAL PARTS OF THE MATRIX ELEMENTS ARE STORED 5097C IN THE FULL LOWER TRIANGLE OF A, AND THE IMAGINARY PARTS 5098C ARE STORED IN THE TRANSPOSED POSITIONS OF THE STRICT UPPER 5099C TRIANGLE OF A. NO STORAGE IS REQUIRED FOR THE ZERO 5100C IMAGINARY PARTS OF THE DIAGONAL ELEMENTS. 5101C 5102C ON OUTPUT 5103C 5104C A CONTAINS INFORMATION ABOUT THE UNITARY TRANSFORMATIONS 5105C USED IN THE REDUCTION. 5106C 5107C D CONTAINS THE DIAGONAL ELEMENTS OF THE THE TRIDIAGONAL MATRIX. 5108C 5109C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL 5110C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. 5111C 5112C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. 5113C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. 5114C 5115C TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. 5116C 5117C CALLS PYTHAG FOR DSQRT(A*A + B*B) . 5118C 5119C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 5120C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 5121C 5122C THIS VERSION DATED AUGUST 1983. 5123C 5124C ------------------------------------------------------------------ 5125C 5126 TAU(1,N) = 1.0D0 5127 TAU(2,N) = 0.0D0 5128C .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... 5129 DO 300 II = 1, N 5130 I = N + 1 - II 5131 L = I - 1 5132 H = 0.0D0 5133 SCALE = 0.0D0 5134 IF (L .LT. 1) GO TO 130 5135C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... 5136 DO 120 K = 1, L 5137 120 SCALE = SCALE + DABS(A(I,K)) + DABS(A(K,I)) 5138C 5139 IF (SCALE .NE. 0.0D0) GO TO 140 5140 TAU(1,L) = 1.0D0 5141 TAU(2,L) = 0.0D0 5142 130 E(I) = 0.0D0 5143 E2(I) = 0.0D0 5144 GO TO 290 5145C 5146 140 DO 150 K = 1, L 5147 A(I,K) = A(I,K) / SCALE 5148 A(K,I) = A(K,I) / SCALE 5149 H = H + A(I,K) * A(I,K) + A(K,I) * A(K,I) 5150 150 CONTINUE 5151C 5152 E2(I) = SCALE * SCALE * H 5153 G = DSQRT(H) 5154 E(I) = SCALE * G 5155 F = PYTHAG(A(I,L),A(L,I)) 5156C .......... FORM NEXT DIAGONAL ELEMENT OF MATRIX T .......... 5157 IF (F .EQ. 0.0D0) GO TO 160 5158 TAU(1,L) = (A(L,I) * TAU(2,I) - A(I,L) * TAU(1,I)) / F 5159 SI = (A(I,L) * TAU(2,I) + A(L,I) * TAU(1,I)) / F 5160 H = H + F * G 5161 G = 1.0D0 + G / F 5162 A(I,L) = G * A(I,L) 5163 A(L,I) = G * A(L,I) 5164 IF (L .EQ. 1) GO TO 270 5165 GO TO 170 5166 160 TAU(1,L) = -TAU(1,I) 5167 SI = TAU(2,I) 5168 A(I,L) = G 5169 170 F = 0.0D0 5170C 5171 DO 240 J = 1, L 5172 G = 0.0D0 5173 GI = 0.0D0 5174 IF (J .EQ. 1) GO TO 190 5175 JM1 = J - 1 5176C .......... FORM ELEMENT OF A*U .......... 5177 DO 180 K = 1, JM1 5178 G = G + A(J,K) * A(I,K) + A(K,J) * A(K,I) 5179 GI = GI - A(J,K) * A(K,I) + A(K,J) * A(I,K) 5180 180 CONTINUE 5181C 5182 190 G = G + A(J,J) * A(I,J) 5183 GI = GI - A(J,J) * A(J,I) 5184 JP1 = J + 1 5185 IF (L .LT. JP1) GO TO 220 5186C 5187 DO 200 K = JP1, L 5188 G = G + A(K,J) * A(I,K) - A(J,K) * A(K,I) 5189 GI = GI - A(K,J) * A(K,I) - A(J,K) * A(I,K) 5190 200 CONTINUE 5191C .......... FORM ELEMENT OF P .......... 5192 220 E(J) = G / H 5193 TAU(2,J) = GI / H 5194 F = F + E(J) * A(I,J) - TAU(2,J) * A(J,I) 5195 240 CONTINUE 5196C 5197 HH = F / (H + H) 5198C .......... FORM REDUCED A .......... 5199 DO 260 J = 1, L 5200 F = A(I,J) 5201 G = E(J) - HH * F 5202 E(J) = G 5203 FI = -A(J,I) 5204 GI = TAU(2,J) - HH * FI 5205 TAU(2,J) = -GI 5206 A(J,J) = A(J,J) - 2.0D0 * (F * G + FI * GI) 5207 IF (J .EQ. 1) GO TO 260 5208 JM1 = J - 1 5209C 5210 DO 250 K = 1, JM1 5211 A(J,K) = A(J,K) - F * E(K) - G * A(I,K) 5212 X + FI * TAU(2,K) + GI * A(K,I) 5213 A(K,J) = A(K,J) - F * TAU(2,K) - G * A(K,I) 5214 X - FI * E(K) - GI * A(I,K) 5215 250 CONTINUE 5216C 5217 260 CONTINUE 5218C 5219 270 DO 280 K = 1, L 5220 A(I,K) = SCALE * A(I,K) 5221 A(K,I) = SCALE * A(K,I) 5222 280 CONTINUE 5223C 5224 TAU(2,L) = -SI 5225 290 D(I) = A(I,I) 5226 A(I,I) = SCALE * DSQRT(H) 5227 300 CONTINUE 5228C 5229 RETURN 5230 END 5231 SUBROUTINE HTRIDI(NM,N,AR,AI,D,E,E2,TAU) 5232C 5233 INTEGER I,J,K,L,N,II,NM,JP1 5234 DOUBLE PRECISION AR(NM,N),AI(NM,N),D(N),E(N),E2(N),TAU(2,N) 5235 DOUBLE PRECISION F,G,H,FI,GI,HH,SI,SCALE,PYTHAG 5236C 5237C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF 5238C THE ALGOL PROCEDURE TRED1, NUM. MATH. 11, 181-195(1968) 5239C BY MARTIN, REINSCH, AND WILKINSON. 5240C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). 5241C 5242C THIS SUBROUTINE REDUCES A COMPLEX HERMITIAN MATRIX 5243C TO A REAL SYMMETRIC TRIDIAGONAL MATRIX USING 5244C UNITARY SIMILARITY TRANSFORMATIONS. 5245C 5246C ON INPUT 5247C 5248C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 5249C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 5250C DIMENSION STATEMENT. 5251C 5252C N IS THE ORDER OF THE MATRIX. 5253C 5254C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, 5255C RESPECTIVELY, OF THE COMPLEX HERMITIAN INPUT MATRIX. 5256C ONLY THE LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED. 5257C 5258C ON OUTPUT 5259C 5260C AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY TRANS- 5261C FORMATIONS USED IN THE REDUCTION IN THEIR FULL LOWER 5262C TRIANGLES. THEIR STRICT UPPER TRIANGLES AND THE 5263C DIAGONAL OF AR ARE UNALTERED. 5264C 5265C D CONTAINS THE DIAGONAL ELEMENTS OF THE THE TRIDIAGONAL MATRIX. 5266C 5267C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL 5268C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. 5269C 5270C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. 5271C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. 5272C 5273C TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. 5274C 5275C CALLS PYTHAG FOR DSQRT(A*A + B*B) . 5276C 5277C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 5278C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 5279C 5280C THIS VERSION DATED AUGUST 1983. 5281C 5282C ------------------------------------------------------------------ 5283C 5284 TAU(1,N) = 1.0D0 5285 TAU(2,N) = 0.0D0 5286C 5287 DO 100 I = 1, N 5288 100 D(I) = AR(I,I) 5289C .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... 5290 DO 300 II = 1, N 5291 I = N + 1 - II 5292 L = I - 1 5293 H = 0.0D0 5294 SCALE = 0.0D0 5295 IF (L .LT. 1) GO TO 130 5296C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... 5297 DO 120 K = 1, L 5298 120 SCALE = SCALE + DABS(AR(I,K)) + DABS(AI(I,K)) 5299C 5300 IF (SCALE .NE. 0.0D0) GO TO 140 5301 TAU(1,L) = 1.0D0 5302 TAU(2,L) = 0.0D0 5303 130 E(I) = 0.0D0 5304 E2(I) = 0.0D0 5305 GO TO 290 5306C 5307 140 DO 150 K = 1, L 5308 AR(I,K) = AR(I,K) / SCALE 5309 AI(I,K) = AI(I,K) / SCALE 5310 H = H + AR(I,K) * AR(I,K) + AI(I,K) * AI(I,K) 5311 150 CONTINUE 5312C 5313 E2(I) = SCALE * SCALE * H 5314 G = DSQRT(H) 5315 E(I) = SCALE * G 5316 F = PYTHAG(AR(I,L),AI(I,L)) 5317C .......... FORM NEXT DIAGONAL ELEMENT OF MATRIX T .......... 5318 IF (F .EQ. 0.0D0) GO TO 160 5319 TAU(1,L) = (AI(I,L) * TAU(2,I) - AR(I,L) * TAU(1,I)) / F 5320 SI = (AR(I,L) * TAU(2,I) + AI(I,L) * TAU(1,I)) / F 5321 H = H + F * G 5322 G = 1.0D0 + G / F 5323 AR(I,L) = G * AR(I,L) 5324 AI(I,L) = G * AI(I,L) 5325 IF (L .EQ. 1) GO TO 270 5326 GO TO 170 5327 160 TAU(1,L) = -TAU(1,I) 5328 SI = TAU(2,I) 5329 AR(I,L) = G 5330 170 F = 0.0D0 5331C 5332 DO 240 J = 1, L 5333 G = 0.0D0 5334 GI = 0.0D0 5335C .......... FORM ELEMENT OF A*U .......... 5336 DO 180 K = 1, J 5337 G = G + AR(J,K) * AR(I,K) + AI(J,K) * AI(I,K) 5338 GI = GI - AR(J,K) * AI(I,K) + AI(J,K) * AR(I,K) 5339 180 CONTINUE 5340C 5341 JP1 = J + 1 5342 IF (L .LT. JP1) GO TO 220 5343C 5344 DO 200 K = JP1, L 5345 G = G + AR(K,J) * AR(I,K) - AI(K,J) * AI(I,K) 5346 GI = GI - AR(K,J) * AI(I,K) - AI(K,J) * AR(I,K) 5347 200 CONTINUE 5348C .......... FORM ELEMENT OF P .......... 5349 220 E(J) = G / H 5350 TAU(2,J) = GI / H 5351 F = F + E(J) * AR(I,J) - TAU(2,J) * AI(I,J) 5352 240 CONTINUE 5353C 5354 HH = F / (H + H) 5355C .......... FORM REDUCED A .......... 5356 DO 260 J = 1, L 5357 F = AR(I,J) 5358 G = E(J) - HH * F 5359 E(J) = G 5360 FI = -AI(I,J) 5361 GI = TAU(2,J) - HH * FI 5362 TAU(2,J) = -GI 5363C 5364 DO 260 K = 1, J 5365 AR(J,K) = AR(J,K) - F * E(K) - G * AR(I,K) 5366 X + FI * TAU(2,K) + GI * AI(I,K) 5367 AI(J,K) = AI(J,K) - F * TAU(2,K) - G * AI(I,K) 5368 X - FI * E(K) - GI * AR(I,K) 5369 260 CONTINUE 5370C 5371 270 DO 280 K = 1, L 5372 AR(I,K) = SCALE * AR(I,K) 5373 AI(I,K) = SCALE * AI(I,K) 5374 280 CONTINUE 5375C 5376 TAU(2,L) = -SI 5377 290 HH = D(I) 5378 D(I) = AR(I,I) 5379 AR(I,I) = HH 5380 AI(I,I) = SCALE * DSQRT(H) 5381 300 CONTINUE 5382C 5383 RETURN 5384 END 5385 SUBROUTINE IMTQL1(N,D,E,IERR) 5386C 5387 INTEGER I,J,L,M,N,II,MML,IERR 5388 DOUBLE PRECISION D(N),E(N) 5389 DOUBLE PRECISION B,C,F,G,P,R,S,TST1,TST2,PYTHAG 5390C 5391C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE IMTQL1, 5392C NUM. MATH. 12, 377-383(1968) BY MARTIN AND WILKINSON, 5393C AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE. 5394C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971). 5395C 5396C THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC 5397C TRIDIAGONAL MATRIX BY THE IMPLICIT QL METHOD. 5398C 5399C ON INPUT 5400C 5401C N IS THE ORDER OF THE MATRIX. 5402C 5403C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. 5404C 5405C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX 5406C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. 5407C 5408C ON OUTPUT 5409C 5410C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN 5411C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND 5412C ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE 5413C THE SMALLEST EIGENVALUES. 5414C 5415C E HAS BEEN DESTROYED. 5416C 5417C IERR IS SET TO 5418C ZERO FOR NORMAL RETURN, 5419C J IF THE J-TH EIGENVALUE HAS NOT BEEN 5420C DETERMINED AFTER 30 ITERATIONS. 5421C 5422C CALLS PYTHAG FOR DSQRT(A*A + B*B) . 5423C 5424C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 5425C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 5426C 5427C THIS VERSION DATED AUGUST 1983. 5428C 5429C ------------------------------------------------------------------ 5430C 5431 IERR = 0 5432 IF (N .EQ. 1) GO TO 1001 5433C 5434 DO 100 I = 2, N 5435 100 E(I-1) = E(I) 5436C 5437 E(N) = 0.0D0 5438C 5439 DO 290 L = 1, N 5440 J = 0 5441C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... 5442 105 DO 110 M = L, N 5443 IF (M .EQ. N) GO TO 120 5444 TST1 = DABS(D(M)) + DABS(D(M+1)) 5445 TST2 = TST1 + DABS(E(M)) 5446 IF (TST2 .EQ. TST1) GO TO 120 5447 110 CONTINUE 5448C 5449 120 P = D(L) 5450 IF (M .EQ. L) GO TO 215 5451 IF (J .EQ. 30) GO TO 1000 5452 J = J + 1 5453C .......... FORM SHIFT .......... 5454 G = (D(L+1) - P) / (2.0D0 * E(L)) 5455 R = PYTHAG(G,1.0D0) 5456 G = D(M) - P + E(L) / (G + DSIGN(R,G)) 5457 S = 1.0D0 5458 C = 1.0D0 5459 P = 0.0D0 5460 MML = M - L 5461C .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... 5462 DO 200 II = 1, MML 5463 I = M - II 5464 F = S * E(I) 5465 B = C * E(I) 5466 R = PYTHAG(F,G) 5467 E(I+1) = R 5468 IF (R .EQ. 0.0D0) GO TO 210 5469 S = F / R 5470 C = G / R 5471 G = D(I+1) - P 5472 R = (D(I) - G) * S + 2.0D0 * C * B 5473 P = S * R 5474 D(I+1) = G + P 5475 G = C * R - B 5476 200 CONTINUE 5477C 5478 D(L) = D(L) - P 5479 E(L) = G 5480 E(M) = 0.0D0 5481 GO TO 105 5482C .......... RECOVER FROM UNDERFLOW .......... 5483 210 D(I+1) = D(I+1) - P 5484 E(M) = 0.0D0 5485 GO TO 105 5486C .......... ORDER EIGENVALUES .......... 5487 215 IF (L .EQ. 1) GO TO 250 5488C .......... FOR I=L STEP -1 UNTIL 2 DO -- .......... 5489 DO 230 II = 2, L 5490 I = L + 2 - II 5491 IF (P .GE. D(I-1)) GO TO 270 5492 D(I) = D(I-1) 5493 230 CONTINUE 5494C 5495 250 I = 1 5496 270 D(I) = P 5497 290 CONTINUE 5498C 5499 GO TO 1001 5500C .......... SET ERROR -- NO CONVERGENCE TO AN 5501C EIGENVALUE AFTER 30 ITERATIONS .......... 5502 1000 IERR = L 5503 1001 RETURN 5504 END 5505 SUBROUTINE IMTQL2(NM,N,D,E,Z,IERR) 5506C 5507 INTEGER I,J,K,L,M,N,II,NM,MML,IERR 5508 DOUBLE PRECISION D(N),E(N),Z(NM,N) 5509 DOUBLE PRECISION B,C,F,G,P,R,S,TST1,TST2,PYTHAG 5510C 5511C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE IMTQL2, 5512C NUM. MATH. 12, 377-383(1968) BY MARTIN AND WILKINSON, 5513C AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE. 5514C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971). 5515C 5516C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS 5517C OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE IMPLICIT QL METHOD. 5518C THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO 5519C BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS 5520C FULL MATRIX TO TRIDIAGONAL FORM. 5521C 5522C ON INPUT 5523C 5524C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 5525C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 5526C DIMENSION STATEMENT. 5527C 5528C N IS THE ORDER OF THE MATRIX. 5529C 5530C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. 5531C 5532C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX 5533C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. 5534C 5535C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE 5536C REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS 5537C OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN 5538C THE IDENTITY MATRIX. 5539C 5540C ON OUTPUT 5541C 5542C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN 5543C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT 5544C UNORDERED FOR INDICES 1,2,...,IERR-1. 5545C 5546C E HAS BEEN DESTROYED. 5547C 5548C Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC 5549C TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE, 5550C Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED 5551C EIGENVALUES. 5552C 5553C IERR IS SET TO 5554C ZERO FOR NORMAL RETURN, 5555C J IF THE J-TH EIGENVALUE HAS NOT BEEN 5556C DETERMINED AFTER 30 ITERATIONS. 5557C 5558C CALLS PYTHAG FOR DSQRT(A*A + B*B) . 5559C 5560C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 5561C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 5562C 5563C THIS VERSION DATED AUGUST 1983. 5564C 5565C ------------------------------------------------------------------ 5566C 5567 IERR = 0 5568 IF (N .EQ. 1) GO TO 1001 5569C 5570 DO 100 I = 2, N 5571 100 E(I-1) = E(I) 5572C 5573 E(N) = 0.0D0 5574C 5575 DO 240 L = 1, N 5576 J = 0 5577C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... 5578 105 DO 110 M = L, N 5579 IF (M .EQ. N) GO TO 120 5580 TST1 = DABS(D(M)) + DABS(D(M+1)) 5581 TST2 = TST1 + DABS(E(M)) 5582 IF (TST2 .EQ. TST1) GO TO 120 5583 110 CONTINUE 5584C 5585 120 P = D(L) 5586 IF (M .EQ. L) GO TO 240 5587 IF (J .EQ. 30) GO TO 1000 5588 J = J + 1 5589C .......... FORM SHIFT .......... 5590 G = (D(L+1) - P) / (2.0D0 * E(L)) 5591 R = PYTHAG(G,1.0D0) 5592 G = D(M) - P + E(L) / (G + DSIGN(R,G)) 5593 S = 1.0D0 5594 C = 1.0D0 5595 P = 0.0D0 5596 MML = M - L 5597C .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... 5598 DO 200 II = 1, MML 5599 I = M - II 5600 F = S * E(I) 5601 B = C * E(I) 5602 R = PYTHAG(F,G) 5603 E(I+1) = R 5604 IF (R .EQ. 0.0D0) GO TO 210 5605 S = F / R 5606 C = G / R 5607 G = D(I+1) - P 5608 R = (D(I) - G) * S + 2.0D0 * C * B 5609 P = S * R 5610 D(I+1) = G + P 5611 G = C * R - B 5612C .......... FORM VECTOR .......... 5613 DO 180 K = 1, N 5614 F = Z(K,I+1) 5615 Z(K,I+1) = S * Z(K,I) + C * F 5616 Z(K,I) = C * Z(K,I) - S * F 5617 180 CONTINUE 5618C 5619 200 CONTINUE 5620C 5621 D(L) = D(L) - P 5622 E(L) = G 5623 E(M) = 0.0D0 5624 GO TO 105 5625C .......... RECOVER FROM UNDERFLOW .......... 5626 210 D(I+1) = D(I+1) - P 5627 E(M) = 0.0D0 5628 GO TO 105 5629 240 CONTINUE 5630C .......... ORDER EIGENVALUES AND EIGENVECTORS .......... 5631 DO 300 II = 2, N 5632 I = II - 1 5633 K = I 5634 P = D(I) 5635C 5636 DO 260 J = II, N 5637 IF (D(J) .GE. P) GO TO 260 5638 K = J 5639 P = D(J) 5640 260 CONTINUE 5641C 5642 IF (K .EQ. I) GO TO 300 5643 D(K) = D(I) 5644 D(I) = P 5645C 5646 DO 280 J = 1, N 5647 P = Z(J,I) 5648 Z(J,I) = Z(J,K) 5649 Z(J,K) = P 5650 280 CONTINUE 5651C 5652 300 CONTINUE 5653C 5654 GO TO 1001 5655C .......... SET ERROR -- NO CONVERGENCE TO AN 5656C EIGENVALUE AFTER 30 ITERATIONS .......... 5657 1000 IERR = L 5658 1001 RETURN 5659 END 5660 SUBROUTINE IMTQLV(N,D,E,E2,W,IND,IERR,RV1) 5661C 5662 INTEGER I,J,K,L,M,N,II,MML,TAG,IERR 5663 DOUBLE PRECISION D(N),E(N),E2(N),W(N),RV1(N) 5664 DOUBLE PRECISION B,C,F,G,P,R,S,TST1,TST2,PYTHAG 5665 INTEGER IND(N) 5666C 5667C THIS SUBROUTINE IS A VARIANT OF IMTQL1 WHICH IS A TRANSLATION OF 5668C ALGOL PROCEDURE IMTQL1, NUM. MATH. 12, 377-383(1968) BY MARTIN AND 5669C WILKINSON, AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE. 5670C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971). 5671C 5672C THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC TRIDIAGONAL 5673C MATRIX BY THE IMPLICIT QL METHOD AND ASSOCIATES WITH THEM 5674C THEIR CORRESPONDING SUBMATRIX INDICES. 5675C 5676C ON INPUT 5677C 5678C N IS THE ORDER OF THE MATRIX. 5679C 5680C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. 5681C 5682C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX 5683C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. 5684C 5685C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. 5686C E2(1) IS ARBITRARY. 5687C 5688C ON OUTPUT 5689C 5690C D AND E ARE UNALTERED. 5691C 5692C ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED 5693C AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE 5694C MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES. 5695C E2(1) IS ALSO SET TO ZERO. 5696C 5697C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN 5698C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND 5699C ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE 5700C THE SMALLEST EIGENVALUES. 5701C 5702C IND CONTAINS THE SUBMATRIX INDICES ASSOCIATED WITH THE 5703C CORRESPONDING EIGENVALUES IN W -- 1 FOR EIGENVALUES 5704C BELONGING TO THE FIRST SUBMATRIX FROM THE TOP, 5705C 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC.. 5706C 5707C IERR IS SET TO 5708C ZERO FOR NORMAL RETURN, 5709C J IF THE J-TH EIGENVALUE HAS NOT BEEN 5710C DETERMINED AFTER 30 ITERATIONS. 5711C 5712C RV1 IS A TEMPORARY STORAGE ARRAY. 5713C 5714C CALLS PYTHAG FOR DSQRT(A*A + B*B) . 5715C 5716C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 5717C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 5718C 5719C THIS VERSION DATED AUGUST 1983. 5720C 5721C ------------------------------------------------------------------ 5722C 5723 IERR = 0 5724 K = 0 5725 TAG = 0 5726C 5727 DO 100 I = 1, N 5728 W(I) = D(I) 5729 IF (I .NE. 1) RV1(I-1) = E(I) 5730 100 CONTINUE 5731C 5732 E2(1) = 0.0D0 5733 RV1(N) = 0.0D0 5734C 5735 DO 290 L = 1, N 5736 J = 0 5737C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... 5738 105 DO 110 M = L, N 5739 IF (M .EQ. N) GO TO 120 5740 TST1 = DABS(W(M)) + DABS(W(M+1)) 5741 TST2 = TST1 + DABS(RV1(M)) 5742 IF (TST2 .EQ. TST1) GO TO 120 5743C .......... GUARD AGAINST UNDERFLOWED ELEMENT OF E2 .......... 5744 IF (E2(M+1) .EQ. 0.0D0) GO TO 125 5745 110 CONTINUE 5746C 5747 120 IF (M .LE. K) GO TO 130 5748 IF (M .NE. N) E2(M+1) = 0.0D0 5749 125 K = M 5750 TAG = TAG + 1 5751 130 P = W(L) 5752 IF (M .EQ. L) GO TO 215 5753 IF (J .EQ. 30) GO TO 1000 5754 J = J + 1 5755C .......... FORM SHIFT .......... 5756 G = (W(L+1) - P) / (2.0D0 * RV1(L)) 5757 R = PYTHAG(G,1.0D0) 5758 G = W(M) - P + RV1(L) / (G + DSIGN(R,G)) 5759 S = 1.0D0 5760 C = 1.0D0 5761 P = 0.0D0 5762 MML = M - L 5763C .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... 5764 DO 200 II = 1, MML 5765 I = M - II 5766 F = S * RV1(I) 5767 B = C * RV1(I) 5768 R = PYTHAG(F,G) 5769 RV1(I+1) = R 5770 IF (R .EQ. 0.0D0) GO TO 210 5771 S = F / R 5772 C = G / R 5773 G = W(I+1) - P 5774 R = (W(I) - G) * S + 2.0D0 * C * B 5775 P = S * R 5776 W(I+1) = G + P 5777 G = C * R - B 5778 200 CONTINUE 5779C 5780 W(L) = W(L) - P 5781 RV1(L) = G 5782 RV1(M) = 0.0D0 5783 GO TO 105 5784C .......... RECOVER FROM UNDERFLOW .......... 5785 210 W(I+1) = W(I+1) - P 5786 RV1(M) = 0.0D0 5787 GO TO 105 5788C .......... ORDER EIGENVALUES .......... 5789 215 IF (L .EQ. 1) GO TO 250 5790C .......... FOR I=L STEP -1 UNTIL 2 DO -- .......... 5791 DO 230 II = 2, L 5792 I = L + 2 - II 5793 IF (P .GE. W(I-1)) GO TO 270 5794 W(I) = W(I-1) 5795 IND(I) = IND(I-1) 5796 230 CONTINUE 5797C 5798 250 I = 1 5799 270 W(I) = P 5800 IND(I) = TAG 5801 290 CONTINUE 5802C 5803 GO TO 1001 5804C .......... SET ERROR -- NO CONVERGENCE TO AN 5805C EIGENVALUE AFTER 30 ITERATIONS .......... 5806 1000 IERR = L 5807 1001 RETURN 5808 END 5809 SUBROUTINE INVIT(NM,N,A,WR,WI,SELECT,MM,M,Z,IERR,RM1,RV1,RV2) 5810C 5811 INTEGER I,J,K,L,M,N,S,II,IP,MM,MP,NM,NS,N1,UK,IP1,ITS,KM1,IERR 5812 DOUBLE PRECISION A(NM,N),WR(N),WI(N),Z(NM,MM),RM1(N,N), 5813 X RV1(N),RV2(N) 5814 DOUBLE PRECISION T,W,X,Y,EPS3,NORM,NORMV,EPSLON,GROWTO,ILAMBD, 5815 X PYTHAG,RLAMBD,UKROOT 5816 LOGICAL SELECT(N) 5817C 5818C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE INVIT 5819C BY PETERS AND WILKINSON. 5820C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). 5821C 5822C THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A REAL UPPER 5823C HESSENBERG MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES, 5824C USING INVERSE ITERATION. 5825C 5826C ON INPUT 5827C 5828C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 5829C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 5830C DIMENSION STATEMENT. 5831C 5832C N IS THE ORDER OF THE MATRIX. 5833C 5834C A CONTAINS THE HESSENBERG MATRIX. 5835C 5836C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, RESPECTIVELY, 5837C OF THE EIGENVALUES OF THE MATRIX. THE EIGENVALUES MUST BE 5838C STORED IN A MANNER IDENTICAL TO THAT OF SUBROUTINE HQR, 5839C WHICH RECOGNIZES POSSIBLE SPLITTING OF THE MATRIX. 5840C 5841C SELECT SPECIFIES THE EIGENVECTORS TO BE FOUND. THE 5842C EIGENVECTOR CORRESPONDING TO THE J-TH EIGENVALUE IS 5843C SPECIFIED BY SETTING SELECT(J) TO .TRUE.. 5844C 5845C MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF 5846C COLUMNS REQUIRED TO STORE THE EIGENVECTORS TO BE FOUND. 5847C NOTE THAT TWO COLUMNS ARE REQUIRED TO STORE THE 5848C EIGENVECTOR CORRESPONDING TO A COMPLEX EIGENVALUE. 5849C 5850C ON OUTPUT 5851C 5852C A AND WI ARE UNALTERED. 5853C 5854C WR MAY HAVE BEEN ALTERED SINCE CLOSE EIGENVALUES ARE PERTURBED 5855C SLIGHTLY IN SEARCHING FOR INDEPENDENT EIGENVECTORS. 5856C 5857C SELECT MAY HAVE BEEN ALTERED. IF THE ELEMENTS CORRESPONDING 5858C TO A PAIR OF CONJUGATE COMPLEX EIGENVALUES WERE EACH 5859C INITIALLY SET TO .TRUE., THE PROGRAM RESETS THE SECOND OF 5860C THE TWO ELEMENTS TO .FALSE.. 5861C 5862C M IS THE NUMBER OF COLUMNS ACTUALLY USED TO STORE 5863C THE EIGENVECTORS. 5864C 5865C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS. 5866C IF THE NEXT SELECTED EIGENVALUE IS REAL, THE NEXT COLUMN 5867C OF Z CONTAINS ITS EIGENVECTOR. IF THE EIGENVALUE IS 5868C COMPLEX, THE NEXT TWO COLUMNS OF Z CONTAIN THE REAL AND 5869C IMAGINARY PARTS OF ITS EIGENVECTOR. THE EIGENVECTORS ARE 5870C NORMALIZED SO THAT THE COMPONENT OF LARGEST MAGNITUDE IS 1. 5871C ANY VECTOR WHICH FAILS THE ACCEPTANCE TEST IS SET TO ZERO. 5872C 5873C IERR IS SET TO 5874C ZERO FOR NORMAL RETURN, 5875C -(2*N+1) IF MORE THAN MM COLUMNS OF Z ARE NECESSARY 5876C TO STORE THE EIGENVECTORS CORRESPONDING TO 5877C THE SPECIFIED EIGENVALUES. 5878C -K IF THE ITERATION CORRESPONDING TO THE K-TH 5879C VALUE FAILS, 5880C -(N+K) IF BOTH ERROR SITUATIONS OCCUR. 5881C 5882C RM1, RV1, AND RV2 ARE TEMPORARY STORAGE ARRAYS. NOTE THAT RM1 5883C IS SQUARE OF DIMENSION N BY N AND, AUGMENTED BY TWO COLUMNS 5884C OF Z, IS THE TRANSPOSE OF THE CORRESPONDING ALGOL B ARRAY. 5885C 5886C THE ALGOL PROCEDURE GUESSVEC APPEARS IN INVIT IN LINE. 5887C 5888C CALLS CDIV FOR COMPLEX DIVISION. 5889C CALLS PYTHAG FOR DSQRT(A*A + B*B) . 5890C 5891C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 5892C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 5893C 5894C THIS VERSION DATED AUGUST 1983. 5895C 5896C ------------------------------------------------------------------ 5897C 5898 IERR = 0 5899 UK = 0 5900 S = 1 5901C .......... IP = 0, REAL EIGENVALUE 5902C 1, FIRST OF CONJUGATE COMPLEX PAIR 5903C -1, SECOND OF CONJUGATE COMPLEX PAIR .......... 5904 IP = 0 5905 N1 = N - 1 5906C 5907 DO 980 K = 1, N 5908 IF (WI(K) .EQ. 0.0D0 .OR. IP .LT. 0) GO TO 100 5909 IP = 1 5910 IF (SELECT(K) .AND. SELECT(K+1)) SELECT(K+1) = .FALSE. 5911 100 IF (.NOT. SELECT(K)) GO TO 960 5912 IF (WI(K) .NE. 0.0D0) S = S + 1 5913 IF (S .GT. MM) GO TO 1000 5914 IF (UK .GE. K) GO TO 200 5915C .......... CHECK FOR POSSIBLE SPLITTING .......... 5916 DO 120 UK = K, N 5917 IF (UK .EQ. N) GO TO 140 5918 IF (A(UK+1,UK) .EQ. 0.0D0) GO TO 140 5919 120 CONTINUE 5920C .......... COMPUTE INFINITY NORM OF LEADING UK BY UK 5921C (HESSENBERG) MATRIX .......... 5922 140 NORM = 0.0D0 5923 MP = 1 5924C 5925 DO 180 I = 1, UK 5926 X = 0.0D0 5927C 5928 DO 160 J = MP, UK 5929 160 X = X + DABS(A(I,J)) 5930C 5931 IF (X .GT. NORM) NORM = X 5932 MP = I 5933 180 CONTINUE 5934C .......... EPS3 REPLACES ZERO PIVOT IN DECOMPOSITION 5935C AND CLOSE ROOTS ARE MODIFIED BY EPS3 .......... 5936 IF (NORM .EQ. 0.0D0) NORM = 1.0D0 5937 EPS3 = EPSLON(NORM) 5938C .......... GROWTO IS THE CRITERION FOR THE GROWTH .......... 5939 UKROOT = UK 5940 UKROOT = DSQRT(UKROOT) 5941 GROWTO = 0.1D0 / UKROOT 5942 200 RLAMBD = WR(K) 5943 ILAMBD = WI(K) 5944 IF (K .EQ. 1) GO TO 280 5945 KM1 = K - 1 5946 GO TO 240 5947C .......... PERTURB EIGENVALUE IF IT IS CLOSE 5948C TO ANY PREVIOUS EIGENVALUE .......... 5949 220 RLAMBD = RLAMBD + EPS3 5950C .......... FOR I=K-1 STEP -1 UNTIL 1 DO -- .......... 5951 240 DO 260 II = 1, KM1 5952 I = K - II 5953 IF (SELECT(I) .AND. DABS(WR(I)-RLAMBD) .LT. EPS3 .AND. 5954 X DABS(WI(I)-ILAMBD) .LT. EPS3) GO TO 220 5955 260 CONTINUE 5956C 5957 WR(K) = RLAMBD 5958C .......... PERTURB CONJUGATE EIGENVALUE TO MATCH .......... 5959 IP1 = K + IP 5960 WR(IP1) = RLAMBD 5961C .......... FORM UPPER HESSENBERG A-RLAMBD*I (TRANSPOSED) 5962C AND INITIAL REAL VECTOR .......... 5963 280 MP = 1 5964C 5965 DO 320 I = 1, UK 5966C 5967 DO 300 J = MP, UK 5968 300 RM1(J,I) = A(I,J) 5969C 5970 RM1(I,I) = RM1(I,I) - RLAMBD 5971 MP = I 5972 RV1(I) = EPS3 5973 320 CONTINUE 5974C 5975 ITS = 0 5976 IF (ILAMBD .NE. 0.0D0) GO TO 520 5977C .......... REAL EIGENVALUE. 5978C TRIANGULAR DECOMPOSITION WITH INTERCHANGES, 5979C REPLACING ZERO PIVOTS BY EPS3 .......... 5980 IF (UK .EQ. 1) GO TO 420 5981C 5982 DO 400 I = 2, UK 5983 MP = I - 1 5984 IF (DABS(RM1(MP,I)) .LE. DABS(RM1(MP,MP))) GO TO 360 5985C 5986 DO 340 J = MP, UK 5987 Y = RM1(J,I) 5988 RM1(J,I) = RM1(J,MP) 5989 RM1(J,MP) = Y 5990 340 CONTINUE 5991C 5992 360 IF (RM1(MP,MP) .EQ. 0.0D0) RM1(MP,MP) = EPS3 5993 X = RM1(MP,I) / RM1(MP,MP) 5994 IF (X .EQ. 0.0D0) GO TO 400 5995C 5996 DO 380 J = I, UK 5997 380 RM1(J,I) = RM1(J,I) - X * RM1(J,MP) 5998C 5999 400 CONTINUE 6000C 6001 420 IF (RM1(UK,UK) .EQ. 0.0D0) RM1(UK,UK) = EPS3 6002C .......... BACK SUBSTITUTION FOR REAL VECTOR 6003C FOR I=UK STEP -1 UNTIL 1 DO -- .......... 6004 440 DO 500 II = 1, UK 6005 I = UK + 1 - II 6006 Y = RV1(I) 6007 IF (I .EQ. UK) GO TO 480 6008 IP1 = I + 1 6009C 6010 DO 460 J = IP1, UK 6011 460 Y = Y - RM1(J,I) * RV1(J) 6012C 6013 480 RV1(I) = Y / RM1(I,I) 6014 500 CONTINUE 6015C 6016 GO TO 740 6017C .......... COMPLEX EIGENVALUE. 6018C TRIANGULAR DECOMPOSITION WITH INTERCHANGES, 6019C REPLACING ZERO PIVOTS BY EPS3. STORE IMAGINARY 6020C PARTS IN UPPER TRIANGLE STARTING AT (1,3) .......... 6021 520 NS = N - S 6022 Z(1,S-1) = -ILAMBD 6023 Z(1,S) = 0.0D0 6024 IF (N .EQ. 2) GO TO 550 6025 RM1(1,3) = -ILAMBD 6026 Z(1,S-1) = 0.0D0 6027 IF (N .EQ. 3) GO TO 550 6028C 6029 DO 540 I = 4, N 6030 540 RM1(1,I) = 0.0D0 6031C 6032 550 DO 640 I = 2, UK 6033 MP = I - 1 6034 W = RM1(MP,I) 6035 IF (I .LT. N) T = RM1(MP,I+1) 6036 IF (I .EQ. N) T = Z(MP,S-1) 6037 X = RM1(MP,MP) * RM1(MP,MP) + T * T 6038 IF (W * W .LE. X) GO TO 580 6039 X = RM1(MP,MP) / W 6040 Y = T / W 6041 RM1(MP,MP) = W 6042 IF (I .LT. N) RM1(MP,I+1) = 0.0D0 6043 IF (I .EQ. N) Z(MP,S-1) = 0.0D0 6044C 6045 DO 560 J = I, UK 6046 W = RM1(J,I) 6047 RM1(J,I) = RM1(J,MP) - X * W 6048 RM1(J,MP) = W 6049 IF (J .LT. N1) GO TO 555 6050 L = J - NS 6051 Z(I,L) = Z(MP,L) - Y * W 6052 Z(MP,L) = 0.0D0 6053 GO TO 560 6054 555 RM1(I,J+2) = RM1(MP,J+2) - Y * W 6055 RM1(MP,J+2) = 0.0D0 6056 560 CONTINUE 6057C 6058 RM1(I,I) = RM1(I,I) - Y * ILAMBD 6059 IF (I .LT. N1) GO TO 570 6060 L = I - NS 6061 Z(MP,L) = -ILAMBD 6062 Z(I,L) = Z(I,L) + X * ILAMBD 6063 GO TO 640 6064 570 RM1(MP,I+2) = -ILAMBD 6065 RM1(I,I+2) = RM1(I,I+2) + X * ILAMBD 6066 GO TO 640 6067 580 IF (X .NE. 0.0D0) GO TO 600 6068 RM1(MP,MP) = EPS3 6069 IF (I .LT. N) RM1(MP,I+1) = 0.0D0 6070 IF (I .EQ. N) Z(MP,S-1) = 0.0D0 6071 T = 0.0D0 6072 X = EPS3 * EPS3 6073 600 W = W / X 6074 X = RM1(MP,MP) * W 6075 Y = -T * W 6076C 6077 DO 620 J = I, UK 6078 IF (J .LT. N1) GO TO 610 6079 L = J - NS 6080 T = Z(MP,L) 6081 Z(I,L) = -X * T - Y * RM1(J,MP) 6082 GO TO 615 6083 610 T = RM1(MP,J+2) 6084 RM1(I,J+2) = -X * T - Y * RM1(J,MP) 6085 615 RM1(J,I) = RM1(J,I) - X * RM1(J,MP) + Y * T 6086 620 CONTINUE 6087C 6088 IF (I .LT. N1) GO TO 630 6089 L = I - NS 6090 Z(I,L) = Z(I,L) - ILAMBD 6091 GO TO 640 6092 630 RM1(I,I+2) = RM1(I,I+2) - ILAMBD 6093 640 CONTINUE 6094C 6095 IF (UK .LT. N1) GO TO 650 6096 L = UK - NS 6097 T = Z(UK,L) 6098 GO TO 655 6099 650 T = RM1(UK,UK+2) 6100 655 IF (RM1(UK,UK) .EQ. 0.0D0 .AND. T .EQ. 0.0D0) RM1(UK,UK) = EPS3 6101C .......... BACK SUBSTITUTION FOR COMPLEX VECTOR 6102C FOR I=UK STEP -1 UNTIL 1 DO -- .......... 6103 660 DO 720 II = 1, UK 6104 I = UK + 1 - II 6105 X = RV1(I) 6106 Y = 0.0D0 6107 IF (I .EQ. UK) GO TO 700 6108 IP1 = I + 1 6109C 6110 DO 680 J = IP1, UK 6111 IF (J .LT. N1) GO TO 670 6112 L = J - NS 6113 T = Z(I,L) 6114 GO TO 675 6115 670 T = RM1(I,J+2) 6116 675 X = X - RM1(J,I) * RV1(J) + T * RV2(J) 6117 Y = Y - RM1(J,I) * RV2(J) - T * RV1(J) 6118 680 CONTINUE 6119C 6120 700 IF (I .LT. N1) GO TO 710 6121 L = I - NS 6122 T = Z(I,L) 6123 GO TO 715 6124 710 T = RM1(I,I+2) 6125 715 CALL CDIV(X,Y,RM1(I,I),T,RV1(I),RV2(I)) 6126 720 CONTINUE 6127C .......... ACCEPTANCE TEST FOR REAL OR COMPLEX 6128C EIGENVECTOR AND NORMALIZATION .......... 6129 740 ITS = ITS + 1 6130 NORM = 0.0D0 6131 NORMV = 0.0D0 6132C 6133 DO 780 I = 1, UK 6134 IF (ILAMBD .EQ. 0.0D0) X = DABS(RV1(I)) 6135 IF (ILAMBD .NE. 0.0D0) X = PYTHAG(RV1(I),RV2(I)) 6136 IF (NORMV .GE. X) GO TO 760 6137 NORMV = X 6138 J = I 6139 760 NORM = NORM + X 6140 780 CONTINUE 6141C 6142 IF (NORM .LT. GROWTO) GO TO 840 6143C .......... ACCEPT VECTOR .......... 6144 X = RV1(J) 6145 IF (ILAMBD .EQ. 0.0D0) X = 1.0D0 / X 6146 IF (ILAMBD .NE. 0.0D0) Y = RV2(J) 6147C 6148 DO 820 I = 1, UK 6149 IF (ILAMBD .NE. 0.0D0) GO TO 800 6150 Z(I,S) = RV1(I) * X 6151 GO TO 820 6152 800 CALL CDIV(RV1(I),RV2(I),X,Y,Z(I,S-1),Z(I,S)) 6153 820 CONTINUE 6154C 6155 IF (UK .EQ. N) GO TO 940 6156 J = UK + 1 6157 GO TO 900 6158C .......... IN-LINE PROCEDURE FOR CHOOSING 6159C A NEW STARTING VECTOR .......... 6160 840 IF (ITS .GE. UK) GO TO 880 6161 X = UKROOT 6162 Y = EPS3 / (X + 1.0D0) 6163 RV1(1) = EPS3 6164C 6165 DO 860 I = 2, UK 6166 860 RV1(I) = Y 6167C 6168 J = UK - ITS + 1 6169 RV1(J) = RV1(J) - EPS3 * X 6170 IF (ILAMBD .EQ. 0.0D0) GO TO 440 6171 GO TO 660 6172C .......... SET ERROR -- UNACCEPTED EIGENVECTOR .......... 6173 880 J = 1 6174 IERR = -K 6175C .......... SET REMAINING VECTOR COMPONENTS TO ZERO .......... 6176 900 DO 920 I = J, N 6177 Z(I,S) = 0.0D0 6178 IF (ILAMBD .NE. 0.0D0) Z(I,S-1) = 0.0D0 6179 920 CONTINUE 6180C 6181 940 S = S + 1 6182 960 IF (IP .EQ. (-1)) IP = 0 6183 IF (IP .EQ. 1) IP = -1 6184 980 CONTINUE 6185C 6186 GO TO 1001 6187C .......... SET ERROR -- UNDERESTIMATE OF EIGENVECTOR 6188C SPACE REQUIRED .......... 6189 1000 IF (IERR .NE. 0) IERR = IERR - N 6190 IF (IERR .EQ. 0) IERR = -(2 * N + 1) 6191 1001 M = S - 1 - IABS(IP) 6192 RETURN 6193 END 6194 SUBROUTINE MINFIT(NM,M,N,A,W,IP,B,IERR,RV1) 6195C 6196 INTEGER I,J,K,L,M,N,II,IP,I1,KK,K1,LL,L1,M1,NM,ITS,IERR 6197 DOUBLE PRECISION A(NM,N),W(N),B(NM,IP),RV1(N) 6198 DOUBLE PRECISION C,F,G,H,S,X,Y,Z,TST1,TST2,SCALE,PYTHAG 6199C 6200C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE MINFIT, 6201C NUM. MATH. 14, 403-420(1970) BY GOLUB AND REINSCH. 6202C HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 134-151(1971). 6203C 6204C THIS SUBROUTINE DETERMINES, TOWARDS THE SOLUTION OF THE LINEAR 6205C T 6206C SYSTEM AX=B, THE SINGULAR VALUE DECOMPOSITION A=USV OF A REAL 6207C T 6208C M BY N RECTANGULAR MATRIX, FORMING U B RATHER THAN U. HOUSEHOLDER 6209C BIDIAGONALIZATION AND A VARIANT OF THE QR ALGORITHM ARE USED. 6210C 6211C ON INPUT 6212C 6213C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 6214C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 6215C DIMENSION STATEMENT. NOTE THAT NM MUST BE AT LEAST 6216C AS LARGE AS THE MAXIMUM OF M AND N. 6217C 6218C M IS THE NUMBER OF ROWS OF A AND B. 6219C 6220C N IS THE NUMBER OF COLUMNS OF A AND THE ORDER OF V. 6221C 6222C A CONTAINS THE RECTANGULAR COEFFICIENT MATRIX OF THE SYSTEM. 6223C 6224C IP IS THE NUMBER OF COLUMNS OF B. IP CAN BE ZERO. 6225C 6226C B CONTAINS THE CONSTANT COLUMN MATRIX OF THE SYSTEM 6227C IF IP IS NOT ZERO. OTHERWISE B IS NOT REFERENCED. 6228C 6229C ON OUTPUT 6230C 6231C A HAS BEEN OVERWRITTEN BY THE MATRIX V (ORTHOGONAL) OF THE 6232C DECOMPOSITION IN ITS FIRST N ROWS AND COLUMNS. IF AN 6233C ERROR EXIT IS MADE, THE COLUMNS OF V CORRESPONDING TO 6234C INDICES OF CORRECT SINGULAR VALUES SHOULD BE CORRECT. 6235C 6236C W CONTAINS THE N (NON-NEGATIVE) SINGULAR VALUES OF A (THE 6237C DIAGONAL ELEMENTS OF S). THEY ARE UNORDERED. IF AN 6238C ERROR EXIT IS MADE, THE SINGULAR VALUES SHOULD BE CORRECT 6239C FOR INDICES IERR+1,IERR+2,...,N. 6240C 6241C T 6242C B HAS BEEN OVERWRITTEN BY U B. IF AN ERROR EXIT IS MADE, 6243C T 6244C THE ROWS OF U B CORRESPONDING TO INDICES OF CORRECT 6245C SINGULAR VALUES SHOULD BE CORRECT. 6246C 6247C IERR IS SET TO 6248C ZERO FOR NORMAL RETURN, 6249C K IF THE K-TH SINGULAR VALUE HAS NOT BEEN 6250C DETERMINED AFTER 30 ITERATIONS. 6251C 6252C RV1 IS A TEMPORARY STORAGE ARRAY. 6253C 6254C CALLS PYTHAG FOR DSQRT(A*A + B*B) . 6255C 6256C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 6257C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 6258C 6259C THIS VERSION DATED AUGUST 1983. 6260C 6261C ------------------------------------------------------------------ 6262C 6263 IERR = 0 6264C .......... HOUSEHOLDER REDUCTION TO BIDIAGONAL FORM .......... 6265 G = 0.0D0 6266 SCALE = 0.0D0 6267 X = 0.0D0 6268C 6269 DO 300 I = 1, N 6270 L = I + 1 6271 RV1(I) = SCALE * G 6272 G = 0.0D0 6273 S = 0.0D0 6274 SCALE = 0.0D0 6275 IF (I .GT. M) GO TO 210 6276C 6277 DO 120 K = I, M 6278 120 SCALE = SCALE + DABS(A(K,I)) 6279C 6280 IF (SCALE .EQ. 0.0D0) GO TO 210 6281C 6282 DO 130 K = I, M 6283 A(K,I) = A(K,I) / SCALE 6284 S = S + A(K,I)**2 6285 130 CONTINUE 6286C 6287 F = A(I,I) 6288 G = -DSIGN(DSQRT(S),F) 6289 H = F * G - S 6290 A(I,I) = F - G 6291 IF (I .EQ. N) GO TO 160 6292C 6293 DO 150 J = L, N 6294 S = 0.0D0 6295C 6296 DO 140 K = I, M 6297 140 S = S + A(K,I) * A(K,J) 6298C 6299 F = S / H 6300C 6301 DO 150 K = I, M 6302 A(K,J) = A(K,J) + F * A(K,I) 6303 150 CONTINUE 6304C 6305 160 IF (IP .EQ. 0) GO TO 190 6306C 6307 DO 180 J = 1, IP 6308 S = 0.0D0 6309C 6310 DO 170 K = I, M 6311 170 S = S + A(K,I) * B(K,J) 6312C 6313 F = S / H 6314C 6315 DO 180 K = I, M 6316 B(K,J) = B(K,J) + F * A(K,I) 6317 180 CONTINUE 6318C 6319 190 DO 200 K = I, M 6320 200 A(K,I) = SCALE * A(K,I) 6321C 6322 210 W(I) = SCALE * G 6323 G = 0.0D0 6324 S = 0.0D0 6325 SCALE = 0.0D0 6326 IF (I .GT. M .OR. I .EQ. N) GO TO 290 6327C 6328 DO 220 K = L, N 6329 220 SCALE = SCALE + DABS(A(I,K)) 6330C 6331 IF (SCALE .EQ. 0.0D0) GO TO 290 6332C 6333 DO 230 K = L, N 6334 A(I,K) = A(I,K) / SCALE 6335 S = S + A(I,K)**2 6336 230 CONTINUE 6337C 6338 F = A(I,L) 6339 G = -DSIGN(DSQRT(S),F) 6340 H = F * G - S 6341 A(I,L) = F - G 6342C 6343 DO 240 K = L, N 6344 240 RV1(K) = A(I,K) / H 6345C 6346 IF (I .EQ. M) GO TO 270 6347C 6348 DO 260 J = L, M 6349 S = 0.0D0 6350C 6351 DO 250 K = L, N 6352 250 S = S + A(J,K) * A(I,K) 6353C 6354 DO 260 K = L, N 6355 A(J,K) = A(J,K) + S * RV1(K) 6356 260 CONTINUE 6357C 6358 270 DO 280 K = L, N 6359 280 A(I,K) = SCALE * A(I,K) 6360C 6361 290 X = DMAX1(X,DABS(W(I))+DABS(RV1(I))) 6362 300 CONTINUE 6363C .......... ACCUMULATION OF RIGHT-HAND TRANSFORMATIONS. 6364C FOR I=N STEP -1 UNTIL 1 DO -- .......... 6365 DO 400 II = 1, N 6366 I = N + 1 - II 6367 IF (I .EQ. N) GO TO 390 6368 IF (G .EQ. 0.0D0) GO TO 360 6369C 6370 DO 320 J = L, N 6371C .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW .......... 6372 320 A(J,I) = (A(I,J) / A(I,L)) / G 6373C 6374 DO 350 J = L, N 6375 S = 0.0D0 6376C 6377 DO 340 K = L, N 6378 340 S = S + A(I,K) * A(K,J) 6379C 6380 DO 350 K = L, N 6381 A(K,J) = A(K,J) + S * A(K,I) 6382 350 CONTINUE 6383C 6384 360 DO 380 J = L, N 6385 A(I,J) = 0.0D0 6386 A(J,I) = 0.0D0 6387 380 CONTINUE 6388C 6389 390 A(I,I) = 1.0D0 6390 G = RV1(I) 6391 L = I 6392 400 CONTINUE 6393C 6394 IF (M .GE. N .OR. IP .EQ. 0) GO TO 510 6395 M1 = M + 1 6396C 6397 DO 500 I = M1, N 6398C 6399 DO 500 J = 1, IP 6400 B(I,J) = 0.0D0 6401 500 CONTINUE 6402C .......... DIAGONALIZATION OF THE BIDIAGONAL FORM .......... 6403 510 TST1 = X 6404C .......... FOR K=N STEP -1 UNTIL 1 DO -- .......... 6405 DO 700 KK = 1, N 6406 K1 = N - KK 6407 K = K1 + 1 6408 ITS = 0 6409C .......... TEST FOR SPLITTING. 6410C FOR L=K STEP -1 UNTIL 1 DO -- .......... 6411 520 DO 530 LL = 1, K 6412 L1 = K - LL 6413 L = L1 + 1 6414 TST2 = TST1 + DABS(RV1(L)) 6415 IF (TST2 .EQ. TST1) GO TO 565 6416C .......... RV1(1) IS ALWAYS ZERO, SO THERE IS NO EXIT 6417C THROUGH THE BOTTOM OF THE LOOP .......... 6418 TST2 = TST1 + DABS(W(L1)) 6419 IF (TST2 .EQ. TST1) GO TO 540 6420 530 CONTINUE 6421C .......... CANCELLATION OF RV1(L) IF L GREATER THAN 1 .......... 6422 540 C = 0.0D0 6423 S = 1.0D0 6424C 6425 DO 560 I = L, K 6426 F = S * RV1(I) 6427 RV1(I) = C * RV1(I) 6428 TST2 = TST1 + DABS(F) 6429 IF (TST2 .EQ. TST1) GO TO 565 6430 G = W(I) 6431 H = PYTHAG(F,G) 6432 W(I) = H 6433 C = G / H 6434 S = -F / H 6435 IF (IP .EQ. 0) GO TO 560 6436C 6437 DO 550 J = 1, IP 6438 Y = B(L1,J) 6439 Z = B(I,J) 6440 B(L1,J) = Y * C + Z * S 6441 B(I,J) = -Y * S + Z * C 6442 550 CONTINUE 6443C 6444 560 CONTINUE 6445C .......... TEST FOR CONVERGENCE .......... 6446 565 Z = W(K) 6447 IF (L .EQ. K) GO TO 650 6448C .......... SHIFT FROM BOTTOM 2 BY 2 MINOR .......... 6449 IF (ITS .EQ. 30) GO TO 1000 6450 ITS = ITS + 1 6451 X = W(L) 6452 Y = W(K1) 6453 G = RV1(K1) 6454 H = RV1(K) 6455 F = 0.5D0 * (((G + Z) / H) * ((G - Z) / Y) + Y / H - H / Y) 6456 G = PYTHAG(F,1.0D0) 6457 F = X - (Z / X) * Z + (H / X) * (Y / (F + DSIGN(G,F)) - H) 6458C .......... NEXT QR TRANSFORMATION .......... 6459 C = 1.0D0 6460 S = 1.0D0 6461C 6462 DO 600 I1 = L, K1 6463 I = I1 + 1 6464 G = RV1(I) 6465 Y = W(I) 6466 H = S * G 6467 G = C * G 6468 Z = PYTHAG(F,H) 6469 RV1(I1) = Z 6470 C = F / Z 6471 S = H / Z 6472 F = X * C + G * S 6473 G = -X * S + G * C 6474 H = Y * S 6475 Y = Y * C 6476C 6477 DO 570 J = 1, N 6478 X = A(J,I1) 6479 Z = A(J,I) 6480 A(J,I1) = X * C + Z * S 6481 A(J,I) = -X * S + Z * C 6482 570 CONTINUE 6483C 6484 Z = PYTHAG(F,H) 6485 W(I1) = Z 6486C .......... ROTATION CAN BE ARBITRARY IF Z IS ZERO .......... 6487 IF (Z .EQ. 0.0D0) GO TO 580 6488 C = F / Z 6489 S = H / Z 6490 580 F = C * G + S * Y 6491 X = -S * G + C * Y 6492 IF (IP .EQ. 0) GO TO 600 6493C 6494 DO 590 J = 1, IP 6495 Y = B(I1,J) 6496 Z = B(I,J) 6497 B(I1,J) = Y * C + Z * S 6498 B(I,J) = -Y * S + Z * C 6499 590 CONTINUE 6500C 6501 600 CONTINUE 6502C 6503 RV1(L) = 0.0D0 6504 RV1(K) = F 6505 W(K) = X 6506 GO TO 520 6507C .......... CONVERGENCE .......... 6508 650 IF (Z .GE. 0.0D0) GO TO 700 6509C .......... W(K) IS MADE NON-NEGATIVE .......... 6510 W(K) = -Z 6511C 6512 DO 690 J = 1, N 6513 690 A(J,K) = -A(J,K) 6514C 6515 700 CONTINUE 6516C 6517 GO TO 1001 6518C .......... SET ERROR -- NO CONVERGENCE TO A 6519C SINGULAR VALUE AFTER 30 ITERATIONS .......... 6520 1000 IERR = K 6521 1001 RETURN 6522 END 6523 SUBROUTINE ORTBAK(NM,LOW,IGH,A,ORT,M,Z) 6524C 6525 INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1 6526 DOUBLE PRECISION A(NM,IGH),ORT(IGH),Z(NM,M) 6527 DOUBLE PRECISION G 6528C 6529C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTBAK, 6530C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. 6531C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). 6532C 6533C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL GENERAL 6534C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING 6535C UPPER HESSENBERG MATRIX DETERMINED BY ORTHES. 6536C 6537C ON INPUT 6538C 6539C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 6540C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 6541C DIMENSION STATEMENT. 6542C 6543C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING 6544C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, 6545C SET LOW=1 AND IGH EQUAL TO THE ORDER OF THE MATRIX. 6546C 6547C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- 6548C FORMATIONS USED IN THE REDUCTION BY ORTHES 6549C IN ITS STRICT LOWER TRIANGLE. 6550C 6551C ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANS- 6552C FORMATIONS USED IN THE REDUCTION BY ORTHES. 6553C ONLY ELEMENTS LOW THROUGH IGH ARE USED. 6554C 6555C M IS THE NUMBER OF COLUMNS OF Z TO BE BACK TRANSFORMED. 6556C 6557C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGEN- 6558C VECTORS TO BE BACK TRANSFORMED IN ITS FIRST M COLUMNS. 6559C 6560C ON OUTPUT 6561C 6562C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE 6563C TRANSFORMED EIGENVECTORS IN ITS FIRST M COLUMNS. 6564C 6565C ORT HAS BEEN ALTERED. 6566C 6567C NOTE THAT ORTBAK PRESERVES VECTOR EUCLIDEAN NORMS. 6568C 6569C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 6570C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 6571C 6572C THIS VERSION DATED AUGUST 1983. 6573C 6574C ------------------------------------------------------------------ 6575C 6576 IF (M .EQ. 0) GO TO 200 6577 LA = IGH - 1 6578 KP1 = LOW + 1 6579 IF (LA .LT. KP1) GO TO 200 6580C .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... 6581 DO 140 MM = KP1, LA 6582 MP = LOW + IGH - MM 6583 IF (A(MP,MP-1) .EQ. 0.0D0) GO TO 140 6584 MP1 = MP + 1 6585C 6586 DO 100 I = MP1, IGH 6587 100 ORT(I) = A(I,MP-1) 6588C 6589 DO 130 J = 1, M 6590 G = 0.0D0 6591C 6592 DO 110 I = MP, IGH 6593 110 G = G + ORT(I) * Z(I,J) 6594C .......... DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHES. 6595C DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW .......... 6596 G = (G / ORT(MP)) / A(MP,MP-1) 6597C 6598 DO 120 I = MP, IGH 6599 120 Z(I,J) = Z(I,J) + G * ORT(I) 6600C 6601 130 CONTINUE 6602C 6603 140 CONTINUE 6604C 6605 200 RETURN 6606 END 6607 SUBROUTINE ORTHES(NM,N,LOW,IGH,A,ORT) 6608C 6609 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW 6610 DOUBLE PRECISION A(NM,N),ORT(IGH) 6611 DOUBLE PRECISION F,G,H,SCALE 6612C 6613C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTHES, 6614C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. 6615C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). 6616C 6617C GIVEN A REAL GENERAL MATRIX, THIS SUBROUTINE 6618C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS 6619C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY 6620C ORTHOGONAL SIMILARITY TRANSFORMATIONS. 6621C 6622C ON INPUT 6623C 6624C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 6625C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 6626C DIMENSION STATEMENT. 6627C 6628C N IS THE ORDER OF THE MATRIX. 6629C 6630C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING 6631C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, 6632C SET LOW=1, IGH=N. 6633C 6634C A CONTAINS THE INPUT MATRIX. 6635C 6636C ON OUTPUT 6637C 6638C A CONTAINS THE HESSENBERG MATRIX. INFORMATION ABOUT 6639C THE ORTHOGONAL TRANSFORMATIONS USED IN THE REDUCTION 6640C IS STORED IN THE REMAINING TRIANGLE UNDER THE 6641C HESSENBERG MATRIX. 6642C 6643C ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. 6644C ONLY ELEMENTS LOW THROUGH IGH ARE USED. 6645C 6646C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 6647C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 6648C 6649C THIS VERSION DATED AUGUST 1983. 6650C 6651C ------------------------------------------------------------------ 6652C 6653 LA = IGH - 1 6654 KP1 = LOW + 1 6655 IF (LA .LT. KP1) GO TO 200 6656C 6657 DO 180 M = KP1, LA 6658 H = 0.0D0 6659 ORT(M) = 0.0D0 6660 SCALE = 0.0D0 6661C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) .......... 6662 DO 90 I = M, IGH 6663 90 SCALE = SCALE + DABS(A(I,M-1)) 6664C 6665 IF (SCALE .EQ. 0.0D0) GO TO 180 6666 MP = M + IGH 6667C .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... 6668 DO 100 II = M, IGH 6669 I = MP - II 6670 ORT(I) = A(I,M-1) / SCALE 6671 H = H + ORT(I) * ORT(I) 6672 100 CONTINUE 6673C 6674 G = -DSIGN(DSQRT(H),ORT(M)) 6675 H = H - ORT(M) * G 6676 ORT(M) = ORT(M) - G 6677C .......... FORM (I-(U*UT)/H) * A .......... 6678 DO 130 J = M, N 6679 F = 0.0D0 6680C .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... 6681 DO 110 II = M, IGH 6682 I = MP - II 6683 F = F + ORT(I) * A(I,J) 6684 110 CONTINUE 6685C 6686 F = F / H 6687C 6688 DO 120 I = M, IGH 6689 120 A(I,J) = A(I,J) - F * ORT(I) 6690C 6691 130 CONTINUE 6692C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) .......... 6693 DO 160 I = 1, IGH 6694 F = 0.0D0 6695C .......... FOR J=IGH STEP -1 UNTIL M DO -- .......... 6696 DO 140 JJ = M, IGH 6697 J = MP - JJ 6698 F = F + ORT(J) * A(I,J) 6699 140 CONTINUE 6700C 6701 F = F / H 6702C 6703 DO 150 J = M, IGH 6704 150 A(I,J) = A(I,J) - F * ORT(J) 6705C 6706 160 CONTINUE 6707C 6708 ORT(M) = SCALE * ORT(M) 6709 A(M,M-1) = SCALE * G 6710 180 CONTINUE 6711C 6712 200 RETURN 6713 END 6714 SUBROUTINE ORTRAN(NM,N,LOW,IGH,A,ORT,Z) 6715C 6716 INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1 6717 DOUBLE PRECISION A(NM,IGH),ORT(IGH),Z(NM,N) 6718 DOUBLE PRECISION G 6719C 6720C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTRANS, 6721C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. 6722C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). 6723C 6724C THIS SUBROUTINE ACCUMULATES THE ORTHOGONAL SIMILARITY 6725C TRANSFORMATIONS USED IN THE REDUCTION OF A REAL GENERAL 6726C MATRIX TO UPPER HESSENBERG FORM BY ORTHES. 6727C 6728C ON INPUT 6729C 6730C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 6731C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 6732C DIMENSION STATEMENT. 6733C 6734C N IS THE ORDER OF THE MATRIX. 6735C 6736C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING 6737C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, 6738C SET LOW=1, IGH=N. 6739C 6740C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- 6741C FORMATIONS USED IN THE REDUCTION BY ORTHES 6742C IN ITS STRICT LOWER TRIANGLE. 6743C 6744C ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANS- 6745C FORMATIONS USED IN THE REDUCTION BY ORTHES. 6746C ONLY ELEMENTS LOW THROUGH IGH ARE USED. 6747C 6748C ON OUTPUT 6749C 6750C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE 6751C REDUCTION BY ORTHES. 6752C 6753C ORT HAS BEEN ALTERED. 6754C 6755C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 6756C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 6757C 6758C THIS VERSION DATED AUGUST 1983. 6759C 6760C ------------------------------------------------------------------ 6761C 6762C .......... INITIALIZE Z TO IDENTITY MATRIX .......... 6763 DO 80 J = 1, N 6764C 6765 DO 60 I = 1, N 6766 60 Z(I,J) = 0.0D0 6767C 6768 Z(J,J) = 1.0D0 6769 80 CONTINUE 6770C 6771 KL = IGH - LOW - 1 6772 IF (KL .LT. 1) GO TO 200 6773C .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... 6774 DO 140 MM = 1, KL 6775 MP = IGH - MM 6776 IF (A(MP,MP-1) .EQ. 0.0D0) GO TO 140 6777 MP1 = MP + 1 6778C 6779 DO 100 I = MP1, IGH 6780 100 ORT(I) = A(I,MP-1) 6781C 6782 DO 130 J = MP, IGH 6783 G = 0.0D0 6784C 6785 DO 110 I = MP, IGH 6786 110 G = G + ORT(I) * Z(I,J) 6787C .......... DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHES. 6788C DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW .......... 6789 G = (G / ORT(MP)) / A(MP,MP-1) 6790C 6791 DO 120 I = MP, IGH 6792 120 Z(I,J) = Z(I,J) + G * ORT(I) 6793C 6794 130 CONTINUE 6795C 6796 140 CONTINUE 6797C 6798 200 RETURN 6799 END 6800 SUBROUTINE QZHES(NM,N,A,B,MATZ,Z) 6801C 6802 INTEGER I,J,K,L,N,LB,L1,NM,NK1,NM1,NM2 6803 DOUBLE PRECISION A(NM,N),B(NM,N),Z(NM,N) 6804 DOUBLE PRECISION R,S,T,U1,U2,V1,V2,RHO 6805 LOGICAL MATZ 6806C 6807C THIS SUBROUTINE IS THE FIRST STEP OF THE QZ ALGORITHM 6808C FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS, 6809C SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART. 6810C 6811C THIS SUBROUTINE ACCEPTS A PAIR OF REAL GENERAL MATRICES AND 6812C REDUCES ONE OF THEM TO UPPER HESSENBERG FORM AND THE OTHER 6813C TO UPPER TRIANGULAR FORM USING ORTHOGONAL TRANSFORMATIONS. 6814C IT IS USUALLY FOLLOWED BY QZIT, QZVAL AND, POSSIBLY, QZVEC. 6815C 6816C ON INPUT 6817C 6818C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 6819C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 6820C DIMENSION STATEMENT. 6821C 6822C N IS THE ORDER OF THE MATRICES. 6823C 6824C A CONTAINS A REAL GENERAL MATRIX. 6825C 6826C B CONTAINS A REAL GENERAL MATRIX. 6827C 6828C MATZ SHOULD BE SET TO .TRUE. IF THE RIGHT HAND TRANSFORMATIONS 6829C ARE TO BE ACCUMULATED FOR LATER USE IN COMPUTING 6830C EIGENVECTORS, AND TO .FALSE. OTHERWISE. 6831C 6832C ON OUTPUT 6833C 6834C A HAS BEEN REDUCED TO UPPER HESSENBERG FORM. THE ELEMENTS 6835C BELOW THE FIRST SUBDIAGONAL HAVE BEEN SET TO ZERO. 6836C 6837C B HAS BEEN REDUCED TO UPPER TRIANGULAR FORM. THE ELEMENTS 6838C BELOW THE MAIN DIAGONAL HAVE BEEN SET TO ZERO. 6839C 6840C Z CONTAINS THE PRODUCT OF THE RIGHT HAND TRANSFORMATIONS IF 6841C MATZ HAS BEEN SET TO .TRUE. OTHERWISE, Z IS NOT REFERENCED. 6842C 6843C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 6844C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 6845C 6846C THIS VERSION DATED AUGUST 1983. 6847C 6848C ------------------------------------------------------------------ 6849C 6850C .......... INITIALIZE Z .......... 6851 IF (.NOT. MATZ) GO TO 10 6852C 6853 DO 3 J = 1, N 6854C 6855 DO 2 I = 1, N 6856 Z(I,J) = 0.0D0 6857 2 CONTINUE 6858C 6859 Z(J,J) = 1.0D0 6860 3 CONTINUE 6861C .......... REDUCE B TO UPPER TRIANGULAR FORM .......... 6862 10 IF (N .LE. 1) GO TO 170 6863 NM1 = N - 1 6864C 6865 DO 100 L = 1, NM1 6866 L1 = L + 1 6867 S = 0.0D0 6868C 6869 DO 20 I = L1, N 6870 S = S + DABS(B(I,L)) 6871 20 CONTINUE 6872C 6873 IF (S .EQ. 0.0D0) GO TO 100 6874 S = S + DABS(B(L,L)) 6875 R = 0.0D0 6876C 6877 DO 25 I = L, N 6878 B(I,L) = B(I,L) / S 6879 R = R + B(I,L)**2 6880 25 CONTINUE 6881C 6882 R = DSIGN(DSQRT(R),B(L,L)) 6883 B(L,L) = B(L,L) + R 6884 RHO = R * B(L,L) 6885C 6886 DO 50 J = L1, N 6887 T = 0.0D0 6888C 6889 DO 30 I = L, N 6890 T = T + B(I,L) * B(I,J) 6891 30 CONTINUE 6892C 6893 T = -T / RHO 6894C 6895 DO 40 I = L, N 6896 B(I,J) = B(I,J) + T * B(I,L) 6897 40 CONTINUE 6898C 6899 50 CONTINUE 6900C 6901 DO 80 J = 1, N 6902 T = 0.0D0 6903C 6904 DO 60 I = L, N 6905 T = T + B(I,L) * A(I,J) 6906 60 CONTINUE 6907C 6908 T = -T / RHO 6909C 6910 DO 70 I = L, N 6911 A(I,J) = A(I,J) + T * B(I,L) 6912 70 CONTINUE 6913C 6914 80 CONTINUE 6915C 6916 B(L,L) = -S * R 6917C 6918 DO 90 I = L1, N 6919 B(I,L) = 0.0D0 6920 90 CONTINUE 6921C 6922 100 CONTINUE 6923C .......... REDUCE A TO UPPER HESSENBERG FORM, WHILE 6924C KEEPING B TRIANGULAR .......... 6925 IF (N .EQ. 2) GO TO 170 6926 NM2 = N - 2 6927C 6928 DO 160 K = 1, NM2 6929 NK1 = NM1 - K 6930C .......... FOR L=N-1 STEP -1 UNTIL K+1 DO -- .......... 6931 DO 150 LB = 1, NK1 6932 L = N - LB 6933 L1 = L + 1 6934C .......... ZERO A(L+1,K) .......... 6935 S = DABS(A(L,K)) + DABS(A(L1,K)) 6936 IF (S .EQ. 0.0D0) GO TO 150 6937 U1 = A(L,K) / S 6938 U2 = A(L1,K) / S 6939 R = DSIGN(DSQRT(U1*U1+U2*U2),U1) 6940 V1 = -(U1 + R) / R 6941 V2 = -U2 / R 6942 U2 = V2 / V1 6943C 6944 DO 110 J = K, N 6945 T = A(L,J) + U2 * A(L1,J) 6946 A(L,J) = A(L,J) + T * V1 6947 A(L1,J) = A(L1,J) + T * V2 6948 110 CONTINUE 6949C 6950 A(L1,K) = 0.0D0 6951C 6952 DO 120 J = L, N 6953 T = B(L,J) + U2 * B(L1,J) 6954 B(L,J) = B(L,J) + T * V1 6955 B(L1,J) = B(L1,J) + T * V2 6956 120 CONTINUE 6957C .......... ZERO B(L+1,L) .......... 6958 S = DABS(B(L1,L1)) + DABS(B(L1,L)) 6959 IF (S .EQ. 0.0D0) GO TO 150 6960 U1 = B(L1,L1) / S 6961 U2 = B(L1,L) / S 6962 R = DSIGN(DSQRT(U1*U1+U2*U2),U1) 6963 V1 = -(U1 + R) / R 6964 V2 = -U2 / R 6965 U2 = V2 / V1 6966C 6967 DO 130 I = 1, L1 6968 T = B(I,L1) + U2 * B(I,L) 6969 B(I,L1) = B(I,L1) + T * V1 6970 B(I,L) = B(I,L) + T * V2 6971 130 CONTINUE 6972C 6973 B(L1,L) = 0.0D0 6974C 6975 DO 140 I = 1, N 6976 T = A(I,L1) + U2 * A(I,L) 6977 A(I,L1) = A(I,L1) + T * V1 6978 A(I,L) = A(I,L) + T * V2 6979 140 CONTINUE 6980C 6981 IF (.NOT. MATZ) GO TO 150 6982C 6983 DO 145 I = 1, N 6984 T = Z(I,L1) + U2 * Z(I,L) 6985 Z(I,L1) = Z(I,L1) + T * V1 6986 Z(I,L) = Z(I,L) + T * V2 6987 145 CONTINUE 6988C 6989 150 CONTINUE 6990C 6991 160 CONTINUE 6992C 6993 170 RETURN 6994 END 6995 SUBROUTINE QZIT(NM,N,A,B,EPS1,MATZ,Z,IERR) 6996C 6997 INTEGER I,J,K,L,N,EN,K1,K2,LD,LL,L1,NA,NM,ISH,ITN,ITS,KM1,LM1, 6998 X ENM2,IERR,LOR1,ENORN 6999 DOUBLE PRECISION A(NM,N),B(NM,N),Z(NM,N) 7000 DOUBLE PRECISION R,S,T,A1,A2,A3,EP,SH,U1,U2,U3,V1,V2,V3,ANI,A11, 7001 X A12,A21,A22,A33,A34,A43,A44,BNI,B11,B12,B22,B33,B34, 7002 X B44,EPSA,EPSB,EPS1,ANORM,BNORM,EPSLON 7003 LOGICAL MATZ,NOTLAS 7004C 7005C THIS SUBROUTINE IS THE SECOND STEP OF THE QZ ALGORITHM 7006C FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS, 7007C SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART, 7008C AS MODIFIED IN TECHNICAL NOTE NASA TN D-7305(1973) BY WARD. 7009C 7010C THIS SUBROUTINE ACCEPTS A PAIR OF REAL MATRICES, ONE OF THEM 7011C IN UPPER HESSENBERG FORM AND THE OTHER IN UPPER TRIANGULAR FORM. 7012C IT REDUCES THE HESSENBERG MATRIX TO QUASI-TRIANGULAR FORM USING 7013C ORTHOGONAL TRANSFORMATIONS WHILE MAINTAINING THE TRIANGULAR FORM 7014C OF THE OTHER MATRIX. IT IS USUALLY PRECEDED BY QZHES AND 7015C FOLLOWED BY QZVAL AND, POSSIBLY, QZVEC. 7016C 7017C ON INPUT 7018C 7019C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 7020C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 7021C DIMENSION STATEMENT. 7022C 7023C N IS THE ORDER OF THE MATRICES. 7024C 7025C A CONTAINS A REAL UPPER HESSENBERG MATRIX. 7026C 7027C B CONTAINS A REAL UPPER TRIANGULAR MATRIX. 7028C 7029C EPS1 IS A TOLERANCE USED TO DETERMINE NEGLIGIBLE ELEMENTS. 7030C EPS1 = 0.0 (OR NEGATIVE) MAY BE INPUT, IN WHICH CASE AN 7031C ELEMENT WILL BE NEGLECTED ONLY IF IT IS LESS THAN ROUNDOFF 7032C ERROR TIMES THE NORM OF ITS MATRIX. IF THE INPUT EPS1 IS 7033C POSITIVE, THEN AN ELEMENT WILL BE CONSIDERED NEGLIGIBLE 7034C IF IT IS LESS THAN EPS1 TIMES THE NORM OF ITS MATRIX. A 7035C POSITIVE VALUE OF EPS1 MAY RESULT IN FASTER EXECUTION, 7036C BUT LESS ACCURATE RESULTS. 7037C 7038C MATZ SHOULD BE SET TO .TRUE. IF THE RIGHT HAND TRANSFORMATIONS 7039C ARE TO BE ACCUMULATED FOR LATER USE IN COMPUTING 7040C EIGENVECTORS, AND TO .FALSE. OTHERWISE. 7041C 7042C Z CONTAINS, IF MATZ HAS BEEN SET TO .TRUE., THE 7043C TRANSFORMATION MATRIX PRODUCED IN THE REDUCTION 7044C BY QZHES, IF PERFORMED, OR ELSE THE IDENTITY MATRIX. 7045C IF MATZ HAS BEEN SET TO .FALSE., Z IS NOT REFERENCED. 7046C 7047C ON OUTPUT 7048C 7049C A HAS BEEN REDUCED TO QUASI-TRIANGULAR FORM. THE ELEMENTS 7050C BELOW THE FIRST SUBDIAGONAL ARE STILL ZERO AND NO TWO 7051C CONSECUTIVE SUBDIAGONAL ELEMENTS ARE NONZERO. 7052C 7053C B IS STILL IN UPPER TRIANGULAR FORM, ALTHOUGH ITS ELEMENTS 7054C HAVE BEEN ALTERED. THE LOCATION B(N,1) IS USED TO STORE 7055C EPS1 TIMES THE NORM OF B FOR LATER USE BY QZVAL AND QZVEC. 7056C 7057C Z CONTAINS THE PRODUCT OF THE RIGHT HAND TRANSFORMATIONS 7058C (FOR BOTH STEPS) IF MATZ HAS BEEN SET TO .TRUE.. 7059C 7060C IERR IS SET TO 7061C ZERO FOR NORMAL RETURN, 7062C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED 7063C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. 7064C 7065C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 7066C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 7067C 7068C THIS VERSION DATED AUGUST 1983. 7069C 7070C ------------------------------------------------------------------ 7071C 7072 IERR = 0 7073C .......... COMPUTE EPSA,EPSB .......... 7074 ANORM = 0.0D0 7075 BNORM = 0.0D0 7076C 7077 DO 30 I = 1, N 7078 ANI = 0.0D0 7079 IF (I .NE. 1) ANI = DABS(A(I,I-1)) 7080 BNI = 0.0D0 7081C 7082 DO 20 J = I, N 7083 ANI = ANI + DABS(A(I,J)) 7084 BNI = BNI + DABS(B(I,J)) 7085 20 CONTINUE 7086C 7087 IF (ANI .GT. ANORM) ANORM = ANI 7088 IF (BNI .GT. BNORM) BNORM = BNI 7089 30 CONTINUE 7090C 7091 IF (ANORM .EQ. 0.0D0) ANORM = 1.0D0 7092 IF (BNORM .EQ. 0.0D0) BNORM = 1.0D0 7093 EP = EPS1 7094 IF (EP .GT. 0.0D0) GO TO 50 7095C .......... USE ROUNDOFF LEVEL IF EPS1 IS ZERO .......... 7096 EP = EPSLON(1.0D0) 7097 50 EPSA = EP * ANORM 7098 EPSB = EP * BNORM 7099C .......... REDUCE A TO QUASI-TRIANGULAR FORM, WHILE 7100C KEEPING B TRIANGULAR .......... 7101 LOR1 = 1 7102 ENORN = N 7103 EN = N 7104 ITN = 30*N 7105C .......... BEGIN QZ STEP .......... 7106 60 IF (EN .LE. 2) GO TO 1001 7107 IF (.NOT. MATZ) ENORN = EN 7108 ITS = 0 7109 NA = EN - 1 7110 ENM2 = NA - 1 7111 70 ISH = 2 7112C .......... CHECK FOR CONVERGENCE OR REDUCIBILITY. 7113C FOR L=EN STEP -1 UNTIL 1 DO -- .......... 7114 DO 80 LL = 1, EN 7115 LM1 = EN - LL 7116 L = LM1 + 1 7117 IF (L .EQ. 1) GO TO 95 7118 IF (DABS(A(L,LM1)) .LE. EPSA) GO TO 90 7119 80 CONTINUE 7120C 7121 90 A(L,LM1) = 0.0D0 7122 IF (L .LT. NA) GO TO 95 7123C .......... 1-BY-1 OR 2-BY-2 BLOCK ISOLATED .......... 7124 EN = LM1 7125 GO TO 60 7126C .......... CHECK FOR SMALL TOP OF B .......... 7127 95 LD = L 7128 100 L1 = L + 1 7129 B11 = B(L,L) 7130 IF (DABS(B11) .GT. EPSB) GO TO 120 7131 B(L,L) = 0.0D0 7132 S = DABS(A(L,L)) + DABS(A(L1,L)) 7133 U1 = A(L,L) / S 7134 U2 = A(L1,L) / S 7135 R = DSIGN(DSQRT(U1*U1+U2*U2),U1) 7136 V1 = -(U1 + R) / R 7137 V2 = -U2 / R 7138 U2 = V2 / V1 7139C 7140 DO 110 J = L, ENORN 7141 T = A(L,J) + U2 * A(L1,J) 7142 A(L,J) = A(L,J) + T * V1 7143 A(L1,J) = A(L1,J) + T * V2 7144 T = B(L,J) + U2 * B(L1,J) 7145 B(L,J) = B(L,J) + T * V1 7146 B(L1,J) = B(L1,J) + T * V2 7147 110 CONTINUE 7148C 7149 IF (L .NE. 1) A(L,LM1) = -A(L,LM1) 7150 LM1 = L 7151 L = L1 7152 GO TO 90 7153 120 A11 = A(L,L) / B11 7154 A21 = A(L1,L) / B11 7155 IF (ISH .EQ. 1) GO TO 140 7156C .......... ITERATION STRATEGY .......... 7157 IF (ITN .EQ. 0) GO TO 1000 7158 IF (ITS .EQ. 10) GO TO 155 7159C .......... DETERMINE TYPE OF SHIFT .......... 7160 B22 = B(L1,L1) 7161 IF (DABS(B22) .LT. EPSB) B22 = EPSB 7162 B33 = B(NA,NA) 7163 IF (DABS(B33) .LT. EPSB) B33 = EPSB 7164 B44 = B(EN,EN) 7165 IF (DABS(B44) .LT. EPSB) B44 = EPSB 7166 A33 = A(NA,NA) / B33 7167 A34 = A(NA,EN) / B44 7168 A43 = A(EN,NA) / B33 7169 A44 = A(EN,EN) / B44 7170 B34 = B(NA,EN) / B44 7171 T = 0.5D0 * (A43 * B34 - A33 - A44) 7172 R = T * T + A34 * A43 - A33 * A44 7173 IF (R .LT. 0.0D0) GO TO 150 7174C .......... DETERMINE SINGLE SHIFT ZEROTH COLUMN OF A .......... 7175 ISH = 1 7176 R = DSQRT(R) 7177 SH = -T + R 7178 S = -T - R 7179 IF (DABS(S-A44) .LT. DABS(SH-A44)) SH = S 7180C .......... LOOK FOR TWO CONSECUTIVE SMALL 7181C SUB-DIAGONAL ELEMENTS OF A. 7182C FOR L=EN-2 STEP -1 UNTIL LD DO -- .......... 7183 DO 130 LL = LD, ENM2 7184 L = ENM2 + LD - LL 7185 IF (L .EQ. LD) GO TO 140 7186 LM1 = L - 1 7187 L1 = L + 1 7188 T = A(L,L) 7189 IF (DABS(B(L,L)) .GT. EPSB) T = T - SH * B(L,L) 7190 IF (DABS(A(L,LM1)) .LE. DABS(T/A(L1,L)) * EPSA) GO TO 100 7191 130 CONTINUE 7192C 7193 140 A1 = A11 - SH 7194 A2 = A21 7195 IF (L .NE. LD) A(L,LM1) = -A(L,LM1) 7196 GO TO 160 7197C .......... DETERMINE DOUBLE SHIFT ZEROTH COLUMN OF A .......... 7198 150 A12 = A(L,L1) / B22 7199 A22 = A(L1,L1) / B22 7200 B12 = B(L,L1) / B22 7201 A1 = ((A33 - A11) * (A44 - A11) - A34 * A43 + A43 * B34 * A11) 7202 X / A21 + A12 - A11 * B12 7203 A2 = (A22 - A11) - A21 * B12 - (A33 - A11) - (A44 - A11) 7204 X + A43 * B34 7205 A3 = A(L1+1,L1) / B22 7206 GO TO 160 7207C .......... AD HOC SHIFT .......... 7208 155 A1 = 0.0D0 7209 A2 = 1.0D0 7210 A3 = 1.1605D0 7211 160 ITS = ITS + 1 7212 ITN = ITN - 1 7213 IF (.NOT. MATZ) LOR1 = LD 7214C .......... MAIN LOOP .......... 7215 DO 260 K = L, NA 7216 NOTLAS = K .NE. NA .AND. ISH .EQ. 2 7217 K1 = K + 1 7218 K2 = K + 2 7219 KM1 = MAX0(K-1,L) 7220 LL = MIN0(EN,K1+ISH) 7221 IF (NOTLAS) GO TO 190 7222C .......... ZERO A(K+1,K-1) .......... 7223 IF (K .EQ. L) GO TO 170 7224 A1 = A(K,KM1) 7225 A2 = A(K1,KM1) 7226 170 S = DABS(A1) + DABS(A2) 7227 IF (S .EQ. 0.0D0) GO TO 70 7228 U1 = A1 / S 7229 U2 = A2 / S 7230 R = DSIGN(DSQRT(U1*U1+U2*U2),U1) 7231 V1 = -(U1 + R) / R 7232 V2 = -U2 / R 7233 U2 = V2 / V1 7234C 7235 DO 180 J = KM1, ENORN 7236 T = A(K,J) + U2 * A(K1,J) 7237 A(K,J) = A(K,J) + T * V1 7238 A(K1,J) = A(K1,J) + T * V2 7239 T = B(K,J) + U2 * B(K1,J) 7240 B(K,J) = B(K,J) + T * V1 7241 B(K1,J) = B(K1,J) + T * V2 7242 180 CONTINUE 7243C 7244 IF (K .NE. L) A(K1,KM1) = 0.0D0 7245 GO TO 240 7246C .......... ZERO A(K+1,K-1) AND A(K+2,K-1) .......... 7247 190 IF (K .EQ. L) GO TO 200 7248 A1 = A(K,KM1) 7249 A2 = A(K1,KM1) 7250 A3 = A(K2,KM1) 7251 200 S = DABS(A1) + DABS(A2) + DABS(A3) 7252 IF (S .EQ. 0.0D0) GO TO 260 7253 U1 = A1 / S 7254 U2 = A2 / S 7255 U3 = A3 / S 7256 R = DSIGN(DSQRT(U1*U1+U2*U2+U3*U3),U1) 7257 V1 = -(U1 + R) / R 7258 V2 = -U2 / R 7259 V3 = -U3 / R 7260 U2 = V2 / V1 7261 U3 = V3 / V1 7262C 7263 DO 210 J = KM1, ENORN 7264 T = A(K,J) + U2 * A(K1,J) + U3 * A(K2,J) 7265 A(K,J) = A(K,J) + T * V1 7266 A(K1,J) = A(K1,J) + T * V2 7267 A(K2,J) = A(K2,J) + T * V3 7268 T = B(K,J) + U2 * B(K1,J) + U3 * B(K2,J) 7269 B(K,J) = B(K,J) + T * V1 7270 B(K1,J) = B(K1,J) + T * V2 7271 B(K2,J) = B(K2,J) + T * V3 7272 210 CONTINUE 7273C 7274 IF (K .EQ. L) GO TO 220 7275 A(K1,KM1) = 0.0D0 7276 A(K2,KM1) = 0.0D0 7277C .......... ZERO B(K+2,K+1) AND B(K+2,K) .......... 7278 220 S = DABS(B(K2,K2)) + DABS(B(K2,K1)) + DABS(B(K2,K)) 7279 IF (S .EQ. 0.0D0) GO TO 240 7280 U1 = B(K2,K2) / S 7281 U2 = B(K2,K1) / S 7282 U3 = B(K2,K) / S 7283 R = DSIGN(DSQRT(U1*U1+U2*U2+U3*U3),U1) 7284 V1 = -(U1 + R) / R 7285 V2 = -U2 / R 7286 V3 = -U3 / R 7287 U2 = V2 / V1 7288 U3 = V3 / V1 7289C 7290 DO 230 I = LOR1, LL 7291 T = A(I,K2) + U2 * A(I,K1) + U3 * A(I,K) 7292 A(I,K2) = A(I,K2) + T * V1 7293 A(I,K1) = A(I,K1) + T * V2 7294 A(I,K) = A(I,K) + T * V3 7295 T = B(I,K2) + U2 * B(I,K1) + U3 * B(I,K) 7296 B(I,K2) = B(I,K2) + T * V1 7297 B(I,K1) = B(I,K1) + T * V2 7298 B(I,K) = B(I,K) + T * V3 7299 230 CONTINUE 7300C 7301 B(K2,K) = 0.0D0 7302 B(K2,K1) = 0.0D0 7303 IF (.NOT. MATZ) GO TO 240 7304C 7305 DO 235 I = 1, N 7306 T = Z(I,K2) + U2 * Z(I,K1) + U3 * Z(I,K) 7307 Z(I,K2) = Z(I,K2) + T * V1 7308 Z(I,K1) = Z(I,K1) + T * V2 7309 Z(I,K) = Z(I,K) + T * V3 7310 235 CONTINUE 7311C .......... ZERO B(K+1,K) .......... 7312 240 S = DABS(B(K1,K1)) + DABS(B(K1,K)) 7313 IF (S .EQ. 0.0D0) GO TO 260 7314 U1 = B(K1,K1) / S 7315 U2 = B(K1,K) / S 7316 R = DSIGN(DSQRT(U1*U1+U2*U2),U1) 7317 V1 = -(U1 + R) / R 7318 V2 = -U2 / R 7319 U2 = V2 / V1 7320C 7321 DO 250 I = LOR1, LL 7322 T = A(I,K1) + U2 * A(I,K) 7323 A(I,K1) = A(I,K1) + T * V1 7324 A(I,K) = A(I,K) + T * V2 7325 T = B(I,K1) + U2 * B(I,K) 7326 B(I,K1) = B(I,K1) + T * V1 7327 B(I,K) = B(I,K) + T * V2 7328 250 CONTINUE 7329C 7330 B(K1,K) = 0.0D0 7331 IF (.NOT. MATZ) GO TO 260 7332C 7333 DO 255 I = 1, N 7334 T = Z(I,K1) + U2 * Z(I,K) 7335 Z(I,K1) = Z(I,K1) + T * V1 7336 Z(I,K) = Z(I,K) + T * V2 7337 255 CONTINUE 7338C 7339 260 CONTINUE 7340C .......... END QZ STEP .......... 7341 GO TO 70 7342C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT 7343C CONVERGED AFTER 30*N ITERATIONS .......... 7344 1000 IERR = EN 7345C .......... SAVE EPSB FOR USE BY QZVAL AND QZVEC .......... 7346 1001 IF (N .GT. 1) B(N,1) = EPSB 7347 RETURN 7348 END 7349 SUBROUTINE QZVAL(NM,N,A,B,ALFR,ALFI,BETA,MATZ,Z) 7350C 7351 INTEGER I,J,N,EN,NA,NM,NN,ISW 7352 DOUBLE PRECISION A(NM,N),B(NM,N),ALFR(N),ALFI(N),BETA(N),Z(NM,N) 7353 DOUBLE PRECISION C,D,E,R,S,T,AN,A1,A2,BN,CQ,CZ,DI,DR,EI,TI,TR,U1, 7354 X U2,V1,V2,A1I,A11,A12,A2I,A21,A22,B11,B12,B22,SQI,SQR, 7355 X SSI,SSR,SZI,SZR,A11I,A11R,A12I,A12R,A22I,A22R,EPSB 7356 LOGICAL MATZ 7357C 7358C THIS SUBROUTINE IS THE THIRD STEP OF THE QZ ALGORITHM 7359C FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS, 7360C SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART. 7361C 7362C THIS SUBROUTINE ACCEPTS A PAIR OF REAL MATRICES, ONE OF THEM 7363C IN QUASI-TRIANGULAR FORM AND THE OTHER IN UPPER TRIANGULAR FORM. 7364C IT REDUCES THE QUASI-TRIANGULAR MATRIX FURTHER, SO THAT ANY 7365C REMAINING 2-BY-2 BLOCKS CORRESPOND TO PAIRS OF COMPLEX 7366C EIGENVALUES, AND RETURNS QUANTITIES WHOSE RATIOS GIVE THE 7367C GENERALIZED EIGENVALUES. IT IS USUALLY PRECEDED BY QZHES 7368C AND QZIT AND MAY BE FOLLOWED BY QZVEC. 7369C 7370C ON INPUT 7371C 7372C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 7373C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 7374C DIMENSION STATEMENT. 7375C 7376C N IS THE ORDER OF THE MATRICES. 7377C 7378C A CONTAINS A REAL UPPER QUASI-TRIANGULAR MATRIX. 7379C 7380C B CONTAINS A REAL UPPER TRIANGULAR MATRIX. IN ADDITION, 7381C LOCATION B(N,1) CONTAINS THE TOLERANCE QUANTITY (EPSB) 7382C COMPUTED AND SAVED IN QZIT. 7383C 7384C MATZ SHOULD BE SET TO .TRUE. IF THE RIGHT HAND TRANSFORMATIONS 7385C ARE TO BE ACCUMULATED FOR LATER USE IN COMPUTING 7386C EIGENVECTORS, AND TO .FALSE. OTHERWISE. 7387C 7388C Z CONTAINS, IF MATZ HAS BEEN SET TO .TRUE., THE 7389C TRANSFORMATION MATRIX PRODUCED IN THE REDUCTIONS BY QZHES 7390C AND QZIT, IF PERFORMED, OR ELSE THE IDENTITY MATRIX. 7391C IF MATZ HAS BEEN SET TO .FALSE., Z IS NOT REFERENCED. 7392C 7393C ON OUTPUT 7394C 7395C A HAS BEEN REDUCED FURTHER TO A QUASI-TRIANGULAR MATRIX 7396C IN WHICH ALL NONZERO SUBDIAGONAL ELEMENTS CORRESPOND TO 7397C PAIRS OF COMPLEX EIGENVALUES. 7398C 7399C B IS STILL IN UPPER TRIANGULAR FORM, ALTHOUGH ITS ELEMENTS 7400C HAVE BEEN ALTERED. B(N,1) IS UNALTERED. 7401C 7402C ALFR AND ALFI CONTAIN THE REAL AND IMAGINARY PARTS OF THE 7403C DIAGONAL ELEMENTS OF THE TRIANGULAR MATRIX THAT WOULD BE 7404C OBTAINED IF A WERE REDUCED COMPLETELY TO TRIANGULAR FORM 7405C BY UNITARY TRANSFORMATIONS. NON-ZERO VALUES OF ALFI OCCUR 7406C IN PAIRS, THE FIRST MEMBER POSITIVE AND THE SECOND NEGATIVE. 7407C 7408C BETA CONTAINS THE DIAGONAL ELEMENTS OF THE CORRESPONDING B, 7409C NORMALIZED TO BE REAL AND NON-NEGATIVE. THE GENERALIZED 7410C EIGENVALUES ARE THEN THE RATIOS ((ALFR+I*ALFI)/BETA). 7411C 7412C Z CONTAINS THE PRODUCT OF THE RIGHT HAND TRANSFORMATIONS 7413C (FOR ALL THREE STEPS) IF MATZ HAS BEEN SET TO .TRUE. 7414C 7415C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 7416C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 7417C 7418C THIS VERSION DATED AUGUST 1983. 7419C 7420C ------------------------------------------------------------------ 7421C 7422 EPSB = B(N,1) 7423 ISW = 1 7424C .......... FIND EIGENVALUES OF QUASI-TRIANGULAR MATRICES. 7425C FOR EN=N STEP -1 UNTIL 1 DO -- .......... 7426 DO 510 NN = 1, N 7427 EN = N + 1 - NN 7428 NA = EN - 1 7429 IF (ISW .EQ. 2) GO TO 505 7430 IF (EN .EQ. 1) GO TO 410 7431 IF (A(EN,NA) .NE. 0.0D0) GO TO 420 7432C .......... 1-BY-1 BLOCK, ONE REAL ROOT .......... 7433 410 ALFR(EN) = A(EN,EN) 7434 IF (B(EN,EN) .LT. 0.0D0) ALFR(EN) = -ALFR(EN) 7435 BETA(EN) = DABS(B(EN,EN)) 7436 ALFI(EN) = 0.0D0 7437 GO TO 510 7438C .......... 2-BY-2 BLOCK .......... 7439 420 IF (DABS(B(NA,NA)) .LE. EPSB) GO TO 455 7440 IF (DABS(B(EN,EN)) .GT. EPSB) GO TO 430 7441 A1 = A(EN,EN) 7442 A2 = A(EN,NA) 7443 BN = 0.0D0 7444 GO TO 435 7445 430 AN = DABS(A(NA,NA)) + DABS(A(NA,EN)) + DABS(A(EN,NA)) 7446 X + DABS(A(EN,EN)) 7447 BN = DABS(B(NA,NA)) + DABS(B(NA,EN)) + DABS(B(EN,EN)) 7448 A11 = A(NA,NA) / AN 7449 A12 = A(NA,EN) / AN 7450 A21 = A(EN,NA) / AN 7451 A22 = A(EN,EN) / AN 7452 B11 = B(NA,NA) / BN 7453 B12 = B(NA,EN) / BN 7454 B22 = B(EN,EN) / BN 7455 E = A11 / B11 7456 EI = A22 / B22 7457 S = A21 / (B11 * B22) 7458 T = (A22 - E * B22) / B22 7459 IF (DABS(E) .LE. DABS(EI)) GO TO 431 7460 E = EI 7461 T = (A11 - E * B11) / B11 7462 431 C = 0.5D0 * (T - S * B12) 7463 D = C * C + S * (A12 - E * B12) 7464 IF (D .LT. 0.0D0) GO TO 480 7465C .......... TWO REAL ROOTS. 7466C ZERO BOTH A(EN,NA) AND B(EN,NA) .......... 7467 E = E + (C + DSIGN(DSQRT(D),C)) 7468 A11 = A11 - E * B11 7469 A12 = A12 - E * B12 7470 A22 = A22 - E * B22 7471 IF (DABS(A11) + DABS(A12) .LT. 7472 X DABS(A21) + DABS(A22)) GO TO 432 7473 A1 = A12 7474 A2 = A11 7475 GO TO 435 7476 432 A1 = A22 7477 A2 = A21 7478C .......... CHOOSE AND APPLY REAL Z .......... 7479 435 S = DABS(A1) + DABS(A2) 7480 U1 = A1 / S 7481 U2 = A2 / S 7482 R = DSIGN(DSQRT(U1*U1+U2*U2),U1) 7483 V1 = -(U1 + R) / R 7484 V2 = -U2 / R 7485 U2 = V2 / V1 7486C 7487 DO 440 I = 1, EN 7488 T = A(I,EN) + U2 * A(I,NA) 7489 A(I,EN) = A(I,EN) + T * V1 7490 A(I,NA) = A(I,NA) + T * V2 7491 T = B(I,EN) + U2 * B(I,NA) 7492 B(I,EN) = B(I,EN) + T * V1 7493 B(I,NA) = B(I,NA) + T * V2 7494 440 CONTINUE 7495C 7496 IF (.NOT. MATZ) GO TO 450 7497C 7498 DO 445 I = 1, N 7499 T = Z(I,EN) + U2 * Z(I,NA) 7500 Z(I,EN) = Z(I,EN) + T * V1 7501 Z(I,NA) = Z(I,NA) + T * V2 7502 445 CONTINUE 7503C 7504 450 IF (BN .EQ. 0.0D0) GO TO 475 7505 IF (AN .LT. DABS(E) * BN) GO TO 455 7506 A1 = B(NA,NA) 7507 A2 = B(EN,NA) 7508 GO TO 460 7509 455 A1 = A(NA,NA) 7510 A2 = A(EN,NA) 7511C .......... CHOOSE AND APPLY REAL Q .......... 7512 460 S = DABS(A1) + DABS(A2) 7513 IF (S .EQ. 0.0D0) GO TO 475 7514 U1 = A1 / S 7515 U2 = A2 / S 7516 R = DSIGN(DSQRT(U1*U1+U2*U2),U1) 7517 V1 = -(U1 + R) / R 7518 V2 = -U2 / R 7519 U2 = V2 / V1 7520C 7521 DO 470 J = NA, N 7522 T = A(NA,J) + U2 * A(EN,J) 7523 A(NA,J) = A(NA,J) + T * V1 7524 A(EN,J) = A(EN,J) + T * V2 7525 T = B(NA,J) + U2 * B(EN,J) 7526 B(NA,J) = B(NA,J) + T * V1 7527 B(EN,J) = B(EN,J) + T * V2 7528 470 CONTINUE 7529C 7530 475 A(EN,NA) = 0.0D0 7531 B(EN,NA) = 0.0D0 7532 ALFR(NA) = A(NA,NA) 7533 ALFR(EN) = A(EN,EN) 7534 IF (B(NA,NA) .LT. 0.0D0) ALFR(NA) = -ALFR(NA) 7535 IF (B(EN,EN) .LT. 0.0D0) ALFR(EN) = -ALFR(EN) 7536 BETA(NA) = DABS(B(NA,NA)) 7537 BETA(EN) = DABS(B(EN,EN)) 7538 ALFI(EN) = 0.0D0 7539 ALFI(NA) = 0.0D0 7540 GO TO 505 7541C .......... TWO COMPLEX ROOTS .......... 7542 480 E = E + C 7543 EI = DSQRT(-D) 7544 A11R = A11 - E * B11 7545 A11I = EI * B11 7546 A12R = A12 - E * B12 7547 A12I = EI * B12 7548 A22R = A22 - E * B22 7549 A22I = EI * B22 7550 IF (DABS(A11R) + DABS(A11I) + DABS(A12R) + DABS(A12I) .LT. 7551 X DABS(A21) + DABS(A22R) + DABS(A22I)) GO TO 482 7552 A1 = A12R 7553 A1I = A12I 7554 A2 = -A11R 7555 A2I = -A11I 7556 GO TO 485 7557 482 A1 = A22R 7558 A1I = A22I 7559 A2 = -A21 7560 A2I = 0.0D0 7561C .......... CHOOSE COMPLEX Z .......... 7562 485 CZ = DSQRT(A1*A1+A1I*A1I) 7563 IF (CZ .EQ. 0.0D0) GO TO 487 7564 SZR = (A1 * A2 + A1I * A2I) / CZ 7565 SZI = (A1 * A2I - A1I * A2) / CZ 7566 R = DSQRT(CZ*CZ+SZR*SZR+SZI*SZI) 7567 CZ = CZ / R 7568 SZR = SZR / R 7569 SZI = SZI / R 7570 GO TO 490 7571 487 SZR = 1.0D0 7572 SZI = 0.0D0 7573 490 IF (AN .LT. (DABS(E) + EI) * BN) GO TO 492 7574 A1 = CZ * B11 + SZR * B12 7575 A1I = SZI * B12 7576 A2 = SZR * B22 7577 A2I = SZI * B22 7578 GO TO 495 7579 492 A1 = CZ * A11 + SZR * A12 7580 A1I = SZI * A12 7581 A2 = CZ * A21 + SZR * A22 7582 A2I = SZI * A22 7583C .......... CHOOSE COMPLEX Q .......... 7584 495 CQ = DSQRT(A1*A1+A1I*A1I) 7585 IF (CQ .EQ. 0.0D0) GO TO 497 7586 SQR = (A1 * A2 + A1I * A2I) / CQ 7587 SQI = (A1 * A2I - A1I * A2) / CQ 7588 R = DSQRT(CQ*CQ+SQR*SQR+SQI*SQI) 7589 CQ = CQ / R 7590 SQR = SQR / R 7591 SQI = SQI / R 7592 GO TO 500 7593 497 SQR = 1.0D0 7594 SQI = 0.0D0 7595C .......... COMPUTE DIAGONAL ELEMENTS THAT WOULD RESULT 7596C IF TRANSFORMATIONS WERE APPLIED .......... 7597 500 SSR = SQR * SZR + SQI * SZI 7598 SSI = SQR * SZI - SQI * SZR 7599 I = 1 7600 TR = CQ * CZ * A11 + CQ * SZR * A12 + SQR * CZ * A21 7601 X + SSR * A22 7602 TI = CQ * SZI * A12 - SQI * CZ * A21 + SSI * A22 7603 DR = CQ * CZ * B11 + CQ * SZR * B12 + SSR * B22 7604 DI = CQ * SZI * B12 + SSI * B22 7605 GO TO 503 7606 502 I = 2 7607 TR = SSR * A11 - SQR * CZ * A12 - CQ * SZR * A21 7608 X + CQ * CZ * A22 7609 TI = -SSI * A11 - SQI * CZ * A12 + CQ * SZI * A21 7610 DR = SSR * B11 - SQR * CZ * B12 + CQ * CZ * B22 7611 DI = -SSI * B11 - SQI * CZ * B12 7612 503 T = TI * DR - TR * DI 7613 J = NA 7614 IF (T .LT. 0.0D0) J = EN 7615 R = DSQRT(DR*DR+DI*DI) 7616 BETA(J) = BN * R 7617 ALFR(J) = AN * (TR * DR + TI * DI) / R 7618 ALFI(J) = AN * T / R 7619 IF (I .EQ. 1) GO TO 502 7620 505 ISW = 3 - ISW 7621 510 CONTINUE 7622 B(N,1) = EPSB 7623C 7624 RETURN 7625 END 7626 SUBROUTINE QZVEC(NM,N,A,B,ALFR,ALFI,BETA,Z) 7627C 7628 INTEGER I,J,K,M,N,EN,II,JJ,NA,NM,NN,ISW,ENM2 7629 DOUBLE PRECISION A(NM,N),B(NM,N),ALFR(N),ALFI(N),BETA(N),Z(NM,N) 7630 DOUBLE PRECISION D,Q,R,S,T,W,X,Y,DI,DR,RA,RR,SA,TI,TR,T1,T2,W1,X1, 7631 X ZZ,Z1,ALFM,ALMI,ALMR,BETM,EPSB 7632C 7633C THIS SUBROUTINE IS THE OPTIONAL FOURTH STEP OF THE QZ ALGORITHM 7634C FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS, 7635C SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART. 7636C 7637C THIS SUBROUTINE ACCEPTS A PAIR OF REAL MATRICES, ONE OF THEM IN 7638C QUASI-TRIANGULAR FORM (IN WHICH EACH 2-BY-2 BLOCK CORRESPONDS TO 7639C A PAIR OF COMPLEX EIGENVALUES) AND THE OTHER IN UPPER TRIANGULAR 7640C FORM. IT COMPUTES THE EIGENVECTORS OF THE TRIANGULAR PROBLEM AND 7641C TRANSFORMS THE RESULTS BACK TO THE ORIGINAL COORDINATE SYSTEM. 7642C IT IS USUALLY PRECEDED BY QZHES, QZIT, AND QZVAL. 7643C 7644C ON INPUT 7645C 7646C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 7647C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 7648C DIMENSION STATEMENT. 7649C 7650C N IS THE ORDER OF THE MATRICES. 7651C 7652C A CONTAINS A REAL UPPER QUASI-TRIANGULAR MATRIX. 7653C 7654C B CONTAINS A REAL UPPER TRIANGULAR MATRIX. IN ADDITION, 7655C LOCATION B(N,1) CONTAINS THE TOLERANCE QUANTITY (EPSB) 7656C COMPUTED AND SAVED IN QZIT. 7657C 7658C ALFR, ALFI, AND BETA ARE VECTORS WITH COMPONENTS WHOSE 7659C RATIOS ((ALFR+I*ALFI)/BETA) ARE THE GENERALIZED 7660C EIGENVALUES. THEY ARE USUALLY OBTAINED FROM QZVAL. 7661C 7662C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE 7663C REDUCTIONS BY QZHES, QZIT, AND QZVAL, IF PERFORMED. 7664C IF THE EIGENVECTORS OF THE TRIANGULAR PROBLEM ARE 7665C DESIRED, Z MUST CONTAIN THE IDENTITY MATRIX. 7666C 7667C ON OUTPUT 7668C 7669C A IS UNALTERED. ITS SUBDIAGONAL ELEMENTS PROVIDE INFORMATION 7670C ABOUT THE STORAGE OF THE COMPLEX EIGENVECTORS. 7671C 7672C B HAS BEEN DESTROYED. 7673C 7674C ALFR, ALFI, AND BETA ARE UNALTERED. 7675C 7676C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS. 7677C IF ALFI(I) .EQ. 0.0, THE I-TH EIGENVALUE IS REAL AND 7678C THE I-TH COLUMN OF Z CONTAINS ITS EIGENVECTOR. 7679C IF ALFI(I) .NE. 0.0, THE I-TH EIGENVALUE IS COMPLEX. 7680C IF ALFI(I) .GT. 0.0, THE EIGENVALUE IS THE FIRST OF 7681C A COMPLEX PAIR AND THE I-TH AND (I+1)-TH COLUMNS 7682C OF Z CONTAIN ITS EIGENVECTOR. 7683C IF ALFI(I) .LT. 0.0, THE EIGENVALUE IS THE SECOND OF 7684C A COMPLEX PAIR AND THE (I-1)-TH AND I-TH COLUMNS 7685C OF Z CONTAIN THE CONJUGATE OF ITS EIGENVECTOR. 7686C EACH EIGENVECTOR IS NORMALIZED SO THAT THE MODULUS 7687C OF ITS LARGEST COMPONENT IS 1.0 . 7688C 7689C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 7690C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 7691C 7692C THIS VERSION DATED AUGUST 1983. 7693C 7694C ------------------------------------------------------------------ 7695C 7696 EPSB = B(N,1) 7697 ISW = 1 7698C .......... FOR EN=N STEP -1 UNTIL 1 DO -- .......... 7699 DO 800 NN = 1, N 7700 EN = N + 1 - NN 7701 NA = EN - 1 7702 IF (ISW .EQ. 2) GO TO 795 7703 IF (ALFI(EN) .NE. 0.0D0) GO TO 710 7704C .......... REAL VECTOR .......... 7705 M = EN 7706 B(EN,EN) = 1.0D0 7707 IF (NA .EQ. 0) GO TO 800 7708 ALFM = ALFR(M) 7709 BETM = BETA(M) 7710C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... 7711 DO 700 II = 1, NA 7712 I = EN - II 7713 W = BETM * A(I,I) - ALFM * B(I,I) 7714 R = 0.0D0 7715C 7716 DO 610 J = M, EN 7717 610 R = R + (BETM * A(I,J) - ALFM * B(I,J)) * B(J,EN) 7718C 7719 IF (I .EQ. 1 .OR. ISW .EQ. 2) GO TO 630 7720 IF (BETM * A(I,I-1) .EQ. 0.0D0) GO TO 630 7721 ZZ = W 7722 S = R 7723 GO TO 690 7724 630 M = I 7725 IF (ISW .EQ. 2) GO TO 640 7726C .......... REAL 1-BY-1 BLOCK .......... 7727 T = W 7728 IF (W .EQ. 0.0D0) T = EPSB 7729 B(I,EN) = -R / T 7730 GO TO 700 7731C .......... REAL 2-BY-2 BLOCK .......... 7732 640 X = BETM * A(I,I+1) - ALFM * B(I,I+1) 7733 Y = BETM * A(I+1,I) 7734 Q = W * ZZ - X * Y 7735 T = (X * S - ZZ * R) / Q 7736 B(I,EN) = T 7737 IF (DABS(X) .LE. DABS(ZZ)) GO TO 650 7738 B(I+1,EN) = (-R - W * T) / X 7739 GO TO 690 7740 650 B(I+1,EN) = (-S - Y * T) / ZZ 7741 690 ISW = 3 - ISW 7742 700 CONTINUE 7743C .......... END REAL VECTOR .......... 7744 GO TO 800 7745C .......... COMPLEX VECTOR .......... 7746 710 M = NA 7747 ALMR = ALFR(M) 7748 ALMI = ALFI(M) 7749 BETM = BETA(M) 7750C .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT 7751C EIGENVECTOR MATRIX IS TRIANGULAR .......... 7752 Y = BETM * A(EN,NA) 7753 B(NA,NA) = -ALMI * B(EN,EN) / Y 7754 B(NA,EN) = (ALMR * B(EN,EN) - BETM * A(EN,EN)) / Y 7755 B(EN,NA) = 0.0D0 7756 B(EN,EN) = 1.0D0 7757 ENM2 = NA - 1 7758 IF (ENM2 .EQ. 0) GO TO 795 7759C .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- .......... 7760 DO 790 II = 1, ENM2 7761 I = NA - II 7762 W = BETM * A(I,I) - ALMR * B(I,I) 7763 W1 = -ALMI * B(I,I) 7764 RA = 0.0D0 7765 SA = 0.0D0 7766C 7767 DO 760 J = M, EN 7768 X = BETM * A(I,J) - ALMR * B(I,J) 7769 X1 = -ALMI * B(I,J) 7770 RA = RA + X * B(J,NA) - X1 * B(J,EN) 7771 SA = SA + X * B(J,EN) + X1 * B(J,NA) 7772 760 CONTINUE 7773C 7774 IF (I .EQ. 1 .OR. ISW .EQ. 2) GO TO 770 7775 IF (BETM * A(I,I-1) .EQ. 0.0D0) GO TO 770 7776 ZZ = W 7777 Z1 = W1 7778 R = RA 7779 S = SA 7780 ISW = 2 7781 GO TO 790 7782 770 M = I 7783 IF (ISW .EQ. 2) GO TO 780 7784C .......... COMPLEX 1-BY-1 BLOCK .......... 7785 TR = -RA 7786 TI = -SA 7787 773 DR = W 7788 DI = W1 7789C .......... COMPLEX DIVIDE (T1,T2) = (TR,TI) / (DR,DI) .......... 7790 775 IF (DABS(DI) .GT. DABS(DR)) GO TO 777 7791 RR = DI / DR 7792 D = DR + DI * RR 7793 T1 = (TR + TI * RR) / D 7794 T2 = (TI - TR * RR) / D 7795 GO TO (787,782), ISW 7796 777 RR = DR / DI 7797 D = DR * RR + DI 7798 T1 = (TR * RR + TI) / D 7799 T2 = (TI * RR - TR) / D 7800 GO TO (787,782), ISW 7801C .......... COMPLEX 2-BY-2 BLOCK .......... 7802 780 X = BETM * A(I,I+1) - ALMR * B(I,I+1) 7803 X1 = -ALMI * B(I,I+1) 7804 Y = BETM * A(I+1,I) 7805 TR = Y * RA - W * R + W1 * S 7806 TI = Y * SA - W * S - W1 * R 7807 DR = W * ZZ - W1 * Z1 - X * Y 7808 DI = W * Z1 + W1 * ZZ - X1 * Y 7809 IF (DR .EQ. 0.0D0 .AND. DI .EQ. 0.0D0) DR = EPSB 7810 GO TO 775 7811 782 B(I+1,NA) = T1 7812 B(I+1,EN) = T2 7813 ISW = 1 7814 IF (DABS(Y) .GT. DABS(W) + DABS(W1)) GO TO 785 7815 TR = -RA - X * B(I+1,NA) + X1 * B(I+1,EN) 7816 TI = -SA - X * B(I+1,EN) - X1 * B(I+1,NA) 7817 GO TO 773 7818 785 T1 = (-R - ZZ * B(I+1,NA) + Z1 * B(I+1,EN)) / Y 7819 T2 = (-S - ZZ * B(I+1,EN) - Z1 * B(I+1,NA)) / Y 7820 787 B(I,NA) = T1 7821 B(I,EN) = T2 7822 790 CONTINUE 7823C .......... END COMPLEX VECTOR .......... 7824 795 ISW = 3 - ISW 7825 800 CONTINUE 7826C .......... END BACK SUBSTITUTION. 7827C TRANSFORM TO ORIGINAL COORDINATE SYSTEM. 7828C FOR J=N STEP -1 UNTIL 1 DO -- .......... 7829 DO 880 JJ = 1, N 7830 J = N + 1 - JJ 7831C 7832 DO 880 I = 1, N 7833 ZZ = 0.0D0 7834C 7835 DO 860 K = 1, J 7836 860 ZZ = ZZ + Z(I,K) * B(K,J) 7837C 7838 Z(I,J) = ZZ 7839 880 CONTINUE 7840C .......... NORMALIZE SO THAT MODULUS OF LARGEST 7841C COMPONENT OF EACH VECTOR IS 1. 7842C (ISW IS 1 INITIALLY FROM BEFORE) .......... 7843 DO 950 J = 1, N 7844 D = 0.0D0 7845 IF (ISW .EQ. 2) GO TO 920 7846 IF (ALFI(J) .NE. 0.0D0) GO TO 945 7847C 7848 DO 890 I = 1, N 7849 IF (DABS(Z(I,J)) .GT. D) D = DABS(Z(I,J)) 7850 890 CONTINUE 7851C 7852 DO 900 I = 1, N 7853 900 Z(I,J) = Z(I,J) / D 7854C 7855 GO TO 950 7856C 7857 920 DO 930 I = 1, N 7858 R = DABS(Z(I,J-1)) + DABS(Z(I,J)) 7859 IF (R .NE. 0.0D0) R = R * DSQRT((Z(I,J-1)/R)**2 7860 X +(Z(I,J)/R)**2) 7861 IF (R .GT. D) D = R 7862 930 CONTINUE 7863C 7864 DO 940 I = 1, N 7865 Z(I,J-1) = Z(I,J-1) / D 7866 Z(I,J) = Z(I,J) / D 7867 940 CONTINUE 7868C 7869 945 ISW = 3 - ISW 7870 950 CONTINUE 7871C 7872 RETURN 7873 END 7874 SUBROUTINE RATQR(N,EPS1,D,E,E2,M,W,IND,BD,TYPE,IDEF,IERR) 7875C 7876 INTEGER I,J,K,M,N,II,JJ,K1,IDEF,IERR,JDEF 7877 DOUBLE PRECISION D(N),E(N),E2(N),W(N),BD(N) 7878 DOUBLE PRECISION F,P,Q,R,S,EP,QP,ERR,TOT,EPS1,DELTA,EPSLON 7879 INTEGER IND(N) 7880 LOGICAL TYPE 7881C 7882C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE RATQR, 7883C NUM. MATH. 11, 264-272(1968) BY REINSCH AND BAUER. 7884C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 257-265(1971). 7885C 7886C THIS SUBROUTINE FINDS THE ALGEBRAICALLY SMALLEST OR LARGEST 7887C EIGENVALUES OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE 7888C RATIONAL QR METHOD WITH NEWTON CORRECTIONS. 7889C 7890C ON INPUT 7891C 7892C N IS THE ORDER OF THE MATRIX. 7893C 7894C EPS1 IS A THEORETICAL ABSOLUTE ERROR TOLERANCE FOR THE 7895C COMPUTED EIGENVALUES. IF THE INPUT EPS1 IS NON-POSITIVE, 7896C OR INDEED SMALLER THAN ITS DEFAULT VALUE, IT IS RESET 7897C AT EACH ITERATION TO THE RESPECTIVE DEFAULT VALUE, 7898C NAMELY, THE PRODUCT OF THE RELATIVE MACHINE PRECISION 7899C AND THE MAGNITUDE OF THE CURRENT EIGENVALUE ITERATE. 7900C THE THEORETICAL ABSOLUTE ERROR IN THE K-TH EIGENVALUE 7901C IS USUALLY NOT GREATER THAN K TIMES EPS1. 7902C 7903C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. 7904C 7905C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX 7906C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. 7907C 7908C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. 7909C E2(1) IS ARBITRARY. 7910C 7911C M IS THE NUMBER OF EIGENVALUES TO BE FOUND. 7912C 7913C IDEF SHOULD BE SET TO 1 IF THE INPUT MATRIX IS KNOWN TO BE 7914C POSITIVE DEFINITE, TO -1 IF THE INPUT MATRIX IS KNOWN TO 7915C BE NEGATIVE DEFINITE, AND TO 0 OTHERWISE. 7916C 7917C TYPE SHOULD BE SET TO .TRUE. IF THE SMALLEST EIGENVALUES 7918C ARE TO BE FOUND, AND TO .FALSE. IF THE LARGEST EIGENVALUES 7919C ARE TO BE FOUND. 7920C 7921C ON OUTPUT 7922C 7923C EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS 7924C (LAST) DEFAULT VALUE. 7925C 7926C D AND E ARE UNALTERED (UNLESS W OVERWRITES D). 7927C 7928C ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED 7929C AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE 7930C MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES. 7931C E2(1) IS SET TO 0.0D0 IF THE SMALLEST EIGENVALUES HAVE BEEN 7932C FOUND, AND TO 2.0D0 IF THE LARGEST EIGENVALUES HAVE BEEN 7933C FOUND. E2 IS OTHERWISE UNALTERED (UNLESS OVERWRITTEN BY BD). 7934C 7935C W CONTAINS THE M ALGEBRAICALLY SMALLEST EIGENVALUES IN 7936C ASCENDING ORDER, OR THE M LARGEST EIGENVALUES IN 7937C DESCENDING ORDER. IF AN ERROR EXIT IS MADE BECAUSE OF 7938C AN INCORRECT SPECIFICATION OF IDEF, NO EIGENVALUES 7939C ARE FOUND. IF THE NEWTON ITERATES FOR A PARTICULAR 7940C EIGENVALUE ARE NOT MONOTONE, THE BEST ESTIMATE OBTAINED 7941C IS RETURNED AND IERR IS SET. W MAY COINCIDE WITH D. 7942C 7943C IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES 7944C ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W -- 7945C 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM 7946C THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC.. 7947C 7948C BD CONTAINS REFINED BOUNDS FOR THE THEORETICAL ERRORS OF THE 7949C CORRESPONDING EIGENVALUES IN W. THESE BOUNDS ARE USUALLY 7950C WITHIN THE TOLERANCE SPECIFIED BY EPS1. BD MAY COINCIDE 7951C WITH E2. 7952C 7953C IERR IS SET TO 7954C ZERO FOR NORMAL RETURN, 7955C 6*N+1 IF IDEF IS SET TO 1 AND TYPE TO .TRUE. 7956C WHEN THE MATRIX IS NOT POSITIVE DEFINITE, OR 7957C IF IDEF IS SET TO -1 AND TYPE TO .FALSE. 7958C WHEN THE MATRIX IS NOT NEGATIVE DEFINITE, 7959C 5*N+K IF SUCCESSIVE ITERATES TO THE K-TH EIGENVALUE 7960C ARE NOT MONOTONE INCREASING, WHERE K REFERS 7961C TO THE LAST SUCH OCCURRENCE. 7962C 7963C NOTE THAT SUBROUTINE TRIDIB IS GENERALLY FASTER AND MORE 7964C ACCURATE THAN RATQR IF THE EIGENVALUES ARE CLUSTERED. 7965C 7966C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 7967C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 7968C 7969C THIS VERSION DATED AUGUST 1983. 7970C 7971C ------------------------------------------------------------------ 7972C 7973 IERR = 0 7974 JDEF = IDEF 7975C .......... COPY D ARRAY INTO W .......... 7976 DO 20 I = 1, N 7977 20 W(I) = D(I) 7978C 7979 IF (TYPE) GO TO 40 7980 J = 1 7981 GO TO 400 7982 40 ERR = 0.0D0 7983 S = 0.0D0 7984C .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES AND DEFINE 7985C INITIAL SHIFT FROM LOWER GERSCHGORIN BOUND. 7986C COPY E2 ARRAY INTO BD .......... 7987 TOT = W(1) 7988 Q = 0.0D0 7989 J = 0 7990C 7991 DO 100 I = 1, N 7992 P = Q 7993 IF (I .EQ. 1) GO TO 60 7994 IF (P .GT. EPSLON(DABS(D(I)) + DABS(D(I-1)))) GO TO 80 7995 60 E2(I) = 0.0D0 7996 80 BD(I) = E2(I) 7997C .......... COUNT ALSO IF ELEMENT OF E2 HAS UNDERFLOWED .......... 7998 IF (E2(I) .EQ. 0.0D0) J = J + 1 7999 IND(I) = J 8000 Q = 0.0D0 8001 IF (I .NE. N) Q = DABS(E(I+1)) 8002 TOT = DMIN1(W(I)-P-Q,TOT) 8003 100 CONTINUE 8004C 8005 IF (JDEF .EQ. 1 .AND. TOT .LT. 0.0D0) GO TO 140 8006C 8007 DO 110 I = 1, N 8008 110 W(I) = W(I) - TOT 8009C 8010 GO TO 160 8011 140 TOT = 0.0D0 8012C 8013 160 DO 360 K = 1, M 8014C .......... NEXT QR TRANSFORMATION .......... 8015 180 TOT = TOT + S 8016 DELTA = W(N) - S 8017 I = N 8018 F = DABS(EPSLON(TOT)) 8019 IF (EPS1 .LT. F) EPS1 = F 8020 IF (DELTA .GT. EPS1) GO TO 190 8021 IF (DELTA .LT. (-EPS1)) GO TO 1000 8022 GO TO 300 8023C .......... REPLACE SMALL SUB-DIAGONAL SQUARES BY ZERO 8024C TO REDUCE THE INCIDENCE OF UNDERFLOWS .......... 8025 190 IF (K .EQ. N) GO TO 210 8026 K1 = K + 1 8027 DO 200 J = K1, N 8028 IF (BD(J) .LE. (EPSLON(W(J)+W(J-1))) ** 2) BD(J) = 0.0D0 8029 200 CONTINUE 8030C 8031 210 F = BD(N) / DELTA 8032 QP = DELTA + F 8033 P = 1.0D0 8034 IF (K .EQ. N) GO TO 260 8035 K1 = N - K 8036C .......... FOR I=N-1 STEP -1 UNTIL K DO -- .......... 8037 DO 240 II = 1, K1 8038 I = N - II 8039 Q = W(I) - S - F 8040 R = Q / QP 8041 P = P * R + 1.0D0 8042 EP = F * R 8043 W(I+1) = QP + EP 8044 DELTA = Q - EP 8045 IF (DELTA .GT. EPS1) GO TO 220 8046 IF (DELTA .LT. (-EPS1)) GO TO 1000 8047 GO TO 300 8048 220 F = BD(I) / Q 8049 QP = DELTA + F 8050 BD(I+1) = QP * EP 8051 240 CONTINUE 8052C 8053 260 W(K) = QP 8054 S = QP / P 8055 IF (TOT + S .GT. TOT) GO TO 180 8056C .......... SET ERROR -- IRREGULAR END OF ITERATION. 8057C DEFLATE MINIMUM DIAGONAL ELEMENT .......... 8058 IERR = 5 * N + K 8059 S = 0.0D0 8060 DELTA = QP 8061C 8062 DO 280 J = K, N 8063 IF (W(J) .GT. DELTA) GO TO 280 8064 I = J 8065 DELTA = W(J) 8066 280 CONTINUE 8067C .......... CONVERGENCE .......... 8068 300 IF (I .LT. N) BD(I+1) = BD(I) * F / QP 8069 II = IND(I) 8070 IF (I .EQ. K) GO TO 340 8071 K1 = I - K 8072C .......... FOR J=I-1 STEP -1 UNTIL K DO -- .......... 8073 DO 320 JJ = 1, K1 8074 J = I - JJ 8075 W(J+1) = W(J) - S 8076 BD(J+1) = BD(J) 8077 IND(J+1) = IND(J) 8078 320 CONTINUE 8079C 8080 340 W(K) = TOT 8081 ERR = ERR + DABS(DELTA) 8082 BD(K) = ERR 8083 IND(K) = II 8084 360 CONTINUE 8085C 8086 IF (TYPE) GO TO 1001 8087 F = BD(1) 8088 E2(1) = 2.0D0 8089 BD(1) = F 8090 J = 2 8091C .......... NEGATE ELEMENTS OF W FOR LARGEST VALUES .......... 8092 400 DO 500 I = 1, N 8093 500 W(I) = -W(I) 8094C 8095 JDEF = -JDEF 8096 GO TO (40,1001), J 8097C .......... SET ERROR -- IDEF SPECIFIED INCORRECTLY .......... 8098 1000 IERR = 6 * N + 1 8099 1001 RETURN 8100 END 8101 SUBROUTINE REBAKL(NM,N,B,DL,M,Z) 8102C 8103 INTEGER I,J,K,M,N,I1,II,NM 8104 DOUBLE PRECISION B(NM,N),DL(N),Z(NM,M) 8105 DOUBLE PRECISION X 8106C 8107C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE REBAKA, 8108C NUM. MATH. 11, 99-110(1968) BY MARTIN AND WILKINSON. 8109C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971). 8110C 8111C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A GENERALIZED 8112C SYMMETRIC EIGENSYSTEM BY BACK TRANSFORMING THOSE OF THE 8113C DERIVED SYMMETRIC MATRIX DETERMINED BY REDUC. 8114C 8115C ON INPUT 8116C 8117C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 8118C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 8119C DIMENSION STATEMENT. 8120C 8121C N IS THE ORDER OF THE MATRIX SYSTEM. 8122C 8123C B CONTAINS INFORMATION ABOUT THE SIMILARITY TRANSFORMATION 8124C (CHOLESKY DECOMPOSITION) USED IN THE REDUCTION BY REDUC 8125C IN ITS STRICT LOWER TRIANGLE. 8126C 8127C DL CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATION. 8128C 8129C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. 8130C 8131C Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED 8132C IN ITS FIRST M COLUMNS. 8133C 8134C ON OUTPUT 8135C 8136C Z CONTAINS THE TRANSFORMED EIGENVECTORS 8137C IN ITS FIRST M COLUMNS. 8138C 8139C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 8140C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 8141C 8142C THIS VERSION DATED AUGUST 1983. 8143C 8144C ------------------------------------------------------------------ 8145C 8146 IF (M .EQ. 0) GO TO 200 8147C 8148 DO 100 J = 1, M 8149C .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... 8150 DO 100 II = 1, N 8151 I = N + 1 - II 8152 I1 = I + 1 8153 X = Z(I,J) 8154 IF (I .EQ. N) GO TO 80 8155C 8156 DO 60 K = I1, N 8157 60 X = X - B(K,I) * Z(K,J) 8158C 8159 80 Z(I,J) = X / DL(I) 8160 100 CONTINUE 8161C 8162 200 RETURN 8163 END 8164 SUBROUTINE REBAKB(NM,N,B,DL,M,Z) 8165C 8166 INTEGER I,J,K,M,N,I1,II,NM 8167 DOUBLE PRECISION B(NM,N),DL(N),Z(NM,M) 8168 DOUBLE PRECISION X 8169C 8170C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE REBAKB, 8171C NUM. MATH. 11, 99-110(1968) BY MARTIN AND WILKINSON. 8172C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971). 8173C 8174C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A GENERALIZED 8175C SYMMETRIC EIGENSYSTEM BY BACK TRANSFORMING THOSE OF THE 8176C DERIVED SYMMETRIC MATRIX DETERMINED BY REDUC2. 8177C 8178C ON INPUT 8179C 8180C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 8181C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 8182C DIMENSION STATEMENT. 8183C 8184C N IS THE ORDER OF THE MATRIX SYSTEM. 8185C 8186C B CONTAINS INFORMATION ABOUT THE SIMILARITY TRANSFORMATION 8187C (CHOLESKY DECOMPOSITION) USED IN THE REDUCTION BY REDUC2 8188C IN ITS STRICT LOWER TRIANGLE. 8189C 8190C DL CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATION. 8191C 8192C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. 8193C 8194C Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED 8195C IN ITS FIRST M COLUMNS. 8196C 8197C ON OUTPUT 8198C 8199C Z CONTAINS THE TRANSFORMED EIGENVECTORS 8200C IN ITS FIRST M COLUMNS. 8201C 8202C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 8203C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 8204C 8205C THIS VERSION DATED AUGUST 1983. 8206C 8207C ------------------------------------------------------------------ 8208C 8209 IF (M .EQ. 0) GO TO 200 8210C 8211 DO 100 J = 1, M 8212C .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... 8213 DO 100 II = 1, N 8214 I1 = N - II 8215 I = I1 + 1 8216 X = DL(I) * Z(I,J) 8217 IF (I .EQ. 1) GO TO 80 8218C 8219 DO 60 K = 1, I1 8220 60 X = X + B(I,K) * Z(K,J) 8221C 8222 80 Z(I,J) = X 8223 100 CONTINUE 8224C 8225 200 RETURN 8226 END 8227 SUBROUTINE REDUCL(NM,N,A,B,DL,IERR) 8228C 8229 INTEGER I,J,K,N,I1,J1,NM,NN,IERR 8230 DOUBLE PRECISION A(NM,N),B(NM,N),DL(N) 8231 DOUBLE PRECISION X,Y 8232C 8233C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE REDUC1, 8234C NUM. MATH. 11, 99-110(1968) BY MARTIN AND WILKINSON. 8235C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971). 8236C 8237C THIS SUBROUTINE REDUCES THE GENERALIZED SYMMETRIC EIGENPROBLEM 8238C AX=(LAMBDA)BX, WHERE B IS POSITIVE DEFINITE, TO THE STANDARD 8239C SYMMETRIC EIGENPROBLEM USING THE CHOLESKY FACTORIZATION OF B. 8240C 8241C ON INPUT 8242C 8243C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 8244C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 8245C DIMENSION STATEMENT. 8246C 8247C N IS THE ORDER OF THE MATRICES A AND B. IF THE CHOLESKY 8248C FACTOR L OF B IS ALREADY AVAILABLE, N SHOULD BE PREFIXED 8249C WITH A MINUS SIGN. 8250C 8251C A AND B CONTAIN THE REAL SYMMETRIC INPUT MATRICES. ONLY THE 8252C FULL UPPER TRIANGLES OF THE MATRICES NEED BE SUPPLIED. IF 8253C N IS NEGATIVE, THE STRICT LOWER TRIANGLE OF B CONTAINS, 8254C INSTEAD, THE STRICT LOWER TRIANGLE OF ITS CHOLESKY FACTOR L. 8255C 8256C DL CONTAINS, IF N IS NEGATIVE, THE DIAGONAL ELEMENTS OF L. 8257C 8258C ON OUTPUT 8259C 8260C A CONTAINS IN ITS FULL LOWER TRIANGLE THE FULL LOWER TRIANGLE 8261C OF THE SYMMETRIC MATRIX DERIVED FROM THE REDUCTION TO THE 8262C STANDARD FORM. THE STRICT UPPER TRIANGLE OF A IS UNALTERED. 8263C 8264C B CONTAINS IN ITS STRICT LOWER TRIANGLE THE STRICT LOWER 8265C TRIANGLE OF ITS CHOLESKY FACTOR L. THE FULL UPPER 8266C TRIANGLE OF B IS UNALTERED. 8267C 8268C DL CONTAINS THE DIAGONAL ELEMENTS OF L. 8269C 8270C IERR IS SET TO 8271C ZERO FOR NORMAL RETURN, 8272C 7*N+1 IF B IS NOT POSITIVE DEFINITE. 8273C 8274C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 8275C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 8276C 8277C THIS VERSION DATED AUGUST 1983. 8278C 8279C ------------------------------------------------------------------ 8280C 8281 IERR = 0 8282 NN = IABS(N) 8283 IF (N .LT. 0) GO TO 100 8284C .......... FORM L IN THE ARRAYS B AND DL .......... 8285 DO 80 I = 1, N 8286 I1 = I - 1 8287C 8288 DO 80 J = I, N 8289 X = B(I,J) 8290 IF (I .EQ. 1) GO TO 40 8291C 8292 DO 20 K = 1, I1 8293 20 X = X - B(I,K) * B(J,K) 8294C 8295 40 IF (J .NE. I) GO TO 60 8296 IF (X .LE. 0.0D0) GO TO 1000 8297 Y = DSQRT(X) 8298 DL(I) = Y 8299 GO TO 80 8300 60 B(J,I) = X / Y 8301 80 CONTINUE 8302C .......... FORM THE TRANSPOSE OF THE UPPER TRIANGLE OF INV(L)*A 8303C IN THE LOWER TRIANGLE OF THE ARRAY A .......... 8304 100 DO 200 I = 1, NN 8305 I1 = I - 1 8306 Y = DL(I) 8307C 8308 DO 200 J = I, NN 8309 X = A(I,J) 8310 IF (I .EQ. 1) GO TO 180 8311C 8312 DO 160 K = 1, I1 8313 160 X = X - B(I,K) * A(J,K) 8314C 8315 180 A(J,I) = X / Y 8316 200 CONTINUE 8317C .......... PRE-MULTIPLY BY INV(L) AND OVERWRITE .......... 8318 DO 300 J = 1, NN 8319 J1 = J - 1 8320C 8321 DO 300 I = J, NN 8322 X = A(I,J) 8323 IF (I .EQ. J) GO TO 240 8324 I1 = I - 1 8325C 8326 DO 220 K = J, I1 8327 220 X = X - A(K,J) * B(I,K) 8328C 8329 240 IF (J .EQ. 1) GO TO 280 8330C 8331 DO 260 K = 1, J1 8332 260 X = X - A(J,K) * B(I,K) 8333C 8334 280 A(I,J) = X / DL(I) 8335 300 CONTINUE 8336C 8337 GO TO 1001 8338C .......... SET ERROR -- B IS NOT POSITIVE DEFINITE .......... 8339 1000 IERR = 7 * N + 1 8340 1001 RETURN 8341 END 8342 SUBROUTINE REDUC2(NM,N,A,B,DL,IERR) 8343C 8344 INTEGER I,J,K,N,I1,J1,NM,NN,IERR 8345 DOUBLE PRECISION A(NM,N),B(NM,N),DL(N) 8346 DOUBLE PRECISION X,Y 8347C 8348C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE REDUC2, 8349C NUM. MATH. 11, 99-110(1968) BY MARTIN AND WILKINSON. 8350C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971). 8351C 8352C THIS SUBROUTINE REDUCES THE GENERALIZED SYMMETRIC EIGENPROBLEMS 8353C ABX=(LAMBDA)X OR BAY=(LAMBDA)Y, WHERE B IS POSITIVE DEFINITE, 8354C TO THE STANDARD SYMMETRIC EIGENPROBLEM USING THE CHOLESKY 8355C FACTORIZATION OF B. 8356C 8357C ON INPUT 8358C 8359C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 8360C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 8361C DIMENSION STATEMENT. 8362C 8363C N IS THE ORDER OF THE MATRICES A AND B. IF THE CHOLESKY 8364C FACTOR L OF B IS ALREADY AVAILABLE, N SHOULD BE PREFIXED 8365C WITH A MINUS SIGN. 8366C 8367C A AND B CONTAIN THE REAL SYMMETRIC INPUT MATRICES. ONLY THE 8368C FULL UPPER TRIANGLES OF THE MATRICES NEED BE SUPPLIED. IF 8369C N IS NEGATIVE, THE STRICT LOWER TRIANGLE OF B CONTAINS, 8370C INSTEAD, THE STRICT LOWER TRIANGLE OF ITS CHOLESKY FACTOR L. 8371C 8372C DL CONTAINS, IF N IS NEGATIVE, THE DIAGONAL ELEMENTS OF L. 8373C 8374C ON OUTPUT 8375C 8376C A CONTAINS IN ITS FULL LOWER TRIANGLE THE FULL LOWER TRIANGLE 8377C OF THE SYMMETRIC MATRIX DERIVED FROM THE REDUCTION TO THE 8378C STANDARD FORM. THE STRICT UPPER TRIANGLE OF A IS UNALTERED. 8379C 8380C B CONTAINS IN ITS STRICT LOWER TRIANGLE THE STRICT LOWER 8381C TRIANGLE OF ITS CHOLESKY FACTOR L. THE FULL UPPER 8382C TRIANGLE OF B IS UNALTERED. 8383C 8384C DL CONTAINS THE DIAGONAL ELEMENTS OF L. 8385C 8386C IERR IS SET TO 8387C ZERO FOR NORMAL RETURN, 8388C 7*N+1 IF B IS NOT POSITIVE DEFINITE. 8389C 8390C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 8391C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 8392C 8393C THIS VERSION DATED AUGUST 1983. 8394C 8395C ------------------------------------------------------------------ 8396C 8397 IERR = 0 8398 NN = IABS(N) 8399 IF (N .LT. 0) GO TO 100 8400C .......... FORM L IN THE ARRAYS B AND DL .......... 8401 DO 80 I = 1, N 8402 I1 = I - 1 8403C 8404 DO 80 J = I, N 8405 X = B(I,J) 8406 IF (I .EQ. 1) GO TO 40 8407C 8408 DO 20 K = 1, I1 8409 20 X = X - B(I,K) * B(J,K) 8410C 8411 40 IF (J .NE. I) GO TO 60 8412 IF (X .LE. 0.0D0) GO TO 1000 8413 Y = DSQRT(X) 8414 DL(I) = Y 8415 GO TO 80 8416 60 B(J,I) = X / Y 8417 80 CONTINUE 8418C .......... FORM THE LOWER TRIANGLE OF A*L 8419C IN THE LOWER TRIANGLE OF THE ARRAY A .......... 8420 100 DO 200 I = 1, NN 8421 I1 = I + 1 8422C 8423 DO 200 J = 1, I 8424 X = A(J,I) * DL(J) 8425 IF (J .EQ. I) GO TO 140 8426 J1 = J + 1 8427C 8428 DO 120 K = J1, I 8429 120 X = X + A(K,I) * B(K,J) 8430C 8431 140 IF (I .EQ. NN) GO TO 180 8432C 8433 DO 160 K = I1, NN 8434 160 X = X + A(I,K) * B(K,J) 8435C 8436 180 A(I,J) = X 8437 200 CONTINUE 8438C .......... PRE-MULTIPLY BY TRANSPOSE(L) AND OVERWRITE .......... 8439 DO 300 I = 1, NN 8440 I1 = I + 1 8441 Y = DL(I) 8442C 8443 DO 300 J = 1, I 8444 X = Y * A(I,J) 8445 IF (I .EQ. NN) GO TO 280 8446C 8447 DO 260 K = I1, NN 8448 260 X = X + A(K,J) * B(K,I) 8449C 8450 280 A(I,J) = X 8451 300 CONTINUE 8452C 8453 GO TO 1001 8454C .......... SET ERROR -- B IS NOT POSITIVE DEFINITE .......... 8455 1000 IERR = 7 * N + 1 8456 1001 RETURN 8457 END 8458 SUBROUTINE RG(NM,N,A,WR,WI,MATZ,Z,IV1,FV1,IERR) 8459C 8460 INTEGER N,NM,IS1,IS2,IERR,MATZ 8461 DOUBLE PRECISION A(NM,N),WR(N),WI(N),Z(NM,N),FV1(N) 8462 INTEGER IV1(N) 8463C 8464C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF 8465C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) 8466C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) 8467C OF A REAL GENERAL MATRIX. 8468C 8469C ON INPUT 8470C 8471C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL 8472C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 8473C DIMENSION STATEMENT. 8474C 8475C N IS THE ORDER OF THE MATRIX A. 8476C 8477C A CONTAINS THE REAL GENERAL MATRIX. 8478C 8479C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF 8480C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO 8481C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. 8482C 8483C ON OUTPUT 8484C 8485C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, 8486C RESPECTIVELY, OF THE EIGENVALUES. COMPLEX CONJUGATE 8487C PAIRS OF EIGENVALUES APPEAR CONSECUTIVELY WITH THE 8488C EIGENVALUE HAVING THE POSITIVE IMAGINARY PART FIRST. 8489C 8490C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS 8491C IF MATZ IS NOT ZERO. IF THE J-TH EIGENVALUE IS REAL, THE 8492C J-TH COLUMN OF Z CONTAINS ITS EIGENVECTOR. IF THE J-TH 8493C EIGENVALUE IS COMPLEX WITH POSITIVE IMAGINARY PART, THE 8494C J-TH AND (J+1)-TH COLUMNS OF Z CONTAIN THE REAL AND 8495C IMAGINARY PARTS OF ITS EIGENVECTOR. THE CONJUGATE OF THIS 8496C VECTOR IS THE EIGENVECTOR FOR THE CONJUGATE EIGENVALUE. 8497C 8498C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR 8499C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR HQR 8500C AND HQR2. THE NORMAL COMPLETION CODE IS ZERO. 8501C 8502C IV1 AND FV1 ARE TEMPORARY STORAGE ARRAYS. 8503C 8504C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 8505C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 8506C 8507C THIS VERSION DATED AUGUST 1983. 8508C 8509C ------------------------------------------------------------------ 8510C 8511 IF (N .LE. NM) GO TO 10 8512 IERR = 10 * N 8513 GO TO 50 8514C 8515 10 CALL BALANC(NM,N,A,IS1,IS2,FV1) 8516 CALL ELMHES(NM,N,IS1,IS2,A,IV1) 8517 IF (MATZ .NE. 0) GO TO 20 8518C .......... FIND EIGENVALUES ONLY .......... 8519 CALL HQR(NM,N,IS1,IS2,A,WR,WI,IERR) 8520 GO TO 50 8521C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 8522 20 CALL ELTRAN(NM,N,IS1,IS2,A,IV1,Z) 8523 CALL HQR2(NM,N,IS1,IS2,A,WR,WI,Z,IERR) 8524 IF (IERR .NE. 0) GO TO 50 8525 CALL BALBAK(NM,N,IS1,IS2,FV1,N,Z) 8526 50 RETURN 8527 END 8528 SUBROUTINE RGG(NM,N,A,B,ALFR,ALFI,BETA,MATZ,Z,IERR) 8529C 8530 INTEGER N,NM,IERR,MATZ 8531 DOUBLE PRECISION A(NM,N),B(NM,N),ALFR(N),ALFI(N),BETA(N),Z(NM,N) 8532 LOGICAL TF 8533C 8534C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF 8535C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) 8536C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) 8537C FOR THE REAL GENERAL GENERALIZED EIGENPROBLEM AX = (LAMBDA)BX. 8538C 8539C ON INPUT 8540C 8541C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL 8542C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 8543C DIMENSION STATEMENT. 8544C 8545C N IS THE ORDER OF THE MATRICES A AND B. 8546C 8547C A CONTAINS A REAL GENERAL MATRIX. 8548C 8549C B CONTAINS A REAL GENERAL MATRIX. 8550C 8551C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF 8552C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO 8553C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. 8554C 8555C ON OUTPUT 8556C 8557C ALFR AND ALFI CONTAIN THE REAL AND IMAGINARY PARTS, 8558C RESPECTIVELY, OF THE NUMERATORS OF THE EIGENVALUES. 8559C 8560C BETA CONTAINS THE DENOMINATORS OF THE EIGENVALUES, 8561C WHICH ARE THUS GIVEN BY THE RATIOS (ALFR+I*ALFI)/BETA. 8562C COMPLEX CONJUGATE PAIRS OF EIGENVALUES APPEAR CONSECUTIVELY 8563C WITH THE EIGENVALUE HAVING THE POSITIVE IMAGINARY PART FIRST. 8564C 8565C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS 8566C IF MATZ IS NOT ZERO. IF THE J-TH EIGENVALUE IS REAL, THE 8567C J-TH COLUMN OF Z CONTAINS ITS EIGENVECTOR. IF THE J-TH 8568C EIGENVALUE IS COMPLEX WITH POSITIVE IMAGINARY PART, THE 8569C J-TH AND (J+1)-TH COLUMNS OF Z CONTAIN THE REAL AND 8570C IMAGINARY PARTS OF ITS EIGENVECTOR. THE CONJUGATE OF THIS 8571C VECTOR IS THE EIGENVECTOR FOR THE CONJUGATE EIGENVALUE. 8572C 8573C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR 8574C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR QZIT. 8575C THE NORMAL COMPLETION CODE IS ZERO. 8576C 8577C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 8578C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 8579C 8580C THIS VERSION DATED AUGUST 1983. 8581C 8582C ------------------------------------------------------------------ 8583C 8584 IF (N .LE. NM) GO TO 10 8585 IERR = 10 * N 8586 GO TO 50 8587C 8588 10 IF (MATZ .NE. 0) GO TO 20 8589C .......... FIND EIGENVALUES ONLY .......... 8590 TF = .FALSE. 8591 CALL QZHES(NM,N,A,B,TF,Z) 8592 CALL QZIT(NM,N,A,B,0.0D0,TF,Z,IERR) 8593 CALL QZVAL(NM,N,A,B,ALFR,ALFI,BETA,TF,Z) 8594 GO TO 50 8595C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 8596 20 TF = .TRUE. 8597 CALL QZHES(NM,N,A,B,TF,Z) 8598 CALL QZIT(NM,N,A,B,0.0D0,TF,Z,IERR) 8599 CALL QZVAL(NM,N,A,B,ALFR,ALFI,BETA,TF,Z) 8600 IF (IERR .NE. 0) GO TO 50 8601 CALL QZVEC(NM,N,A,B,ALFR,ALFI,BETA,Z) 8602 50 RETURN 8603 END 8604 SUBROUTINE RS(NM,N,A,W,MATZ,Z,FV1,FV2,IERR) 8605C 8606 INTEGER N,NM,IERR,MATZ 8607 DOUBLE PRECISION A(NM,N),W(N),Z(NM,N),FV1(N),FV2(N) 8608C 8609C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF 8610C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) 8611C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) 8612C OF A REAL SYMMETRIC MATRIX. 8613C 8614C ON INPUT 8615C 8616C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL 8617C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 8618C DIMENSION STATEMENT. 8619C 8620C N IS THE ORDER OF THE MATRIX A. 8621C 8622C A CONTAINS THE REAL SYMMETRIC MATRIX. 8623C 8624C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF 8625C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO 8626C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. 8627C 8628C ON OUTPUT 8629C 8630C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. 8631C 8632C Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. 8633C 8634C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR 8635C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT 8636C AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. 8637C 8638C FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS. 8639C 8640C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 8641C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 8642C 8643C THIS VERSION DATED AUGUST 1983. 8644C 8645C ------------------------------------------------------------------ 8646C 8647 IF (N .LE. NM) GO TO 10 8648 IERR = 10 * N 8649 GO TO 50 8650C 8651 10 IF (MATZ .NE. 0) GO TO 20 8652C .......... FIND EIGENVALUES ONLY .......... 8653 CALL TRED1L(NM,N,A,W,FV1,FV2) 8654 CALL TQLRATL(N,W,FV2,IERR) 8655 GO TO 50 8656C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 8657 20 CALL TRED2L(NM,N,A,W,FV1,Z) 8658 CALL TQL2L(NM,N,W,FV1,Z,IERR) 8659 50 RETURN 8660 END 8661 SUBROUTINE RSB(NM,N,MB,A,W,MATZ,Z,FV1,FV2,IERR) 8662C 8663 INTEGER N,MB,NM,IERR,MATZ 8664 DOUBLE PRECISION A(NM,MB),W(N),Z(NM,N),FV1(N),FV2(N) 8665 LOGICAL TF 8666C 8667C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF 8668C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) 8669C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) 8670C OF A REAL SYMMETRIC BAND MATRIX. 8671C 8672C ON INPUT 8673C 8674C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL 8675C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 8676C DIMENSION STATEMENT. 8677C 8678C N IS THE ORDER OF THE MATRIX A. 8679C 8680C MB IS THE HALF BAND WIDTH OF THE MATRIX, DEFINED AS THE 8681C NUMBER OF ADJACENT DIAGONALS, INCLUDING THE PRINCIPAL 8682C DIAGONAL, REQUIRED TO SPECIFY THE NON-ZERO PORTION OF THE 8683C LOWER TRIANGLE OF THE MATRIX. 8684C 8685C A CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC 8686C BAND MATRIX. ITS LOWEST SUBDIAGONAL IS STORED IN THE 8687C LAST N+1-MB POSITIONS OF THE FIRST COLUMN, ITS NEXT 8688C SUBDIAGONAL IN THE LAST N+2-MB POSITIONS OF THE 8689C SECOND COLUMN, FURTHER SUBDIAGONALS SIMILARLY, AND 8690C FINALLY ITS PRINCIPAL DIAGONAL IN THE N POSITIONS 8691C OF THE LAST COLUMN. CONTENTS OF STORAGES NOT PART 8692C OF THE MATRIX ARE ARBITRARY. 8693C 8694C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF 8695C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO 8696C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. 8697C 8698C ON OUTPUT 8699C 8700C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. 8701C 8702C Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. 8703C 8704C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR 8705C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT 8706C AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. 8707C 8708C FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS. 8709C 8710C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 8711C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 8712C 8713C THIS VERSION DATED AUGUST 1983. 8714C 8715C ------------------------------------------------------------------ 8716C 8717 IF (N .LE. NM) GO TO 5 8718 IERR = 10 * N 8719 GO TO 50 8720 5 IF (MB .GT. 0) GO TO 10 8721 IERR = 12 * N 8722 GO TO 50 8723 10 IF (MB .LE. N) GO TO 15 8724 IERR = 12 * N 8725 GO TO 50 8726C 8727 15 IF (MATZ .NE. 0) GO TO 20 8728C .......... FIND EIGENVALUES ONLY .......... 8729 TF = .FALSE. 8730 CALL BANDR(NM,N,MB,A,W,FV1,FV2,TF,Z) 8731 CALL TQLRATL(N,W,FV2,IERR) 8732 GO TO 50 8733C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 8734 20 TF = .TRUE. 8735 CALL BANDR(NM,N,MB,A,W,FV1,FV1,TF,Z) 8736 CALL TQL2L(NM,N,W,FV1,Z,IERR) 8737 50 RETURN 8738 END 8739 SUBROUTINE RSG(NM,N,A,B,W,MATZ,Z,FV1,FV2,IERR) 8740C 8741 INTEGER N,NM,IERR,MATZ 8742 DOUBLE PRECISION A(NM,N),B(NM,N),W(N),Z(NM,N),FV1(N),FV2(N) 8743C 8744C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF 8745C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) 8746C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) 8747C FOR THE REAL SYMMETRIC GENERALIZED EIGENPROBLEM AX = (LAMBDA)BX. 8748C 8749C ON INPUT 8750C 8751C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL 8752C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 8753C DIMENSION STATEMENT. 8754C 8755C N IS THE ORDER OF THE MATRICES A AND B. 8756C 8757C A CONTAINS A REAL SYMMETRIC MATRIX. 8758C 8759C B CONTAINS A POSITIVE DEFINITE REAL SYMMETRIC MATRIX. 8760C 8761C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF 8762C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO 8763C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. 8764C 8765C ON OUTPUT 8766C 8767C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. 8768C 8769C Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. 8770C 8771C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR 8772C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT 8773C AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. 8774C 8775C FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS. 8776C 8777C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 8778C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 8779C 8780C THIS VERSION DATED AUGUST 1983. 8781C 8782C ------------------------------------------------------------------ 8783C 8784 IF (N .LE. NM) GO TO 10 8785 IERR = 10 * N 8786 GO TO 50 8787C 8788 10 CALL REDUCL(NM,N,A,B,FV2,IERR) 8789 IF (IERR .NE. 0) GO TO 50 8790 IF (MATZ .NE. 0) GO TO 20 8791C .......... FIND EIGENVALUES ONLY .......... 8792 CALL TRED1L(NM,N,A,W,FV1,FV2) 8793 CALL TQLRATL(N,W,FV2,IERR) 8794 GO TO 50 8795C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 8796 20 CALL TRED2L(NM,N,A,W,FV1,Z) 8797 CALL TQL2L(NM,N,W,FV1,Z,IERR) 8798 IF (IERR .NE. 0) GO TO 50 8799 CALL REBAKL(NM,N,B,FV2,N,Z) 8800 50 RETURN 8801 END 8802 SUBROUTINE RSGAB(NM,N,A,B,W,MATZ,Z,FV1,FV2,IERR) 8803C 8804 INTEGER N,NM,IERR,MATZ 8805 DOUBLE PRECISION A(NM,N),B(NM,N),W(N),Z(NM,N),FV1(N),FV2(N) 8806C 8807C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF 8808C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) 8809C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) 8810C FOR THE REAL SYMMETRIC GENERALIZED EIGENPROBLEM ABX = (LAMBDA)X. 8811C 8812C ON INPUT 8813C 8814C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL 8815C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 8816C DIMENSION STATEMENT. 8817C 8818C N IS THE ORDER OF THE MATRICES A AND B. 8819C 8820C A CONTAINS A REAL SYMMETRIC MATRIX. 8821C 8822C B CONTAINS A POSITIVE DEFINITE REAL SYMMETRIC MATRIX. 8823C 8824C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF 8825C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO 8826C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. 8827C 8828C ON OUTPUT 8829C 8830C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. 8831C 8832C Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. 8833C 8834C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR 8835C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT 8836C AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. 8837C 8838C FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS. 8839C 8840C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 8841C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 8842C 8843C THIS VERSION DATED AUGUST 1983. 8844C 8845C ------------------------------------------------------------------ 8846C 8847 IF (N .LE. NM) GO TO 10 8848 IERR = 10 * N 8849 GO TO 50 8850C 8851 10 CALL REDUC2(NM,N,A,B,FV2,IERR) 8852 IF (IERR .NE. 0) GO TO 50 8853 IF (MATZ .NE. 0) GO TO 20 8854C .......... FIND EIGENVALUES ONLY .......... 8855 CALL TRED1L(NM,N,A,W,FV1,FV2) 8856 CALL TQLRATL(N,W,FV2,IERR) 8857 GO TO 50 8858C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 8859 20 CALL TRED2L(NM,N,A,W,FV1,Z) 8860 CALL TQL2L(NM,N,W,FV1,Z,IERR) 8861 IF (IERR .NE. 0) GO TO 50 8862 CALL REBAKL(NM,N,B,FV2,N,Z) 8863 50 RETURN 8864 END 8865 SUBROUTINE RSGBA(NM,N,A,B,W,MATZ,Z,FV1,FV2,IERR) 8866C 8867 INTEGER N,NM,IERR,MATZ 8868 DOUBLE PRECISION A(NM,N),B(NM,N),W(N),Z(NM,N),FV1(N),FV2(N) 8869C 8870C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF 8871C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) 8872C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) 8873C FOR THE REAL SYMMETRIC GENERALIZED EIGENPROBLEM BAX = (LAMBDA)X. 8874C 8875C ON INPUT 8876C 8877C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL 8878C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 8879C DIMENSION STATEMENT. 8880C 8881C N IS THE ORDER OF THE MATRICES A AND B. 8882C 8883C A CONTAINS A REAL SYMMETRIC MATRIX. 8884C 8885C B CONTAINS A POSITIVE DEFINITE REAL SYMMETRIC MATRIX. 8886C 8887C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF 8888C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO 8889C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. 8890C 8891C ON OUTPUT 8892C 8893C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. 8894C 8895C Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. 8896C 8897C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR 8898C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT 8899C AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. 8900C 8901C FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS. 8902C 8903C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 8904C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 8905C 8906C THIS VERSION DATED AUGUST 1983. 8907C 8908C ------------------------------------------------------------------ 8909C 8910 IF (N .LE. NM) GO TO 10 8911 IERR = 10 * N 8912 GO TO 50 8913C 8914 10 CALL REDUC2(NM,N,A,B,FV2,IERR) 8915 IF (IERR .NE. 0) GO TO 50 8916 IF (MATZ .NE. 0) GO TO 20 8917C .......... FIND EIGENVALUES ONLY .......... 8918 CALL TRED1L(NM,N,A,W,FV1,FV2) 8919 CALL TQLRATL(N,W,FV2,IERR) 8920 GO TO 50 8921C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 8922 20 CALL TRED2L(NM,N,A,W,FV1,Z) 8923 CALL TQL2L(NM,N,W,FV1,Z,IERR) 8924 IF (IERR .NE. 0) GO TO 50 8925 CALL REBAKB(NM,N,B,FV2,N,Z) 8926 50 RETURN 8927 END 8928 SUBROUTINE RSM(NM,N,A,W,M,Z,FWORK,IWORK,IERR) 8929C 8930 INTEGER N,NM,M,IWORK(N),IERR 8931 DOUBLE PRECISION A(NM,N),W(N),Z(NM,M),FWORK(1) 8932C 8933C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF 8934C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) 8935C TO FIND ALL OF THE EIGENVALUES AND SOME OF THE EIGENVECTORS 8936C OF A REAL SYMMETRIC MATRIX. 8937C 8938C ON INPUT 8939C 8940C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL 8941C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 8942C DIMENSION STATEMENT. 8943C 8944C N IS THE ORDER OF THE MATRIX A. 8945C 8946C A CONTAINS THE REAL SYMMETRIC MATRIX. 8947C 8948C M THE EIGENVECTORS CORRESPONDING TO THE FIRST M EIGENVALUES 8949C ARE TO BE COMPUTED. 8950C IF M = 0 THEN NO EIGENVECTORS ARE COMPUTED. 8951C IF M = N THEN ALL OF THE EIGENVECTORS ARE COMPUTED. 8952C 8953C ON OUTPUT 8954C 8955C W CONTAINS ALL N EIGENVALUES IN ASCENDING ORDER. 8956C 8957C Z CONTAINS THE ORTHONORMAL EIGENVECTORS ASSOCIATED WITH 8958C THE FIRST M EIGENVALUES. 8959C 8960C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR 8961C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT, 8962C IMTQLV AND TINVIT. THE NORMAL COMPLETION CODE IS ZERO. 8963C 8964C FWORK IS A TEMPORARY STORAGE ARRAY OF DIMENSION 8*N. 8965C 8966C IWORK IS AN INTEGER TEMPORARY STORAGE ARRAY OF DIMENSION N. 8967C 8968C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 8969C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 8970C 8971C THIS VERSION DATED AUGUST 1983. 8972C 8973C ------------------------------------------------------------------ 8974C 8975 IERR = 10 * N 8976 IF (N .GT. NM .OR. M .GT. NM) GO TO 50 8977 K1 = 1 8978 K2 = K1 + N 8979 K3 = K2 + N 8980 K4 = K3 + N 8981 K5 = K4 + N 8982 K6 = K5 + N 8983 K7 = K6 + N 8984 K8 = K7 + N 8985 IF (M .GT. 0) GO TO 10 8986C .......... FIND EIGENVALUES ONLY .......... 8987 CALL TRED1L(NM,N,A,W,FWORK(K1),FWORK(K2)) 8988 CALL TQLRATL(N,W,FWORK(K2),IERR) 8989 GO TO 50 8990C .......... FIND ALL EIGENVALUES AND M EIGENVECTORS .......... 8991 10 CALL TRED1L(NM,N,A,FWORK(K1),FWORK(K2),FWORK(K3)) 8992 CALL IMTQLV(N,FWORK(K1),FWORK(K2),FWORK(K3),W,IWORK, 8993 X IERR,FWORK(K4)) 8994 CALL TINVIT(NM,N,FWORK(K1),FWORK(K2),FWORK(K3),M,W,IWORK,Z,IERR, 8995 X FWORK(K4),FWORK(K5),FWORK(K6),FWORK(K7),FWORK(K8)) 8996 CALL TRBAK1(NM,N,A,FWORK(K2),M,Z) 8997 50 RETURN 8998 END 8999 SUBROUTINE RSP(NM,N,NV,A,W,MATZ,Z,FV1,FV2,IERR) 9000C 9001 INTEGER I,J,N,NM,NV,IERR,MATZ 9002 DOUBLE PRECISION A(NV),W(N),Z(NM,N),FV1(N),FV2(N) 9003C 9004C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF 9005C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) 9006C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) 9007C OF A REAL SYMMETRIC PACKED MATRIX. 9008C 9009C ON INPUT 9010C 9011C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL 9012C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 9013C DIMENSION STATEMENT. 9014C 9015C N IS THE ORDER OF THE MATRIX A. 9016C 9017C NV IS AN INTEGER VARIABLE SET EQUAL TO THE 9018C DIMENSION OF THE ARRAY A AS SPECIFIED FOR 9019C A IN THE CALLING PROGRAM. NV MUST NOT BE 9020C LESS THAN N*(N+1)/2. 9021C 9022C A CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC 9023C PACKED MATRIX STORED ROW-WISE. 9024C 9025C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF 9026C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO 9027C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. 9028C 9029C ON OUTPUT 9030C 9031C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. 9032C 9033C Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. 9034C 9035C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR 9036C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT 9037C AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. 9038C 9039C FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS. 9040C 9041C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 9042C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 9043C 9044C THIS VERSION DATED AUGUST 1983. 9045C 9046C ------------------------------------------------------------------ 9047C 9048 IF (N .LE. NM) GO TO 5 9049 IERR = 10 * N 9050 GO TO 50 9051 5 IF (NV .GE. (N * (N + 1)) / 2) GO TO 10 9052 IERR = 20 * N 9053 GO TO 50 9054C 9055 10 CALL TRED3L(N,NV,A,W,FV1,FV2) 9056 IF (MATZ .NE. 0) GO TO 20 9057C .......... FIND EIGENVALUES ONLY .......... 9058 CALL TQLRATL(N,W,FV2,IERR) 9059 GO TO 50 9060C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 9061 20 DO 40 I = 1, N 9062C 9063 DO 30 J = 1, N 9064 Z(J,I) = 0.0D0 9065 30 CONTINUE 9066C 9067 Z(I,I) = 1.0D0 9068 40 CONTINUE 9069C 9070 CALL TQL2L(NM,N,W,FV1,Z,IERR) 9071 IF (IERR .NE. 0) GO TO 50 9072 CALL TRBAK3(NM,N,NV,A,N,Z) 9073 50 RETURN 9074 END 9075 SUBROUTINE RST(NM,N,W,E,MATZ,Z,IERR) 9076C 9077 INTEGER I,J,N,NM,IERR,MATZ 9078 DOUBLE PRECISION W(N),E(N),Z(NM,N) 9079C 9080C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF 9081C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) 9082C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) 9083C OF A REAL SYMMETRIC TRIDIAGONAL MATRIX. 9084C 9085C ON INPUT 9086C 9087C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL 9088C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 9089C DIMENSION STATEMENT. 9090C 9091C N IS THE ORDER OF THE MATRIX. 9092C 9093C W CONTAINS THE DIAGONAL ELEMENTS OF THE REAL 9094C SYMMETRIC TRIDIAGONAL MATRIX. 9095C 9096C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE MATRIX IN 9097C ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. 9098C 9099C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF 9100C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO 9101C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. 9102C 9103C ON OUTPUT 9104C 9105C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. 9106C 9107C Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. 9108C 9109C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR 9110C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR IMTQL1 9111C AND IMTQL2. THE NORMAL COMPLETION CODE IS ZERO. 9112C 9113C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 9114C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 9115C 9116C THIS VERSION DATED AUGUST 1983. 9117C 9118C ------------------------------------------------------------------ 9119C 9120 IF (N .LE. NM) GO TO 10 9121 IERR = 10 * N 9122 GO TO 50 9123C 9124 10 IF (MATZ .NE. 0) GO TO 20 9125C .......... FIND EIGENVALUES ONLY .......... 9126 CALL IMTQL1(N,W,E,IERR) 9127 GO TO 50 9128C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 9129 20 DO 40 I = 1, N 9130C 9131 DO 30 J = 1, N 9132 Z(J,I) = 0.0D0 9133 30 CONTINUE 9134C 9135 Z(I,I) = 1.0D0 9136 40 CONTINUE 9137C 9138 CALL IMTQL2(NM,N,W,E,Z,IERR) 9139 50 RETURN 9140 END 9141 SUBROUTINE RT(NM,N,A,W,MATZ,Z,FV1,IERR) 9142C 9143 INTEGER N,NM,IERR,MATZ 9144 DOUBLE PRECISION A(NM,3),W(N),Z(NM,N),FV1(N) 9145C 9146C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF 9147C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) 9148C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) 9149C OF A SPECIAL REAL TRIDIAGONAL MATRIX. 9150C 9151C ON INPUT 9152C 9153C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL 9154C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 9155C DIMENSION STATEMENT. 9156C 9157C N IS THE ORDER OF THE MATRIX A. 9158C 9159C A CONTAINS THE SPECIAL REAL TRIDIAGONAL MATRIX IN ITS 9160C FIRST THREE COLUMNS. THE SUBDIAGONAL ELEMENTS ARE STORED 9161C IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN, THE 9162C DIAGONAL ELEMENTS IN THE SECOND COLUMN, AND THE SUPERDIAGONAL 9163C ELEMENTS IN THE FIRST N-1 POSITIONS OF THE THIRD COLUMN. 9164C ELEMENTS A(1,1) AND A(N,3) ARE ARBITRARY. 9165C 9166C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF 9167C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO 9168C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. 9169C 9170C ON OUTPUT 9171C 9172C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. 9173C 9174C Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. 9175C 9176C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR 9177C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR IMTQL1 9178C AND IMTQL2. THE NORMAL COMPLETION CODE IS ZERO. 9179C 9180C FV1 IS A TEMPORARY STORAGE ARRAY. 9181C 9182C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 9183C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 9184C 9185C THIS VERSION DATED AUGUST 1983. 9186C 9187C ------------------------------------------------------------------ 9188C 9189 IF (N .LE. NM) GO TO 10 9190 IERR = 10 * N 9191 GO TO 50 9192C 9193 10 IF (MATZ .NE. 0) GO TO 20 9194C .......... FIND EIGENVALUES ONLY .......... 9195 CALL FIGI(NM,N,A,W,FV1,FV1,IERR) 9196 IF (IERR .GT. 0) GO TO 50 9197 CALL IMTQL1(N,W,FV1,IERR) 9198 GO TO 50 9199C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 9200 20 CALL FIGI2(NM,N,A,W,FV1,Z,IERR) 9201 IF (IERR .NE. 0) GO TO 50 9202 CALL IMTQL2(NM,N,W,FV1,Z,IERR) 9203 50 RETURN 9204 END 9205 SUBROUTINE SVD(NM,M,N,A,W,MATU,U,MATV,V,IERR,RV1) 9206C 9207 INTEGER I,J,K,L,M,N,II,I1,KK,K1,LL,L1,MN,NM,ITS,IERR 9208 DOUBLE PRECISION A(NM,N),W(N),U(NM,N),V(NM,N),RV1(N) 9209 DOUBLE PRECISION C,F,G,H,S,X,Y,Z,TST1,TST2,SCALE,PYTHAG 9210 LOGICAL MATU,MATV 9211C To avoid compiler bug (WK/UniKA/11-11-2002). 9212 INTEGER LUDUMM, IDUMMY 9213C 9214C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE SVD, 9215C NUM. MATH. 14, 403-420(1970) BY GOLUB AND REINSCH. 9216C HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 134-151(1971). 9217C 9218C THIS SUBROUTINE DETERMINES THE SINGULAR VALUE DECOMPOSITION 9219C T 9220C A=USV OF A REAL M BY N RECTANGULAR MATRIX. HOUSEHOLDER 9221C BIDIAGONALIZATION AND A VARIANT OF THE QR ALGORITHM ARE USED. 9222C 9223C ON INPUT 9224C 9225C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 9226C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 9227C DIMENSION STATEMENT. NOTE THAT NM MUST BE AT LEAST 9228C AS LARGE AS THE MAXIMUM OF M AND N. 9229C 9230C M IS THE NUMBER OF ROWS OF A (AND U). 9231C 9232C N IS THE NUMBER OF COLUMNS OF A (AND U) AND THE ORDER OF V. 9233C 9234C A CONTAINS THE RECTANGULAR INPUT MATRIX TO BE DECOMPOSED. 9235C 9236C MATU SHOULD BE SET TO .TRUE. IF THE U MATRIX IN THE 9237C DECOMPOSITION IS DESIRED, AND TO .FALSE. OTHERWISE. 9238C 9239C MATV SHOULD BE SET TO .TRUE. IF THE V MATRIX IN THE 9240C DECOMPOSITION IS DESIRED, AND TO .FALSE. OTHERWISE. 9241C 9242C ON OUTPUT 9243C 9244C A IS UNALTERED (UNLESS OVERWRITTEN BY U OR V). 9245C 9246C W CONTAINS THE N (NON-NEGATIVE) SINGULAR VALUES OF A (THE 9247C DIAGONAL ELEMENTS OF S). THEY ARE UNORDERED. IF AN 9248C ERROR EXIT IS MADE, THE SINGULAR VALUES SHOULD BE CORRECT 9249C FOR INDICES IERR+1,IERR+2,...,N. 9250C 9251C U CONTAINS THE MATRIX U (ORTHOGONAL COLUMN VECTORS) OF THE 9252C DECOMPOSITION IF MATU HAS BEEN SET TO .TRUE. OTHERWISE 9253C U IS USED AS A TEMPORARY ARRAY. U MAY COINCIDE WITH A. 9254C IF AN ERROR EXIT IS MADE, THE COLUMNS OF U CORRESPONDING 9255C TO INDICES OF CORRECT SINGULAR VALUES SHOULD BE CORRECT. 9256C 9257C V CONTAINS THE MATRIX V (ORTHOGONAL) OF THE DECOMPOSITION IF 9258C MATV HAS BEEN SET TO .TRUE. OTHERWISE V IS NOT REFERENCED. 9259C V MAY ALSO COINCIDE WITH A IF U IS NOT NEEDED. IF AN ERROR 9260C EXIT IS MADE, THE COLUMNS OF V CORRESPONDING TO INDICES OF 9261C CORRECT SINGULAR VALUES SHOULD BE CORRECT. 9262C 9263C IERR IS SET TO 9264C ZERO FOR NORMAL RETURN, 9265C K IF THE K-TH SINGULAR VALUE HAS NOT BEEN 9266C DETERMINED AFTER 30 ITERATIONS. 9267C 9268C RV1 IS A TEMPORARY STORAGE ARRAY. 9269C 9270C CALLS PYTHAG FOR DSQRT(A*A + B*B) . 9271C 9272C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 9273C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 9274C 9275C THIS VERSION DATED AUGUST 1983. 9276C 9277C ------------------------------------------------------------------ 9278C 9279 IERR = 0 9280C 9281 DO 100 I = 1, M 9282C 9283 DO 100 J = 1, N 9284 U(I,J) = A(I,J) 9285 100 CONTINUE 9286C .......... HOUSEHOLDER REDUCTION TO BIDIAGONAL FORM .......... 9287 G = 0.0D0 9288 SCALE = 0.0D0 9289 X = 0.0D0 9290C 9291 DO 300 I = 1, N 9292 L = I + 1 9293 RV1(I) = SCALE * G 9294 G = 0.0D0 9295 S = 0.0D0 9296 SCALE = 0.0D0 9297 IF (I .GT. M) GO TO 210 9298C 9299 DO 120 K = I, M 9300 120 SCALE = SCALE + DABS(U(K,I)) 9301C 9302 IF (SCALE .EQ. 0.0D0) GO TO 210 9303C 9304 DO 130 K = I, M 9305 U(K,I) = U(K,I) / SCALE 9306 S = S + U(K,I)**2 9307 130 CONTINUE 9308C 9309 F = U(I,I) 9310 G = -DSIGN(DSQRT(S),F) 9311 H = F * G - S 9312 U(I,I) = F - G 9313 IF (I .EQ. N) GO TO 190 9314C 9315 DO 150 J = L, N 9316 S = 0.0D0 9317C 9318 DO 140 K = I, M 9319 140 S = S + U(K,I) * U(K,J) 9320C 9321 F = S / H 9322C 9323 DO 150 K = I, M 9324 U(K,J) = U(K,J) + F * U(K,I) 9325 150 CONTINUE 9326C 9327 190 DO 200 K = I, M 9328 200 U(K,I) = SCALE * U(K,I) 9329C 9330 210 W(I) = SCALE * G 9331 G = 0.0D0 9332 S = 0.0D0 9333 SCALE = 0.0D0 9334 IF (I .GT. M .OR. I .EQ. N) GO TO 290 9335C 9336 DO 220 K = L, N 9337 220 SCALE = SCALE + DABS(U(I,K)) 9338C 9339 IF (SCALE .EQ. 0.0D0) GO TO 290 9340C 9341 DO 230 K = L, N 9342 U(I,K) = U(I,K) / SCALE 9343 S = S + U(I,K)**2 9344 230 CONTINUE 9345C 9346 F = U(I,L) 9347 G = -DSIGN(DSQRT(S),F) 9348 H = F * G - S 9349 U(I,L) = F - G 9350C 9351 DO 240 K = L, N 9352 240 RV1(K) = U(I,K) / H 9353C 9354 IF (I .EQ. M) GO TO 270 9355C 9356 DO 260 J = L, M 9357 S = 0.0D0 9358C 9359 DO 250 K = L, N 9360 250 S = S + U(J,K) * U(I,K) 9361C 9362 DO 260 K = L, N 9363 U(J,K) = U(J,K) + S * RV1(K) 9364 260 CONTINUE 9365C 9366 270 DO 280 K = L, N 9367 280 U(I,K) = SCALE * U(I,K) 9368C 9369 290 X = DMAX1(X,DABS(W(I))+DABS(RV1(I))) 9370 300 CONTINUE 9371C .......... ACCUMULATION OF RIGHT-HAND TRANSFORMATIONS .......... 9372 IF (.NOT. MATV) GO TO 410 9373C .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... 9374 DO 400 II = 1, N 9375 I = N + 1 - II 9376 IF (I .EQ. N) GO TO 390 9377 IF (G .EQ. 0.0D0) GO TO 360 9378C 9379 DO 320 J = L, N 9380C .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW .......... 9381 320 V(J,I) = (U(I,J) / U(I,L)) / G 9382C 9383 DO 350 J = L, N 9384 S = 0.0D0 9385C 9386 DO 340 K = L, N 9387 340 S = S + U(I,K) * V(K,J) 9388C 9389 DO 350 K = L, N 9390 V(K,J) = V(K,J) + S * V(K,I) 9391 350 CONTINUE 9392C 9393 360 DO 380 J = L, N 9394 V(I,J) = 0.0D0 9395 V(J,I) = 0.0D0 9396 380 CONTINUE 9397C 9398 390 V(I,I) = 1.0D0 9399 G = RV1(I) 9400 L = I 9401 400 CONTINUE 9402C .......... ACCUMULATION OF LEFT-HAND TRANSFORMATIONS .......... 9403 410 IF (.NOT. MATU) GO TO 510 9404C ..........FOR I=MIN(M,N) STEP -1 UNTIL 1 DO -- .......... 9405 MN = N 9406 IF (M .LT. N) MN = M 9407C 9408 DO 500 II = 1, MN 9409 I = MN + 1 - II 9410 L = I + 1 9411 G = W(I) 9412 IF (I .EQ. N) GO TO 430 9413C 9414 DO 420 J = L, N 9415 420 U(I,J) = 0.0D0 9416C 9417 430 IF (G .EQ. 0.0D0) GO TO 475 9418 IF (I .EQ. MN) GO TO 460 9419C 9420 DO 450 J = L, N 9421 S = 0.0D0 9422C 9423 DO 440 K = L, M 9424 440 S = S + U(K,I) * U(K,J) 9425C .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW .......... 9426 F = (S / U(I,I)) / G 9427C 9428 DO 450 K = I, M 9429 U(K,J) = U(K,J) + F * U(K,I) 9430 450 CONTINUE 9431C 9432 460 DO 470 J = I, M 9433 470 U(J,I) = U(J,I) / G 9434C 9435 GO TO 490 9436C 9437 475 DO 480 J = I, M 9438 480 U(J,I) = 0.0D0 9439C 9440 490 U(I,I) = U(I,I) + 1.0D0 9441 500 CONTINUE 9442C .......... DIAGONALIZATION OF THE BIDIAGONAL FORM .......... 9443 510 TST1 = X 9444C .......... FOR K=N STEP -1 UNTIL 1 DO -- .......... 9445 DO 700 KK = 1, N 9446 K1 = N - KK 9447 K = K1 + 1 9448 ITS = 0 9449C .......... TEST FOR SPLITTING. 9450C FOR L=K STEP -1 UNTIL 1 DO -- .......... 9451 520 DO 530 LL = 1, K 9452 L1 = K - LL 9453 L = L1 + 1 9454 TST2 = TST1 + DABS(RV1(L)) 9455 IF (TST2 .EQ. TST1) GO TO 565 9456C .......... RV1(1) IS ALWAYS ZERO, SO THERE IS NO EXIT 9457C THROUGH THE BOTTOM OF THE LOOP .......... 9458 TST2 = TST1 + DABS(W(L1)) 9459 IF (TST2 .EQ. TST1) GO TO 540 9460 530 CONTINUE 9461C .......... CANCELLATION OF RV1(L) IF L GREATER THAN 1 .......... 9462 540 C = 0.0D0 9463 S = 1.0D0 9464C 9465 DO 560 I = L, K 9466 F = S * RV1(I) 9467 RV1(I) = C * RV1(I) 9468 TST2 = TST1 + DABS(F) 9469 IF (TST2 .EQ. TST1) GO TO 565 9470 G = W(I) 9471 H = PYTHAG(F,G) 9472 W(I) = H 9473 C = G / H 9474 S = -F / H 9475 IF (.NOT. MATU) GO TO 560 9476C 9477 DO 550 J = 1, M 9478 Y = U(J,L1) 9479 Z = U(J,I) 9480 U(J,L1) = Y * C + Z * S 9481 U(J,I) = -Y * S + Z * C 9482 550 CONTINUE 9483C 9484 560 CONTINUE 9485C .......... TEST FOR CONVERGENCE .......... 9486 565 Z = W(K) 9487 IF (L .EQ. K) GO TO 650 9488C .......... SHIFT FROM BOTTOM 2 BY 2 MINOR .......... 9489 IF (ITS .EQ. 30) GO TO 1000 9490 ITS = ITS + 1 9491 X = W(L) 9492 Y = W(K1) 9493 G = RV1(K1) 9494 H = RV1(K) 9495 F = 0.5D0 * (((G + Z) / H) * ((G - Z) / Y) + Y / H - H / Y) 9496 G = PYTHAG(F,1.0D0) 9497 F = X - (Z / X) * Z + (H / X) * (Y / (F + DSIGN(G,F)) - H) 9498C .......... NEXT QR TRANSFORMATION .......... 9499 C = 1.0D0 9500 S = 1.0D0 9501C 9502 DO 600 I1 = L, K1 9503 I = I1 + 1 9504 G = RV1(I) 9505 Y = W(I) 9506 H = S * G 9507 G = C * G 9508 Z = PYTHAG(F,H) 9509 RV1(I1) = Z 9510 C = F / Z 9511 S = H / Z 9512 F = X * C + G * S 9513 G = -X * S + G * C 9514 H = Y * S 9515 Y = Y * C 9516 IF (.NOT. MATV) GO TO 575 9517C 9518 DO 570 J = 1, N 9519 X = V(J,I1) 9520 Z = V(J,I) 9521 V(J,I1) = X * C + Z * S 9522 V(J,I) = -X * S + Z * C 9523 570 CONTINUE 9524C 9525 575 Z = PYTHAG(F,H) 9526 W(I1) = Z 9527C .......... ROTATION CAN BE ARBITRARY IF Z IS ZERO .......... 9528 IF (Z .EQ. 0.0D0) GO TO 580 9529 C = F / Z 9530 S = H / Z 9531 580 F = C * G + S * Y 9532 X = -S * G + C * Y 9533 IF (.NOT. MATU) GO TO 600 9534C 9535 DO 590 J = 1, M 9536 Y = U(J,I1) 9537 Z = U(J,I) 9538 U(J,I1) = Y * C + Z * S 9539 U(J,I) = -Y * S + Z * C 9540 590 CONTINUE 9541C 9542 600 CONTINUE 9543C 9544 RV1(L) = 0.0D0 9545 RV1(K) = F 9546 W(K) = X 9547 GO TO 520 9548C .......... CONVERGENCE .......... 9549 650 IF (Z .GE. 0.0D0) GO TO 700 9550C .......... W(K) IS MADE NON-NEGATIVE .......... 9551 W(K) = -Z 9552 IF (.NOT. MATV) GO TO 700 9553C 9554 DO 690 J = 1, N 9555 690 V(J,K) = -V(J,K) 9556C 9557 700 CONTINUE 9558C 9559 GO TO 1001 9560C .......... SET ERROR -- NO CONVERGENCE TO A 9561C SINGULAR VALUE AFTER 30 ITERATIONS .......... 9562 1000 IERR = K 9563 1001 RETURN 9564 END 9565 SUBROUTINE TINVIT(NM,N,D,E,E2,M,W,IND,Z, 9566 X IERR,RV1,RV2,RV3,RV4,RV6) 9567C 9568 INTEGER I,J,M,N,P,Q,R,S,II,IP,JJ,NM,ITS,TAG,IERR,GROUP 9569 DOUBLE PRECISION D(N),E(N),E2(N),W(M),Z(NM,M), 9570 X RV1(N),RV2(N),RV3(N),RV4(N),RV6(N) 9571 DOUBLE PRECISION U,V,UK,XU,X0,X1,EPS2,EPS3,EPS4,NORM,ORDER,EPSLON, 9572 X PYTHAG 9573 INTEGER IND(M) 9574C 9575C THIS SUBROUTINE IS A TRANSLATION OF THE INVERSE ITERATION TECH- 9576C NIQUE IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON. 9577C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). 9578C 9579C THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A TRIDIAGONAL 9580C SYMMETRIC MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES, 9581C USING INVERSE ITERATION. 9582C 9583C ON INPUT 9584C 9585C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 9586C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 9587C DIMENSION STATEMENT. 9588C 9589C N IS THE ORDER OF THE MATRIX. 9590C 9591C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. 9592C 9593C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX 9594C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. 9595C 9596C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E, 9597C WITH ZEROS CORRESPONDING TO NEGLIGIBLE ELEMENTS OF E. 9598C E(I) IS CONSIDERED NEGLIGIBLE IF IT IS NOT LARGER THAN 9599C THE PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE SUM 9600C OF THE MAGNITUDES OF D(I) AND D(I-1). E2(1) MUST CONTAIN 9601C 0.0D0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, OR 2.0D0 9602C IF THE EIGENVALUES ARE IN DESCENDING ORDER. IF BISECT, 9603C TRIDIB, OR IMTQLV HAS BEEN USED TO FIND THE EIGENVALUES, 9604C THEIR OUTPUT E2 ARRAY IS EXACTLY WHAT IS EXPECTED HERE. 9605C 9606C M IS THE NUMBER OF SPECIFIED EIGENVALUES. 9607C 9608C W CONTAINS THE M EIGENVALUES IN ASCENDING OR DESCENDING ORDER. 9609C 9610C IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES 9611C ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W -- 9612C 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM 9613C THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC. 9614C 9615C ON OUTPUT 9616C 9617C ALL INPUT ARRAYS ARE UNALTERED. 9618C 9619C Z CONTAINS THE ASSOCIATED SET OF ORTHONORMAL EIGENVECTORS. 9620C ANY VECTOR WHICH FAILS TO CONVERGE IS SET TO ZERO. 9621C 9622C IERR IS SET TO 9623C ZERO FOR NORMAL RETURN, 9624C -R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH 9625C EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS. 9626C 9627C RV1, RV2, RV3, RV4, AND RV6 ARE TEMPORARY STORAGE ARRAYS. 9628C 9629C CALLS PYTHAG FOR DSQRT(A*A + B*B) . 9630C 9631C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 9632C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 9633C 9634C THIS VERSION DATED AUGUST 1983. 9635C 9636C ------------------------------------------------------------------ 9637C 9638 IERR = 0 9639 IF (M .EQ. 0) GO TO 1001 9640 TAG = 0 9641 ORDER = 1.0D0 - E2(1) 9642 Q = 0 9643C .......... ESTABLISH AND PROCESS NEXT SUBMATRIX .......... 9644 100 P = Q + 1 9645C 9646 DO 120 Q = P, N 9647 IF (Q .EQ. N) GO TO 140 9648 IF (E2(Q+1) .EQ. 0.0D0) GO TO 140 9649 120 CONTINUE 9650C .......... FIND VECTORS BY INVERSE ITERATION .......... 9651 140 TAG = TAG + 1 9652 S = 0 9653C 9654 DO 920 R = 1, M 9655 IF (IND(R) .NE. TAG) GO TO 920 9656 ITS = 1 9657 X1 = W(R) 9658 IF (S .NE. 0) GO TO 510 9659C .......... CHECK FOR ISOLATED ROOT .......... 9660 XU = 1.0D0 9661 IF (P .NE. Q) GO TO 490 9662 RV6(P) = 1.0D0 9663 GO TO 870 9664 490 NORM = DABS(D(P)) 9665 IP = P + 1 9666C 9667 DO 500 I = IP, Q 9668 500 NORM = DMAX1(NORM, DABS(D(I))+DABS(E(I))) 9669C .......... EPS2 IS THE CRITERION FOR GROUPING, 9670C EPS3 REPLACES ZERO PIVOTS AND EQUAL 9671C ROOTS ARE MODIFIED BY EPS3, 9672C EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW .......... 9673 EPS2 = 1.0D-3 * NORM 9674 EPS3 = EPSLON(NORM) 9675 UK = Q - P + 1 9676 EPS4 = UK * EPS3 9677 UK = EPS4 / DSQRT(UK) 9678 S = P 9679 505 GROUP = 0 9680 GO TO 520 9681C .......... LOOK FOR CLOSE OR COINCIDENT ROOTS .......... 9682 510 IF (DABS(X1-X0) .GE. EPS2) GO TO 505 9683 GROUP = GROUP + 1 9684 IF (ORDER * (X1 - X0) .LE. 0.0D0) X1 = X0 + ORDER * EPS3 9685C .......... ELIMINATION WITH INTERCHANGES AND 9686C INITIALIZATION OF VECTOR .......... 9687 520 V = 0.0D0 9688C 9689 DO 580 I = P, Q 9690 RV6(I) = UK 9691 IF (I .EQ. P) GO TO 560 9692 IF (DABS(E(I)) .LT. DABS(U)) GO TO 540 9693C .......... WARNING -- A DIVIDE CHECK MAY OCCUR HERE IF 9694C E2 ARRAY HAS NOT BEEN SPECIFIED CORRECTLY .......... 9695 XU = U / E(I) 9696 RV4(I) = XU 9697 RV1(I-1) = E(I) 9698 RV2(I-1) = D(I) - X1 9699 RV3(I-1) = 0.0D0 9700 IF (I .NE. Q) RV3(I-1) = E(I+1) 9701 U = V - XU * RV2(I-1) 9702 V = -XU * RV3(I-1) 9703 GO TO 580 9704 540 XU = E(I) / U 9705 RV4(I) = XU 9706 RV1(I-1) = U 9707 RV2(I-1) = V 9708 RV3(I-1) = 0.0D0 9709 560 U = D(I) - X1 - XU * V 9710 IF (I .NE. Q) V = E(I+1) 9711 580 CONTINUE 9712C 9713 IF (U .EQ. 0.0D0) U = EPS3 9714 RV1(Q) = U 9715 RV2(Q) = 0.0D0 9716 RV3(Q) = 0.0D0 9717C .......... BACK SUBSTITUTION 9718C FOR I=Q STEP -1 UNTIL P DO -- .......... 9719 600 DO 620 II = P, Q 9720 I = P + Q - II 9721 RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I) 9722 V = U 9723 U = RV6(I) 9724 620 CONTINUE 9725C .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS 9726C MEMBERS OF GROUP .......... 9727 IF (GROUP .EQ. 0) GO TO 700 9728 J = R 9729C 9730 DO 680 JJ = 1, GROUP 9731 630 J = J - 1 9732 IF (IND(J) .NE. TAG) GO TO 630 9733 XU = 0.0D0 9734C 9735 DO 640 I = P, Q 9736 640 XU = XU + RV6(I) * Z(I,J) 9737C 9738 DO 660 I = P, Q 9739 660 RV6(I) = RV6(I) - XU * Z(I,J) 9740C 9741 680 CONTINUE 9742C 9743 700 NORM = 0.0D0 9744C 9745 DO 720 I = P, Q 9746 720 NORM = NORM + DABS(RV6(I)) 9747C 9748 IF (NORM .GE. 1.0D0) GO TO 840 9749C .......... FORWARD SUBSTITUTION .......... 9750 IF (ITS .EQ. 5) GO TO 830 9751 IF (NORM .NE. 0.0D0) GO TO 740 9752 RV6(S) = EPS4 9753 S = S + 1 9754 IF (S .GT. Q) S = P 9755 GO TO 780 9756 740 XU = EPS4 / NORM 9757C 9758 DO 760 I = P, Q 9759 760 RV6(I) = RV6(I) * XU 9760C .......... ELIMINATION OPERATIONS ON NEXT VECTOR 9761C ITERATE .......... 9762 780 DO 820 I = IP, Q 9763 U = RV6(I) 9764C .......... IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE 9765C WAS PERFORMED EARLIER IN THE 9766C TRIANGULARIZATION PROCESS .......... 9767 IF (RV1(I-1) .NE. E(I)) GO TO 800 9768 U = RV6(I-1) 9769 RV6(I-1) = RV6(I) 9770 800 RV6(I) = U - RV4(I) * RV6(I-1) 9771 820 CONTINUE 9772C 9773 ITS = ITS + 1 9774 GO TO 600 9775C .......... SET ERROR -- NON-CONVERGED EIGENVECTOR .......... 9776 830 IERR = -R 9777 XU = 0.0D0 9778 GO TO 870 9779C .......... NORMALIZE SO THAT SUM OF SQUARES IS 9780C 1 AND EXPAND TO FULL ORDER .......... 9781 840 U = 0.0D0 9782C 9783 DO 860 I = P, Q 9784 860 U = PYTHAG(U,RV6(I)) 9785C 9786 XU = 1.0D0 / U 9787C 9788 870 DO 880 I = 1, N 9789 880 Z(I,R) = 0.0D0 9790C 9791 DO 900 I = P, Q 9792 900 Z(I,R) = RV6(I) * XU 9793C 9794 X0 = X1 9795 920 CONTINUE 9796C 9797 IF (Q .LT. N) GO TO 100 9798 1001 RETURN 9799 END 9800 SUBROUTINE TQL1(N,D,E,IERR) 9801C 9802 INTEGER I,J,L,M,N,II,L1,L2,MML,IERR 9803 DOUBLE PRECISION D(N),E(N) 9804 DOUBLE PRECISION C,C2,C3,DL1,EL1,F,G,H,P,R,S,S2,TST1,TST2,PYTHAG 9805C 9806C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL1, 9807C NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND 9808C WILKINSON. 9809C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). 9810C 9811C THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC 9812C TRIDIAGONAL MATRIX BY THE QL METHOD. 9813C 9814C ON INPUT 9815C 9816C N IS THE ORDER OF THE MATRIX. 9817C 9818C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. 9819C 9820C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX 9821C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. 9822C 9823C ON OUTPUT 9824C 9825C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN 9826C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND 9827C ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE 9828C THE SMALLEST EIGENVALUES. 9829C 9830C E HAS BEEN DESTROYED. 9831C 9832C IERR IS SET TO 9833C ZERO FOR NORMAL RETURN, 9834C J IF THE J-TH EIGENVALUE HAS NOT BEEN 9835C DETERMINED AFTER 30 ITERATIONS. 9836C 9837C CALLS PYTHAG FOR DSQRT(A*A + B*B) . 9838C 9839C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 9840C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 9841C 9842C THIS VERSION DATED AUGUST 1983. 9843C 9844C ------------------------------------------------------------------ 9845C 9846 IERR = 0 9847 IF (N .EQ. 1) GO TO 1001 9848C 9849 DO 100 I = 2, N 9850 100 E(I-1) = E(I) 9851C 9852 F = 0.0D0 9853 TST1 = 0.0D0 9854 E(N) = 0.0D0 9855C 9856 DO 290 L = 1, N 9857 J = 0 9858 H = DABS(D(L)) + DABS(E(L)) 9859 IF (TST1 .LT. H) TST1 = H 9860C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... 9861 DO 110 M = L, N 9862 TST2 = TST1 + DABS(E(M)) 9863 IF (TST2 .EQ. TST1) GO TO 120 9864C .......... E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT 9865C THROUGH THE BOTTOM OF THE LOOP .......... 9866 110 CONTINUE 9867C 9868 120 IF (M .EQ. L) GO TO 210 9869 130 IF (J .EQ. 30) GO TO 1000 9870 J = J + 1 9871C .......... FORM SHIFT .......... 9872 L1 = L + 1 9873 L2 = L1 + 1 9874 G = D(L) 9875 P = (D(L1) - G) / (2.0D0 * E(L)) 9876 R = PYTHAG(P,1.0D0) 9877 D(L) = E(L) / (P + DSIGN(R,P)) 9878 D(L1) = E(L) * (P + DSIGN(R,P)) 9879 DL1 = D(L1) 9880 H = G - D(L) 9881 IF (L2 .GT. N) GO TO 145 9882C 9883 DO 140 I = L2, N 9884 140 D(I) = D(I) - H 9885C 9886 145 F = F + H 9887C .......... QL TRANSFORMATION .......... 9888 P = D(M) 9889 C = 1.0D0 9890 C2 = C 9891 EL1 = E(L1) 9892 S = 0.0D0 9893 MML = M - L 9894C .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... 9895 DO 200 II = 1, MML 9896 C3 = C2 9897 C2 = C 9898 S2 = S 9899 I = M - II 9900 G = C * E(I) 9901 H = C * P 9902 R = PYTHAG(P,E(I)) 9903 E(I+1) = S * R 9904 S = E(I) / R 9905 C = P / R 9906 P = C * D(I) - S * G 9907 D(I+1) = H + S * (C * G + S * D(I)) 9908 200 CONTINUE 9909C 9910 P = -S * S2 * C3 * EL1 * E(L) / DL1 9911 E(L) = S * P 9912 D(L) = C * P 9913 TST2 = TST1 + DABS(E(L)) 9914 IF (TST2 .GT. TST1) GO TO 130 9915 210 P = D(L) + F 9916C .......... ORDER EIGENVALUES .......... 9917 IF (L .EQ. 1) GO TO 250 9918C .......... FOR I=L STEP -1 UNTIL 2 DO -- .......... 9919 DO 230 II = 2, L 9920 I = L + 2 - II 9921 IF (P .GE. D(I-1)) GO TO 270 9922 D(I) = D(I-1) 9923 230 CONTINUE 9924C 9925 250 I = 1 9926 270 D(I) = P 9927 290 CONTINUE 9928C 9929 GO TO 1001 9930C .......... SET ERROR -- NO CONVERGENCE TO AN 9931C EIGENVALUE AFTER 30 ITERATIONS .......... 9932 1000 IERR = L 9933 1001 RETURN 9934 END 9935 SUBROUTINE TQL2L(NM,N,D,E,Z,IERR) 9936C 9937 INTEGER I,J,K,L,M,N,II,L1,L2,NM,MML,IERR 9938 DOUBLE PRECISION D(N),E(N),Z(NM,N) 9939 DOUBLE PRECISION C,C2,C3,DL1,EL1,F,G,H,P,R,S,S2,TST1,TST2,PYTHAG 9940C 9941C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2, 9942C NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND 9943C WILKINSON. 9944C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). 9945C 9946C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS 9947C OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD. 9948C THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO 9949C BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS 9950C FULL MATRIX TO TRIDIAGONAL FORM. 9951C 9952C ON INPUT 9953C 9954C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 9955C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 9956C DIMENSION STATEMENT. 9957C 9958C N IS THE ORDER OF THE MATRIX. 9959C 9960C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. 9961C 9962C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX 9963C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. 9964C 9965C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE 9966C REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS 9967C OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN 9968C THE IDENTITY MATRIX. 9969C 9970C ON OUTPUT 9971C 9972C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN 9973C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT 9974C UNORDERED FOR INDICES 1,2,...,IERR-1. 9975C 9976C E HAS BEEN DESTROYED. 9977C 9978C Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC 9979C TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE, 9980C Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED 9981C EIGENVALUES. 9982C 9983C IERR IS SET TO 9984C ZERO FOR NORMAL RETURN, 9985C J IF THE J-TH EIGENVALUE HAS NOT BEEN 9986C DETERMINED AFTER 30 ITERATIONS. 9987C 9988C CALLS PYTHAG FOR DSQRT(A*A + B*B) . 9989C 9990C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 9991C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 9992C 9993C THIS VERSION DATED AUGUST 1983. 9994C 9995C ------------------------------------------------------------------ 9996C 9997 IERR = 0 9998 IF (N .EQ. 1) GO TO 1001 9999C 10000 DO 100 I = 2, N 10001 100 E(I-1) = E(I) 10002C 10003 F = 0.0D0 10004 TST1 = 0.0D0 10005 E(N) = 0.0D0 10006C 10007 DO 240 L = 1, N 10008 J = 0 10009 H = DABS(D(L)) + DABS(E(L)) 10010 IF (TST1 .LT. H) TST1 = H 10011C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... 10012 DO 110 M = L, N 10013 TST2 = TST1 + DABS(E(M)) 10014 IF (TST2 .EQ. TST1) GO TO 120 10015C .......... E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT 10016C THROUGH THE BOTTOM OF THE LOOP .......... 10017 110 CONTINUE 10018C 10019 120 IF (M .EQ. L) GO TO 220 10020 130 IF (J .EQ. 30) GO TO 1000 10021 J = J + 1 10022C .......... FORM SHIFT .......... 10023 L1 = L + 1 10024 L2 = L1 + 1 10025 G = D(L) 10026 P = (D(L1) - G) / (2.0D0 * E(L)) 10027 R = PYTHAG(P,1.0D0) 10028 D(L) = E(L) / (P + DSIGN(R,P)) 10029 D(L1) = E(L) * (P + DSIGN(R,P)) 10030 DL1 = D(L1) 10031 H = G - D(L) 10032 IF (L2 .GT. N) GO TO 145 10033C 10034 DO 140 I = L2, N 10035 140 D(I) = D(I) - H 10036C 10037 145 F = F + H 10038C .......... QL TRANSFORMATION .......... 10039 P = D(M) 10040 C = 1.0D0 10041 C2 = C 10042 EL1 = E(L1) 10043 S = 0.0D0 10044 MML = M - L 10045C .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... 10046 DO 200 II = 1, MML 10047 C3 = C2 10048 C2 = C 10049 S2 = S 10050 I = M - II 10051 G = C * E(I) 10052 H = C * P 10053 R = PYTHAG(P,E(I)) 10054 E(I+1) = S * R 10055 S = E(I) / R 10056 C = P / R 10057 P = C * D(I) - S * G 10058 D(I+1) = H + S * (C * G + S * D(I)) 10059C .......... FORM VECTOR .......... 10060 DO 180 K = 1, N 10061 H = Z(K,I+1) 10062 Z(K,I+1) = S * Z(K,I) + C * H 10063 Z(K,I) = C * Z(K,I) - S * H 10064 180 CONTINUE 10065C 10066 200 CONTINUE 10067C 10068 P = -S * S2 * C3 * EL1 * E(L) / DL1 10069 E(L) = S * P 10070 D(L) = C * P 10071 TST2 = TST1 + DABS(E(L)) 10072 IF (TST2 .GT. TST1) GO TO 130 10073 220 D(L) = D(L) + F 10074 240 CONTINUE 10075C .......... ORDER EIGENVALUES AND EIGENVECTORS .......... 10076 DO 300 II = 2, N 10077 I = II - 1 10078 K = I 10079 P = D(I) 10080C 10081 DO 260 J = II, N 10082 IF (D(J) .GE. P) GO TO 260 10083 K = J 10084 P = D(J) 10085 260 CONTINUE 10086C 10087 IF (K .EQ. I) GO TO 300 10088 D(K) = D(I) 10089 D(I) = P 10090C 10091 DO 280 J = 1, N 10092 P = Z(J,I) 10093 Z(J,I) = Z(J,K) 10094 Z(J,K) = P 10095 280 CONTINUE 10096C 10097 300 CONTINUE 10098C 10099 GO TO 1001 10100C .......... SET ERROR -- NO CONVERGENCE TO AN 10101C EIGENVALUE AFTER 30 ITERATIONS .......... 10102 1000 IERR = L 10103 1001 RETURN 10104 END 10105 SUBROUTINE TQLRATL(N,D,E2,IERR) 10106C 10107 INTEGER I,J,L,M,N,II,L1,MML,IERR 10108 DOUBLE PRECISION D(N),E2(N) 10109 DOUBLE PRECISION B,C,F,G,H,P,R,S,T,EPSLON,PYTHAG 10110C 10111C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQLRAT, 10112C ALGORITHM 464, COMM. ACM 16, 689(1973) BY REINSCH. 10113C 10114C THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC 10115C TRIDIAGONAL MATRIX BY THE RATIONAL QL METHOD. 10116C 10117C ON INPUT 10118C 10119C N IS THE ORDER OF THE MATRIX. 10120C 10121C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. 10122C 10123C E2 CONTAINS THE SQUARES OF THE SUBDIAGONAL ELEMENTS OF THE 10124C INPUT MATRIX IN ITS LAST N-1 POSITIONS. E2(1) IS ARBITRARY. 10125C 10126C ON OUTPUT 10127C 10128C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN 10129C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND 10130C ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE 10131C THE SMALLEST EIGENVALUES. 10132C 10133C E2 HAS BEEN DESTROYED. 10134C 10135C IERR IS SET TO 10136C ZERO FOR NORMAL RETURN, 10137C J IF THE J-TH EIGENVALUE HAS NOT BEEN 10138C DETERMINED AFTER 30 ITERATIONS. 10139C 10140C CALLS PYTHAG FOR DSQRT(A*A + B*B) . 10141C 10142C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 10143C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 10144C 10145C THIS VERSION DATED AUGUST 1983. 10146C 10147C ------------------------------------------------------------------ 10148C 10149 IERR = 0 10150 IF (N .EQ. 1) GO TO 1001 10151C 10152 DO 100 I = 2, N 10153 100 E2(I-1) = E2(I) 10154C 10155 F = 0.0D0 10156 T = 0.0D0 10157 E2(N) = 0.0D0 10158C 10159 DO 290 L = 1, N 10160 J = 0 10161 H = DABS(D(L)) + DSQRT(E2(L)) 10162 IF (T .GT. H) GO TO 105 10163 T = H 10164 B = EPSLON(T) 10165 C = B * B 10166C .......... LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT .......... 10167 105 DO 110 M = L, N 10168 IF (E2(M) .LE. C) GO TO 120 10169C .......... E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT 10170C THROUGH THE BOTTOM OF THE LOOP .......... 10171 110 CONTINUE 10172C 10173 120 IF (M .EQ. L) GO TO 210 10174 130 IF (J .EQ. 30) GO TO 1000 10175 J = J + 1 10176C .......... FORM SHIFT .......... 10177 L1 = L + 1 10178 S = DSQRT(E2(L)) 10179 G = D(L) 10180 P = (D(L1) - G) / (2.0D0 * S) 10181 R = PYTHAG(P,1.0D0) 10182 D(L) = S / (P + DSIGN(R,P)) 10183 H = G - D(L) 10184C 10185 DO 140 I = L1, N 10186 140 D(I) = D(I) - H 10187C 10188 F = F + H 10189C .......... RATIONAL QL TRANSFORMATION .......... 10190 G = D(M) 10191 IF (G .EQ. 0.0D0) G = B 10192 H = G 10193 S = 0.0D0 10194 MML = M - L 10195C .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... 10196 DO 200 II = 1, MML 10197 I = M - II 10198 P = G * H 10199 R = P + E2(I) 10200 E2(I+1) = S * R 10201 S = E2(I) / R 10202 D(I+1) = H + S * (H + D(I)) 10203 G = D(I) - E2(I) / G 10204 IF (G .EQ. 0.0D0) G = B 10205 H = G * P / R 10206 200 CONTINUE 10207C 10208 E2(L) = S * G 10209 D(L) = H 10210C .......... GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST .......... 10211 IF (H .EQ. 0.0D0) GO TO 210 10212 IF (DABS(E2(L)) .LE. DABS(C/H)) GO TO 210 10213 E2(L) = H * E2(L) 10214 IF (E2(L) .NE. 0.0D0) GO TO 130 10215 210 P = D(L) + F 10216C .......... ORDER EIGENVALUES .......... 10217 IF (L .EQ. 1) GO TO 250 10218C .......... FOR I=L STEP -1 UNTIL 2 DO -- .......... 10219 DO 230 II = 2, L 10220 I = L + 2 - II 10221 IF (P .GE. D(I-1)) GO TO 270 10222 D(I) = D(I-1) 10223 230 CONTINUE 10224C 10225 250 I = 1 10226 270 D(I) = P 10227 290 CONTINUE 10228C 10229 GO TO 1001 10230C .......... SET ERROR -- NO CONVERGENCE TO AN 10231C EIGENVALUE AFTER 30 ITERATIONS .......... 10232 1000 IERR = L 10233 1001 RETURN 10234 END 10235 SUBROUTINE TRBAK1(NM,N,A,E,M,Z) 10236C 10237 INTEGER I,J,K,L,M,N,NM 10238 DOUBLE PRECISION A(NM,N),E(N),Z(NM,M) 10239 DOUBLE PRECISION S 10240C 10241C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK1, 10242C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. 10243C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). 10244C 10245C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC 10246C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING 10247C SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY TRED1. 10248C 10249C ON INPUT 10250C 10251C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 10252C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 10253C DIMENSION STATEMENT. 10254C 10255C N IS THE ORDER OF THE MATRIX. 10256C 10257C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- 10258C FORMATIONS USED IN THE REDUCTION BY TRED1 10259C IN ITS STRICT LOWER TRIANGLE. 10260C 10261C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL 10262C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. 10263C 10264C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. 10265C 10266C Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED 10267C IN ITS FIRST M COLUMNS. 10268C 10269C ON OUTPUT 10270C 10271C Z CONTAINS THE TRANSFORMED EIGENVECTORS 10272C IN ITS FIRST M COLUMNS. 10273C 10274C NOTE THAT TRBAK1 PRESERVES VECTOR EUCLIDEAN NORMS. 10275C 10276C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 10277C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 10278C 10279C THIS VERSION DATED AUGUST 1983. 10280C 10281C ------------------------------------------------------------------ 10282C 10283 IF (M .EQ. 0) GO TO 200 10284 IF (N .EQ. 1) GO TO 200 10285C 10286 DO 140 I = 2, N 10287 L = I - 1 10288 IF (E(I) .EQ. 0.0D0) GO TO 140 10289C 10290 DO 130 J = 1, M 10291 S = 0.0D0 10292C 10293 DO 110 K = 1, L 10294 110 S = S + A(I,K) * Z(K,J) 10295C .......... DIVISOR BELOW IS NEGATIVE OF H FORMED IN TRED1. 10296C DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW .......... 10297 S = (S / A(I,L)) / E(I) 10298C 10299 DO 120 K = 1, L 10300 120 Z(K,J) = Z(K,J) + S * A(I,K) 10301C 10302 130 CONTINUE 10303C 10304 140 CONTINUE 10305C 10306 200 RETURN 10307 END 10308 SUBROUTINE TRBAK3(NM,N,NV,A,M,Z) 10309C 10310 INTEGER I,J,K,L,M,N,IK,IZ,NM,NV 10311 DOUBLE PRECISION A(NV),Z(NM,M) 10312 DOUBLE PRECISION H,S 10313C 10314C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK3, 10315C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. 10316C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). 10317C 10318C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC 10319C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING 10320C SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY TRED3L. 10321C 10322C ON INPUT 10323C 10324C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 10325C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 10326C DIMENSION STATEMENT. 10327C 10328C N IS THE ORDER OF THE MATRIX. 10329C 10330C NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A 10331C AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT. 10332C 10333C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANSFORMATIONS 10334C USED IN THE REDUCTION BY TRED3L IN ITS FIRST 10335C N*(N+1)/2 POSITIONS. 10336C 10337C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. 10338C 10339C Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED 10340C IN ITS FIRST M COLUMNS. 10341C 10342C ON OUTPUT 10343C 10344C Z CONTAINS THE TRANSFORMED EIGENVECTORS 10345C IN ITS FIRST M COLUMNS. 10346C 10347C NOTE THAT TRBAK3 PRESERVES VECTOR EUCLIDEAN NORMS. 10348C 10349C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 10350C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 10351C 10352C THIS VERSION DATED AUGUST 1983. 10353C 10354C ------------------------------------------------------------------ 10355C 10356 IF (M .EQ. 0) GO TO 200 10357 IF (N .EQ. 1) GO TO 200 10358C 10359 DO 140 I = 2, N 10360 L = I - 1 10361 IZ = (I * L) / 2 10362 IK = IZ + I 10363 H = A(IK) 10364 IF (H .EQ. 0.0D0) GO TO 140 10365C 10366 DO 130 J = 1, M 10367 S = 0.0D0 10368 IK = IZ 10369C 10370 DO 110 K = 1, L 10371 IK = IK + 1 10372 S = S + A(IK) * Z(K,J) 10373 110 CONTINUE 10374C .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW .......... 10375 S = (S / H) / H 10376 IK = IZ 10377C 10378 DO 120 K = 1, L 10379 IK = IK + 1 10380 Z(K,J) = Z(K,J) - S * A(IK) 10381 120 CONTINUE 10382C 10383 130 CONTINUE 10384C 10385 140 CONTINUE 10386C 10387 200 RETURN 10388 END 10389 SUBROUTINE TRED1L(NM,N,A,D,E,E2) 10390C 10391 INTEGER I,J,K,L,N,II,NM,JP1 10392 DOUBLE PRECISION A(NM,N),D(N),E(N),E2(N) 10393 DOUBLE PRECISION F,G,H,SCALE 10394C 10395C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED1, 10396C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. 10397C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). 10398C 10399C THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX 10400C TO A SYMMETRIC TRIDIAGONAL MATRIX USING 10401C ORTHOGONAL SIMILARITY TRANSFORMATIONS. 10402C 10403C ON INPUT 10404C 10405C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 10406C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 10407C DIMENSION STATEMENT. 10408C 10409C N IS THE ORDER OF THE MATRIX. 10410C 10411C A CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE 10412C LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED. 10413C 10414C ON OUTPUT 10415C 10416C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- 10417C FORMATIONS USED IN THE REDUCTION IN ITS STRICT LOWER 10418C TRIANGLE. THE FULL UPPER TRIANGLE OF A IS UNALTERED. 10419C 10420C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. 10421C 10422C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL 10423C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. 10424C 10425C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. 10426C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. 10427C 10428C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 10429C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 10430C 10431C THIS VERSION DATED AUGUST 1983. 10432C 10433C ------------------------------------------------------------------ 10434C 10435 DO 100 I = 1, N 10436 D(I) = A(N,I) 10437 A(N,I) = A(I,I) 10438 100 CONTINUE 10439C .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... 10440 DO 300 II = 1, N 10441 I = N + 1 - II 10442 L = I - 1 10443 H = 0.0D0 10444 SCALE = 0.0D0 10445 IF (L .LT. 1) GO TO 130 10446C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... 10447 DO 120 K = 1, L 10448 120 SCALE = SCALE + DABS(D(K)) 10449C 10450 IF (SCALE .NE. 0.0D0) GO TO 140 10451C 10452 DO 125 J = 1, L 10453 D(J) = A(L,J) 10454 A(L,J) = A(I,J) 10455 A(I,J) = 0.0D0 10456 125 CONTINUE 10457C 10458 130 E(I) = 0.0D0 10459 E2(I) = 0.0D0 10460 GO TO 300 10461C 10462 140 DO 150 K = 1, L 10463 D(K) = D(K) / SCALE 10464 H = H + D(K) * D(K) 10465 150 CONTINUE 10466C 10467 E2(I) = SCALE * SCALE * H 10468 F = D(L) 10469 G = -DSIGN(DSQRT(H),F) 10470 E(I) = SCALE * G 10471 H = H - F * G 10472 D(L) = F - G 10473 IF (L .EQ. 1) GO TO 285 10474C .......... FORM A*U .......... 10475 DO 170 J = 1, L 10476 170 E(J) = 0.0D0 10477C 10478 DO 240 J = 1, L 10479 F = D(J) 10480 G = E(J) + A(J,J) * F 10481 JP1 = J + 1 10482 IF (L .LT. JP1) GO TO 220 10483C 10484 DO 200 K = JP1, L 10485 G = G + A(K,J) * D(K) 10486 E(K) = E(K) + A(K,J) * F 10487 200 CONTINUE 10488C 10489 220 E(J) = G 10490 240 CONTINUE 10491C .......... FORM P .......... 10492 F = 0.0D0 10493C 10494 DO 245 J = 1, L 10495 E(J) = E(J) / H 10496 F = F + E(J) * D(J) 10497 245 CONTINUE 10498C 10499 H = F / (H + H) 10500C .......... FORM Q .......... 10501 DO 250 J = 1, L 10502 250 E(J) = E(J) - H * D(J) 10503C .......... FORM REDUCED A .......... 10504 DO 280 J = 1, L 10505 F = D(J) 10506 G = E(J) 10507C 10508 DO 260 K = J, L 10509 260 A(K,J) = A(K,J) - F * E(K) - G * D(K) 10510C 10511 280 CONTINUE 10512C 10513 285 DO 290 J = 1, L 10514 F = D(J) 10515 D(J) = A(L,J) 10516 A(L,J) = A(I,J) 10517 A(I,J) = F * SCALE 10518 290 CONTINUE 10519C 10520 300 CONTINUE 10521C 10522 RETURN 10523 END 10524 SUBROUTINE TRED2L(NM,N,A,D,E,Z) 10525C 10526 INTEGER I,J,K,L,N,II,NM,JP1 10527 DOUBLE PRECISION A(NM,N),D(N),E(N),Z(NM,N) 10528 DOUBLE PRECISION F,G,H,HH,SCALE 10529C 10530C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED2, 10531C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. 10532C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). 10533C 10534C THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX TO A 10535C SYMMETRIC TRIDIAGONAL MATRIX USING AND ACCUMULATING 10536C ORTHOGONAL SIMILARITY TRANSFORMATIONS. 10537C 10538C ON INPUT 10539C 10540C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 10541C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 10542C DIMENSION STATEMENT. 10543C 10544C N IS THE ORDER OF THE MATRIX. 10545C 10546C A CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE 10547C LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED. 10548C 10549C ON OUTPUT 10550C 10551C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. 10552C 10553C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL 10554C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. 10555C 10556C Z CONTAINS THE ORTHOGONAL TRANSFORMATION MATRIX 10557C PRODUCED IN THE REDUCTION. 10558C 10559C A AND Z MAY COINCIDE. IF DISTINCT, A IS UNALTERED. 10560C 10561C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 10562C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 10563C 10564C THIS VERSION DATED AUGUST 1983. 10565C 10566C ------------------------------------------------------------------ 10567C 10568 DO 100 I = 1, N 10569C 10570 DO 80 J = I, N 10571 80 Z(J,I) = A(J,I) 10572C 10573 D(I) = A(N,I) 10574 100 CONTINUE 10575C 10576 IF (N .EQ. 1) GO TO 510 10577C .......... FOR I=N STEP -1 UNTIL 2 DO -- .......... 10578 DO 300 II = 2, N 10579 I = N + 2 - II 10580 L = I - 1 10581 H = 0.0D0 10582 SCALE = 0.0D0 10583 IF (L .LT. 2) GO TO 130 10584C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... 10585 DO 120 K = 1, L 10586 120 SCALE = SCALE + DABS(D(K)) 10587C 10588 IF (SCALE .NE. 0.0D0) GO TO 140 10589 130 E(I) = D(L) 10590C 10591 DO 135 J = 1, L 10592 D(J) = Z(L,J) 10593 Z(I,J) = 0.0D0 10594 Z(J,I) = 0.0D0 10595 135 CONTINUE 10596C 10597 GO TO 290 10598C 10599 140 DO 150 K = 1, L 10600 D(K) = D(K) / SCALE 10601 H = H + D(K) * D(K) 10602 150 CONTINUE 10603C 10604 F = D(L) 10605 G = -DSIGN(DSQRT(H),F) 10606 E(I) = SCALE * G 10607 H = H - F * G 10608 D(L) = F - G 10609C .......... FORM A*U .......... 10610 DO 170 J = 1, L 10611 170 E(J) = 0.0D0 10612C 10613 DO 240 J = 1, L 10614 F = D(J) 10615 Z(J,I) = F 10616 G = E(J) + Z(J,J) * F 10617 JP1 = J + 1 10618 IF (L .LT. JP1) GO TO 220 10619C 10620 DO 200 K = JP1, L 10621 G = G + Z(K,J) * D(K) 10622 E(K) = E(K) + Z(K,J) * F 10623 200 CONTINUE 10624C 10625 220 E(J) = G 10626 240 CONTINUE 10627C .......... FORM P .......... 10628 F = 0.0D0 10629C 10630 DO 245 J = 1, L 10631 E(J) = E(J) / H 10632 F = F + E(J) * D(J) 10633 245 CONTINUE 10634C 10635 HH = F / (H + H) 10636C .......... FORM Q .......... 10637 DO 250 J = 1, L 10638 250 E(J) = E(J) - HH * D(J) 10639C .......... FORM REDUCED A .......... 10640 DO 280 J = 1, L 10641 F = D(J) 10642 G = E(J) 10643C 10644 DO 260 K = J, L 10645 260 Z(K,J) = Z(K,J) - F * E(K) - G * D(K) 10646C 10647 D(J) = Z(L,J) 10648 Z(I,J) = 0.0D0 10649 280 CONTINUE 10650C 10651 290 D(I) = H 10652 300 CONTINUE 10653C .......... ACCUMULATION OF TRANSFORMATION MATRICES .......... 10654 DO 500 I = 2, N 10655 L = I - 1 10656 Z(N,L) = Z(L,L) 10657 Z(L,L) = 1.0D0 10658 H = D(I) 10659 IF (H .EQ. 0.0D0) GO TO 380 10660C 10661 DO 330 K = 1, L 10662 330 D(K) = Z(K,I) / H 10663C 10664 DO 360 J = 1, L 10665 G = 0.0D0 10666C 10667 DO 340 K = 1, L 10668 340 G = G + Z(K,I) * Z(K,J) 10669C 10670 DO 360 K = 1, L 10671 Z(K,J) = Z(K,J) - G * D(K) 10672 360 CONTINUE 10673C 10674 380 DO 400 K = 1, L 10675 400 Z(K,I) = 0.0D0 10676C 10677 500 CONTINUE 10678C 10679 510 DO 520 I = 1, N 10680 D(I) = Z(N,I) 10681 Z(N,I) = 0.0D0 10682 520 CONTINUE 10683C 10684 Z(N,N) = 1.0D0 10685 E(1) = 0.0D0 10686 RETURN 10687 END 10688 SUBROUTINE TRED3L(N,NV,A,D,E,E2) 10689C 10690 INTEGER I,J,K,L,N,II,IZ,JK,NV,JM1 10691 DOUBLE PRECISION A(NV),D(N),E(N),E2(N) 10692 DOUBLE PRECISION F,G,H,HH,SCALE 10693C 10694C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED3L, 10695C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. 10696C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). 10697C 10698C THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX, STORED AS 10699C A ONE-DIMENSIONAL ARRAY, TO A SYMMETRIC TRIDIAGONAL MATRIX 10700C USING ORTHOGONAL SIMILARITY TRANSFORMATIONS. 10701C 10702C ON INPUT 10703C 10704C N IS THE ORDER OF THE MATRIX. 10705C 10706C NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A 10707C AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT. 10708C 10709C A CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC 10710C INPUT MATRIX, STORED ROW-WISE AS A ONE-DIMENSIONAL 10711C ARRAY, IN ITS FIRST N*(N+1)/2 POSITIONS. 10712C 10713C ON OUTPUT 10714C 10715C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL 10716C TRANSFORMATIONS USED IN THE REDUCTION. 10717C 10718C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. 10719C 10720C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL 10721C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. 10722C 10723C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. 10724C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. 10725C 10726C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 10727C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 10728C 10729C THIS VERSION DATED AUGUST 1983. 10730C 10731C ------------------------------------------------------------------ 10732C 10733C .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... 10734 DO 300 II = 1, N 10735 I = N + 1 - II 10736 L = I - 1 10737 IZ = (I * L) / 2 10738 H = 0.0D0 10739 SCALE = 0.0D0 10740 IF (L .LT. 1) GO TO 130 10741C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... 10742 DO 120 K = 1, L 10743 IZ = IZ + 1 10744 D(K) = A(IZ) 10745 SCALE = SCALE + DABS(D(K)) 10746 120 CONTINUE 10747C 10748 IF (SCALE .NE. 0.0D0) GO TO 140 10749 130 E(I) = 0.0D0 10750 E2(I) = 0.0D0 10751 GO TO 290 10752C 10753 140 DO 150 K = 1, L 10754 D(K) = D(K) / SCALE 10755 H = H + D(K) * D(K) 10756 150 CONTINUE 10757C 10758 E2(I) = SCALE * SCALE * H 10759 F = D(L) 10760 G = -DSIGN(DSQRT(H),F) 10761 E(I) = SCALE * G 10762 H = H - F * G 10763 D(L) = F - G 10764 A(IZ) = SCALE * D(L) 10765 IF (L .EQ. 1) GO TO 290 10766 JK = 1 10767C 10768 DO 240 J = 1, L 10769 F = D(J) 10770 G = 0.0D0 10771 JM1 = J - 1 10772 IF (JM1 .LT. 1) GO TO 220 10773C 10774 DO 200 K = 1, JM1 10775 G = G + A(JK) * D(K) 10776 E(K) = E(K) + A(JK) * F 10777 JK = JK + 1 10778 200 CONTINUE 10779C 10780 220 E(J) = G + A(JK) * F 10781 JK = JK + 1 10782 240 CONTINUE 10783C .......... FORM P .......... 10784 F = 0.0D0 10785C 10786 DO 245 J = 1, L 10787 E(J) = E(J) / H 10788 F = F + E(J) * D(J) 10789 245 CONTINUE 10790C 10791 HH = F / (H + H) 10792C .......... FORM Q .......... 10793 DO 250 J = 1, L 10794 250 E(J) = E(J) - HH * D(J) 10795C 10796 JK = 1 10797C .......... FORM REDUCED A .......... 10798 DO 280 J = 1, L 10799 F = D(J) 10800 G = E(J) 10801C 10802 DO 260 K = 1, J 10803 A(JK) = A(JK) - F * E(K) - G * D(K) 10804 JK = JK + 1 10805 260 CONTINUE 10806C 10807 280 CONTINUE 10808C 10809 290 D(I) = A(IZ+1) 10810 A(IZ+1) = SCALE * DSQRT(H) 10811 300 CONTINUE 10812C 10813 RETURN 10814 END 10815 SUBROUTINE TRIDIB(N,EPS1,D,E,E2,LB,UB,M11,M,W,IND,IERR,RV4,RV5) 10816C 10817 INTEGER I,J,K,L,M,N,P,Q,R,S,II,M1,M2,M11,M22,TAG,IERR,ISTURM 10818 DOUBLE PRECISION D(N),E(N),E2(N),W(M),RV4(N),RV5(N) 10819 DOUBLE PRECISION U,V,LB,T1,T2,UB,XU,X0,X1,EPS1,TST1,TST2,EPSLON 10820 INTEGER IND(M) 10821 integer*4 ii4 10822C 10823C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BISECT, 10824C NUM. MATH. 9, 386-393(1967) BY BARTH, MARTIN, AND WILKINSON. 10825C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 249-256(1971). 10826C 10827C THIS SUBROUTINE FINDS THOSE EIGENVALUES OF A TRIDIAGONAL 10828C SYMMETRIC MATRIX BETWEEN SPECIFIED BOUNDARY INDICES, 10829C USING BISECTION. 10830C 10831C ON INPUT 10832C 10833C N IS THE ORDER OF THE MATRIX. 10834C 10835C EPS1 IS AN ABSOLUTE ERROR TOLERANCE FOR THE COMPUTED 10836C EIGENVALUES. IF THE INPUT EPS1 IS NON-POSITIVE, 10837C IT IS RESET FOR EACH SUBMATRIX TO A DEFAULT VALUE, 10838C NAMELY, MINUS THE PRODUCT OF THE RELATIVE MACHINE 10839C PRECISION AND THE 1-NORM OF THE SUBMATRIX. 10840C 10841C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. 10842C 10843C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX 10844C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. 10845C 10846C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. 10847C E2(1) IS ARBITRARY. 10848C 10849C M11 SPECIFIES THE LOWER BOUNDARY INDEX FOR THE DESIRED 10850C EIGENVALUES. 10851C 10852C M SPECIFIES THE NUMBER OF EIGENVALUES DESIRED. THE UPPER 10853C BOUNDARY INDEX M22 IS THEN OBTAINED AS M22=M11+M-1. 10854C 10855C ON OUTPUT 10856C 10857C EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS 10858C (LAST) DEFAULT VALUE. 10859C 10860C D AND E ARE UNALTERED. 10861C 10862C ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED 10863C AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE 10864C MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES. 10865C E2(1) IS ALSO SET TO ZERO. 10866C 10867C LB AND UB DEFINE AN INTERVAL CONTAINING EXACTLY THE DESIRED 10868C EIGENVALUES. 10869C 10870C W CONTAINS, IN ITS FIRST M POSITIONS, THE EIGENVALUES 10871C BETWEEN INDICES M11 AND M22 IN ASCENDING ORDER. 10872C 10873C IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES 10874C ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W -- 10875C 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM 10876C THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC.. 10877C 10878C IERR IS SET TO 10879C ZERO FOR NORMAL RETURN, 10880C 3*N+1 IF MULTIPLE EIGENVALUES AT INDEX M11 MAKE 10881C UNIQUE SELECTION IMPOSSIBLE, 10882C 3*N+2 IF MULTIPLE EIGENVALUES AT INDEX M22 MAKE 10883C UNIQUE SELECTION IMPOSSIBLE. 10884C 10885C RV4 AND RV5 ARE TEMPORARY STORAGE ARRAYS. 10886C 10887C NOTE THAT SUBROUTINE TQL1, IMTQL1, OR TQLRAT IS GENERALLY FASTER 10888C THAN TRIDIB, IF MORE THAN N/4 EIGENVALUES ARE TO BE FOUND. 10889C 10890C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 10891C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 10892C 10893C THIS VERSION DATED AUGUST 1983. 10894C 10895C ------------------------------------------------------------------ 10896C 10897 IERR = 0 10898 TAG = 0 10899 XU = D(1) 10900 X0 = D(1) 10901 U = 0.0D0 10902C .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES AND DETERMINE AN 10903C INTERVAL CONTAINING ALL THE EIGENVALUES .......... 10904 DO 40 I = 1, N 10905 X1 = U 10906 U = 0.0D0 10907 IF (I .NE. N) U = DABS(E(I+1)) 10908 XU = DMIN1(D(I)-(X1+U),XU) 10909 X0 = DMAX1(D(I)+(X1+U),X0) 10910 IF (I .EQ. 1) GO TO 20 10911 TST1 = DABS(D(I)) + DABS(D(I-1)) 10912 TST2 = TST1 + DABS(E(I)) 10913 IF (TST2 .GT. TST1) GO TO 40 10914 20 E2(I) = 0.0D0 10915 40 CONTINUE 10916C 10917 X1 = N 10918 X1 = X1 * EPSLON(DMAX1(DABS(XU),DABS(X0))) 10919 XU = XU - X1 10920 T1 = XU 10921 X0 = X0 + X1 10922 T2 = X0 10923C .......... DETERMINE AN INTERVAL CONTAINING EXACTLY 10924C THE DESIRED EIGENVALUES .......... 10925 P = 1 10926 Q = N 10927 M1 = M11 - 1 10928 IF (M1 .EQ. 0) GO TO 75 10929 ISTURM = 1 10930 50 V = X1 10931 X1 = XU + (X0 - XU) * 0.5D0 10932 IF (X1 .EQ. V) GO TO 980 10933 GO TO 320 10934 60 ii4=S - M1 10935 IF (ii4) 65, 73, 70 10936 65 XU = X1 10937 GO TO 50 10938 70 X0 = X1 10939 GO TO 50 10940 73 XU = X1 10941 T1 = X1 10942 75 M22 = M1 + M 10943 IF (M22 .EQ. N) GO TO 90 10944 X0 = T2 10945 ISTURM = 2 10946 GO TO 50 10947 80 ii4=S - M22 10948 IF (ii4) 65, 85, 70 10949 85 T2 = X1 10950 90 Q = 0 10951 R = 0 10952C .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING 10953C INTERVAL BY THE GERSCHGORIN BOUNDS .......... 10954 100 IF (R .EQ. M) GO TO 1001 10955 TAG = TAG + 1 10956 P = Q + 1 10957 XU = D(P) 10958 X0 = D(P) 10959 U = 0.0D0 10960C 10961 DO 120 Q = P, N 10962 X1 = U 10963 U = 0.0D0 10964 V = 0.0D0 10965 IF (Q .EQ. N) GO TO 110 10966 U = DABS(E(Q+1)) 10967 V = E2(Q+1) 10968 110 XU = DMIN1(D(Q)-(X1+U),XU) 10969 X0 = DMAX1(D(Q)+(X1+U),X0) 10970 IF (V .EQ. 0.0D0) GO TO 140 10971 120 CONTINUE 10972C 10973 140 X1 = EPSLON(DMAX1(DABS(XU),DABS(X0))) 10974 IF (EPS1 .LE. 0.0D0) EPS1 = -X1 10975 IF (P .NE. Q) GO TO 180 10976C .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL .......... 10977 IF (T1 .GT. D(P) .OR. D(P) .GE. T2) GO TO 940 10978 M1 = P 10979 M2 = P 10980 RV5(P) = D(P) 10981 GO TO 900 10982 180 X1 = X1 * (Q - P + 1) 10983 LB = DMAX1(T1,XU-X1) 10984 UB = DMIN1(T2,X0+X1) 10985 X1 = LB 10986 ISTURM = 3 10987 GO TO 320 10988 200 M1 = S + 1 10989 X1 = UB 10990 ISTURM = 4 10991 GO TO 320 10992 220 M2 = S 10993 IF (M1 .GT. M2) GO TO 940 10994C .......... FIND ROOTS BY BISECTION .......... 10995 X0 = UB 10996 ISTURM = 5 10997C 10998 DO 240 I = M1, M2 10999 RV5(I) = UB 11000 RV4(I) = LB 11001 240 CONTINUE 11002C .......... LOOP FOR K-TH EIGENVALUE 11003C FOR K=M2 STEP -1 UNTIL M1 DO -- 11004C (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) .......... 11005 K = M2 11006 250 XU = LB 11007C .......... FOR I=K STEP -1 UNTIL M1 DO -- .......... 11008 DO 260 II = M1, K 11009 I = M1 + K - II 11010 IF (XU .GE. RV4(I)) GO TO 260 11011 XU = RV4(I) 11012 GO TO 280 11013 260 CONTINUE 11014C 11015 280 IF (X0 .GT. RV5(K)) X0 = RV5(K) 11016C .......... NEXT BISECTION STEP .......... 11017 300 X1 = (XU + X0) * 0.5D0 11018 IF ((X0 - XU) .LE. DABS(EPS1)) GO TO 420 11019 TST1 = 2.0D0 * (DABS(XU) + DABS(X0)) 11020 TST2 = TST1 + (X0 - XU) 11021 IF (TST2 .EQ. TST1) GO TO 420 11022C .......... IN-LINE PROCEDURE FOR STURM SEQUENCE .......... 11023 320 S = P - 1 11024 U = 1.0D0 11025C 11026 DO 340 I = P, Q 11027 IF (U .NE. 0.0D0) GO TO 325 11028 V = DABS(E(I)) / EPSLON(1.0D0) 11029 IF (E2(I) .EQ. 0.0D0) V = 0.0D0 11030 GO TO 330 11031 325 V = E2(I) / U 11032 330 U = D(I) - X1 - V 11033 IF (U .LT. 0.0D0) S = S + 1 11034 340 CONTINUE 11035C 11036 GO TO (60,80,200,220,360), ISTURM 11037C .......... REFINE INTERVALS .......... 11038 360 IF (S .GE. K) GO TO 400 11039 XU = X1 11040 IF (S .GE. M1) GO TO 380 11041 RV4(M1) = X1 11042 GO TO 300 11043 380 RV4(S+1) = X1 11044 IF (RV5(S) .GT. X1) RV5(S) = X1 11045 GO TO 300 11046 400 X0 = X1 11047 GO TO 300 11048C .......... K-TH EIGENVALUE FOUND .......... 11049 420 RV5(K) = X1 11050 K = K - 1 11051 IF (K .GE. M1) GO TO 250 11052C .......... ORDER EIGENVALUES TAGGED WITH THEIR 11053C SUBMATRIX ASSOCIATIONS .......... 11054 900 S = R 11055 R = R + M2 - M1 + 1 11056 J = 1 11057 K = M1 11058C 11059 DO 920 L = 1, R 11060 IF (J .GT. S) GO TO 910 11061 IF (K .GT. M2) GO TO 940 11062 IF (RV5(K) .GE. W(L)) GO TO 915 11063C 11064 DO 905 II = J, S 11065 I = L + S - II 11066 W(I+1) = W(I) 11067 IND(I+1) = IND(I) 11068 905 CONTINUE 11069C 11070 910 W(L) = RV5(K) 11071 IND(L) = TAG 11072 K = K + 1 11073 GO TO 920 11074 915 J = J + 1 11075 920 CONTINUE 11076C 11077 940 IF (Q .LT. N) GO TO 100 11078 GO TO 1001 11079C .......... SET ERROR -- INTERVAL CANNOT BE FOUND CONTAINING 11080C EXACTLY THE DESIRED EIGENVALUES .......... 11081 980 IERR = 3 * N + ISTURM 11082 1001 LB = T1 11083 UB = T2 11084 RETURN 11085 END 11086 SUBROUTINE TSTURM(NM,N,EPS1,D,E,E2,LB,UB,MM,M,W,Z, 11087 X IERR,RV1,RV2,RV3,RV4,RV5,RV6) 11088C 11089 INTEGER I,J,K,M,N,P,Q,R,S,II,IP,JJ,MM,M1,M2,NM,ITS, 11090 X IERR,GROUP,ISTURM 11091 DOUBLE PRECISION D(N),E(N),E2(N),W(MM),Z(NM,MM), 11092 X RV1(N),RV2(N),RV3(N),RV4(N),RV5(N),RV6(N) 11093 DOUBLE PRECISION U,V,LB,T1,T2,UB,UK,XU,X0,X1,EPS1,EPS2,EPS3,EPS4, 11094 X NORM,TST1,TST2,EPSLON,PYTHAG 11095C 11096C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRISTURM 11097C BY PETERS AND WILKINSON. 11098C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). 11099C 11100C THIS SUBROUTINE FINDS THOSE EIGENVALUES OF A TRIDIAGONAL 11101C SYMMETRIC MATRIX WHICH LIE IN A SPECIFIED INTERVAL AND THEIR 11102C ASSOCIATED EIGENVECTORS, USING BISECTION AND INVERSE ITERATION. 11103C 11104C ON INPUT 11105C 11106C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 11107C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 11108C DIMENSION STATEMENT. 11109C 11110C N IS THE ORDER OF THE MATRIX. 11111C 11112C EPS1 IS AN ABSOLUTE ERROR TOLERANCE FOR THE COMPUTED 11113C EIGENVALUES. IT SHOULD BE CHOSEN COMMENSURATE WITH 11114C RELATIVE PERTURBATIONS IN THE MATRIX ELEMENTS OF THE 11115C ORDER OF THE RELATIVE MACHINE PRECISION. IF THE 11116C INPUT EPS1 IS NON-POSITIVE, IT IS RESET FOR EACH 11117C SUBMATRIX TO A DEFAULT VALUE, NAMELY, MINUS THE 11118C PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE 11119C 1-NORM OF THE SUBMATRIX. 11120C 11121C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. 11122C 11123C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX 11124C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. 11125C 11126C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. 11127C E2(1) IS ARBITRARY. 11128C 11129C LB AND UB DEFINE THE INTERVAL TO BE SEARCHED FOR EIGENVALUES. 11130C IF LB IS NOT LESS THAN UB, NO EIGENVALUES WILL BE FOUND. 11131C 11132C MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF 11133C EIGENVALUES IN THE INTERVAL. WARNING. IF MORE THAN 11134C MM EIGENVALUES ARE DETERMINED TO LIE IN THE INTERVAL, 11135C AN ERROR RETURN IS MADE WITH NO VALUES OR VECTORS FOUND. 11136C 11137C ON OUTPUT 11138C 11139C EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS 11140C (LAST) DEFAULT VALUE. 11141C 11142C D AND E ARE UNALTERED. 11143C 11144C ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED 11145C AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE 11146C MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES. 11147C E2(1) IS ALSO SET TO ZERO. 11148C 11149C M IS THE NUMBER OF EIGENVALUES DETERMINED TO LIE IN (LB,UB). 11150C 11151C W CONTAINS THE M EIGENVALUES IN ASCENDING ORDER IF THE MATRIX 11152C DOES NOT SPLIT. IF THE MATRIX SPLITS, THE EIGENVALUES ARE 11153C IN ASCENDING ORDER FOR EACH SUBMATRIX. IF A VECTOR ERROR 11154C EXIT IS MADE, W CONTAINS THOSE VALUES ALREADY FOUND. 11155C 11156C Z CONTAINS THE ASSOCIATED SET OF ORTHONORMAL EIGENVECTORS. 11157C IF AN ERROR EXIT IS MADE, Z CONTAINS THOSE VECTORS 11158C ALREADY FOUND. 11159C 11160C IERR IS SET TO 11161C ZERO FOR NORMAL RETURN, 11162C 3*N+1 IF M EXCEEDS MM. 11163C 4*N+R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH 11164C EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS. 11165C 11166C RV1, RV2, RV3, RV4, RV5, AND RV6 ARE TEMPORARY STORAGE ARRAYS. 11167C 11168C THE ALGOL PROCEDURE STURMCNT CONTAINED IN TRISTURM 11169C APPEARS IN TSTURM IN-LINE. 11170C 11171C CALLS PYTHAG FOR DSQRT(A*A + B*B) . 11172C 11173C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, 11174C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY 11175C 11176C THIS VERSION DATED AUGUST 1983. 11177C 11178C ------------------------------------------------------------------ 11179C 11180 IERR = 0 11181 T1 = LB 11182 T2 = UB 11183C .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES .......... 11184 DO 40 I = 1, N 11185 IF (I .EQ. 1) GO TO 20 11186 TST1 = DABS(D(I)) + DABS(D(I-1)) 11187 TST2 = TST1 + DABS(E(I)) 11188 IF (TST2 .GT. TST1) GO TO 40 11189 20 E2(I) = 0.0D0 11190 40 CONTINUE 11191C .......... DETERMINE THE NUMBER OF EIGENVALUES 11192C IN THE INTERVAL .......... 11193 P = 1 11194 Q = N 11195 X1 = UB 11196 ISTURM = 1 11197 GO TO 320 11198 60 M = S 11199 X1 = LB 11200 ISTURM = 2 11201 GO TO 320 11202 80 M = M - S 11203 IF (M .GT. MM) GO TO 980 11204 Q = 0 11205 R = 0 11206C .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING 11207C INTERVAL BY THE GERSCHGORIN BOUNDS .......... 11208 100 IF (R .EQ. M) GO TO 1001 11209 P = Q + 1 11210 XU = D(P) 11211 X0 = D(P) 11212 U = 0.0D0 11213C 11214 DO 120 Q = P, N 11215 X1 = U 11216 U = 0.0D0 11217 V = 0.0D0 11218 IF (Q .EQ. N) GO TO 110 11219 U = DABS(E(Q+1)) 11220 V = E2(Q+1) 11221 110 XU = DMIN1(D(Q)-(X1+U),XU) 11222 X0 = DMAX1(D(Q)+(X1+U),X0) 11223 IF (V .EQ. 0.0D0) GO TO 140 11224 120 CONTINUE 11225C 11226 140 X1 = EPSLON(DMAX1(DABS(XU),DABS(X0))) 11227 IF (EPS1 .LE. 0.0D0) EPS1 = -X1 11228 IF (P .NE. Q) GO TO 180 11229C .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL .......... 11230 IF (T1 .GT. D(P) .OR. D(P) .GE. T2) GO TO 940 11231 R = R + 1 11232C 11233 DO 160 I = 1, N 11234 160 Z(I,R) = 0.0D0 11235C 11236 W(R) = D(P) 11237 Z(P,R) = 1.0D0 11238 GO TO 940 11239 180 U = Q-P+1 11240 X1 = U * X1 11241 LB = DMAX1(T1,XU-X1) 11242 UB = DMIN1(T2,X0+X1) 11243 X1 = LB 11244 ISTURM = 3 11245 GO TO 320 11246 200 M1 = S + 1 11247 X1 = UB 11248 ISTURM = 4 11249 GO TO 320 11250 220 M2 = S 11251 IF (M1 .GT. M2) GO TO 940 11252C .......... FIND ROOTS BY BISECTION .......... 11253 X0 = UB 11254 ISTURM = 5 11255C 11256 DO 240 I = M1, M2 11257 RV5(I) = UB 11258 RV4(I) = LB 11259 240 CONTINUE 11260C .......... LOOP FOR K-TH EIGENVALUE 11261C FOR K=M2 STEP -1 UNTIL M1 DO -- 11262C (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) .......... 11263 K = M2 11264 250 XU = LB 11265C .......... FOR I=K STEP -1 UNTIL M1 DO -- .......... 11266 DO 260 II = M1, K 11267 I = M1 + K - II 11268 IF (XU .GE. RV4(I)) GO TO 260 11269 XU = RV4(I) 11270 GO TO 280 11271 260 CONTINUE 11272C 11273 280 IF (X0 .GT. RV5(K)) X0 = RV5(K) 11274C .......... NEXT BISECTION STEP .......... 11275 300 X1 = (XU + X0) * 0.5D0 11276 IF ((X0 - XU) .LE. DABS(EPS1)) GO TO 420 11277 TST1 = 2.0D0 * (DABS(XU) + DABS(X0)) 11278 TST2 = TST1 + (X0 - XU) 11279 IF (TST2 .EQ. TST1) GO TO 420 11280C .......... IN-LINE PROCEDURE FOR STURM SEQUENCE .......... 11281 320 S = P - 1 11282 U = 1.0D0 11283C 11284 DO 340 I = P, Q 11285 IF (U .NE. 0.0D0) GO TO 325 11286 V = DABS(E(I)) / EPSLON(1.0D0) 11287 IF (E2(I) .EQ. 0.0D0) V = 0.0D0 11288 GO TO 330 11289 325 V = E2(I) / U 11290 330 U = D(I) - X1 - V 11291 IF (U .LT. 0.0D0) S = S + 1 11292 340 CONTINUE 11293C 11294 GO TO (60,80,200,220,360), ISTURM 11295C .......... REFINE INTERVALS .......... 11296 360 IF (S .GE. K) GO TO 400 11297 XU = X1 11298 IF (S .GE. M1) GO TO 380 11299 RV4(M1) = X1 11300 GO TO 300 11301 380 RV4(S+1) = X1 11302 IF (RV5(S) .GT. X1) RV5(S) = X1 11303 GO TO 300 11304 400 X0 = X1 11305 GO TO 300 11306C .......... K-TH EIGENVALUE FOUND .......... 11307 420 RV5(K) = X1 11308 K = K - 1 11309 IF (K .GE. M1) GO TO 250 11310C .......... FIND VECTORS BY INVERSE ITERATION .......... 11311 NORM = DABS(D(P)) 11312 IP = P + 1 11313C 11314 DO 500 I = IP, Q 11315 500 NORM = DMAX1(NORM, DABS(D(I)) + DABS(E(I))) 11316C .......... EPS2 IS THE CRITERION FOR GROUPING, 11317C EPS3 REPLACES ZERO PIVOTS AND EQUAL 11318C ROOTS ARE MODIFIED BY EPS3, 11319C EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW .......... 11320 EPS2 = 1.0D-3 * NORM 11321 EPS3 = EPSLON(NORM) 11322 UK = Q - P + 1 11323 EPS4 = UK * EPS3 11324 UK = EPS4 / DSQRT(UK) 11325 GROUP = 0 11326 S = P 11327C 11328 DO 920 K = M1, M2 11329 R = R + 1 11330 ITS = 1 11331 W(R) = RV5(K) 11332 X1 = RV5(K) 11333C .......... LOOK FOR CLOSE OR COINCIDENT ROOTS .......... 11334 IF (K .EQ. M1) GO TO 520 11335 IF (X1 - X0 .GE. EPS2) GROUP = -1 11336 GROUP = GROUP + 1 11337 IF (X1 .LE. X0) X1 = X0 + EPS3 11338C .......... ELIMINATION WITH INTERCHANGES AND 11339C INITIALIZATION OF VECTOR .......... 11340 520 V = 0.0D0 11341C 11342 DO 580 I = P, Q 11343 RV6(I) = UK 11344 IF (I .EQ. P) GO TO 560 11345 IF (DABS(E(I)) .LT. DABS(U)) GO TO 540 11346 XU = U / E(I) 11347 RV4(I) = XU 11348 RV1(I-1) = E(I) 11349 RV2(I-1) = D(I) - X1 11350 RV3(I-1) = 0.0D0 11351 IF (I .NE. Q) RV3(I-1) = E(I+1) 11352 U = V - XU * RV2(I-1) 11353 V = -XU * RV3(I-1) 11354 GO TO 580 11355 540 XU = E(I) / U 11356 RV4(I) = XU 11357 RV1(I-1) = U 11358 RV2(I-1) = V 11359 RV3(I-1) = 0.0D0 11360 560 U = D(I) - X1 - XU * V 11361 IF (I .NE. Q) V = E(I+1) 11362 580 CONTINUE 11363C 11364 IF (U .EQ. 0.0D0) U = EPS3 11365 RV1(Q) = U 11366 RV2(Q) = 0.0D0 11367 RV3(Q) = 0.0D0 11368C .......... BACK SUBSTITUTION 11369C FOR I=Q STEP -1 UNTIL P DO -- .......... 11370 600 DO 620 II = P, Q 11371 I = P + Q - II 11372 RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I) 11373 V = U 11374 U = RV6(I) 11375 620 CONTINUE 11376C .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS 11377C MEMBERS OF GROUP .......... 11378 IF (GROUP .EQ. 0) GO TO 700 11379C 11380 DO 680 JJ = 1, GROUP 11381 J = R - GROUP - 1 + JJ 11382 XU = 0.0D0 11383C 11384 DO 640 I = P, Q 11385 640 XU = XU + RV6(I) * Z(I,J) 11386C 11387 DO 660 I = P, Q 11388 660 RV6(I) = RV6(I) - XU * Z(I,J) 11389C 11390 680 CONTINUE 11391C 11392 700 NORM = 0.0D0 11393C 11394 DO 720 I = P, Q 11395 720 NORM = NORM + DABS(RV6(I)) 11396C 11397 IF (NORM .GE. 1.0D0) GO TO 840 11398C .......... FORWARD SUBSTITUTION .......... 11399 IF (ITS .EQ. 5) GO TO 960 11400 IF (NORM .NE. 0.0D0) GO TO 740 11401 RV6(S) = EPS4 11402 S = S + 1 11403 IF (S .GT. Q) S = P 11404 GO TO 780 11405 740 XU = EPS4 / NORM 11406C 11407 DO 760 I = P, Q 11408 760 RV6(I) = RV6(I) * XU 11409C .......... ELIMINATION OPERATIONS ON NEXT VECTOR 11410C ITERATE .......... 11411 780 DO 820 I = IP, Q 11412 U = RV6(I) 11413C .......... IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE 11414C WAS PERFORMED EARLIER IN THE 11415C TRIANGULARIZATION PROCESS .......... 11416 IF (RV1(I-1) .NE. E(I)) GO TO 800 11417 U = RV6(I-1) 11418 RV6(I-1) = RV6(I) 11419 800 RV6(I) = U - RV4(I) * RV6(I-1) 11420 820 CONTINUE 11421C 11422 ITS = ITS + 1 11423 GO TO 600 11424C .......... NORMALIZE SO THAT SUM OF SQUARES IS 11425C 1 AND EXPAND TO FULL ORDER .......... 11426 840 U = 0.0D0 11427C 11428 DO 860 I = P, Q 11429 860 U = PYTHAG(U,RV6(I)) 11430C 11431 XU = 1.0D0 / U 11432C 11433 DO 880 I = 1, N 11434 880 Z(I,R) = 0.0D0 11435C 11436 DO 900 I = P, Q 11437 900 Z(I,R) = RV6(I) * XU 11438C 11439 X0 = X1 11440 920 CONTINUE 11441C 11442 940 IF (Q .LT. N) GO TO 100 11443 GO TO 1001 11444C .......... SET ERROR -- NON-CONVERGED EIGENVECTOR .......... 11445 960 IERR = 4 * N + R 11446 GO TO 1001 11447C .......... SET ERROR -- UNDERESTIMATE OF NUMBER OF 11448C EIGENVALUES IN INTERVAL .......... 11449 980 IERR = 3 * N + 1 11450 1001 LB = T1 11451 UB = T2 11452 RETURN 11453 END 11454c $Id$ 11455