Context Navigation

eispack.f

Visit:

Last change on this file was 2, checked in by oldcode, 25 years ago
Initial revision
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 348.0 KB

Line
1	SUBROUTINE CDIV(AR,AI,BR,BI,CR,CI)
2	DOUBLE PRECISION AR,AI,BR,BI,CR,CI
3	C
4	C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
5	C
6	DOUBLE PRECISION S,ARS,AIS,BRS,BIS
7	S = DABS(BR) + DABS(BI)
8	ARS = AR/S
9	AIS = AI/S
10	BRS = BR/S
11	BIS = BI/S
12	S = BRS2 + BIS2
13	CR = (ARSBRS + AISBIS)/S
14	CI = (AISBRS - ARSBIS)/S
15	RETURN
16	END
17	SUBROUTINE CSROOT(XR,XI,YR,YI)
18	DOUBLE PRECISION XR,XI,YR,YI
19	C
20	C (YR,YI) = COMPLEX DSQRT(XR,XI)
21	C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
22	C
23	DOUBLE PRECISION S,TR,TI,PYTHAG
24	TR = XR
25	TI = XI
26	S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
27	IF (TR .GE. 0.0D0) YR = S
28	IF (TI .LT. 0.0D0) S = -S
29	IF (TR .LE. 0.0D0) YI = S
30	IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
31	IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
32	RETURN
33	END
34	DOUBLE PRECISION FUNCTION EPSLON (X)
35	DOUBLE PRECISION X
36	C
37	C ESTIMATE UNIT ROUNDOFF IN QUANTITIES OF SIZE X.
38	C
39	DOUBLE PRECISION A,B,C,EPS
40	C
41	C THIS PROGRAM SHOULD FUNCTION PROPERLY ON ALL SYSTEMS
42	C SATISFYING THE FOLLOWING TWO ASSUMPTIONS,
43	C 1. THE BASE USED IN REPRESENTING FLOATING POINT
44	C NUMBERS IS NOT A POWER OF THREE.
45	C 2. THE QUANTITY A IN STATEMENT 10 IS REPRESENTED TO
46	C THE ACCURACY USED IN FLOATING POINT VARIABLES
47	C THAT ARE STORED IN MEMORY.
48	C THE STATEMENT NUMBER 10 AND THE GO TO 10 ARE INTENDED TO
49	C FORCE OPTIMIZING COMPILERS TO GENERATE CODE SATISFYING
50	C ASSUMPTION 2.
51	C UNDER THESE ASSUMPTIONS, IT SHOULD BE TRUE THAT,
52	C A IS NOT EXACTLY EQUAL TO FOUR-THIRDS,
53	C B HAS A ZERO FOR ITS LAST BIT OR DIGIT,
54	C C IS NOT EXACTLY EQUAL TO ONE,
55	C EPS MEASURES THE SEPARATION OF 1.0 FROM
56	C THE NEXT LARGER FLOATING POINT NUMBER.
57	C THE DEVELOPERS OF EISPACK WOULD APPRECIATE BEING INFORMED
58	C ABOUT ANY SYSTEMS WHERE THESE ASSUMPTIONS DO NOT HOLD.
59	C
60	C THIS VERSION DATED 4/6/83.
61	C
62	A = 4.0D0/3.0D0
63	10 B = A - 1.0D0
64	C = B + B + B
65	EPS = DABS(C-1.0D0)
66	IF (EPS .EQ. 0.0D0) GO TO 10
67	EPSLON = EPS*DABS(X)
68	RETURN
69	END
70	DOUBLE PRECISION FUNCTION PYTHAG(A,B)
71	DOUBLE PRECISION A,B
72	C
73	C FINDS DSQRT(A2+B2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
74	C
75	DOUBLE PRECISION P,R,S,T,U
76	P = DMAX1(DABS(A),DABS(B))
77	IF (P .EQ. 0.0D0) GO TO 20
78	R = (DMIN1(DABS(A),DABS(B))/P)**2
79	10 CONTINUE
80	T = 4.0D0 + R
81	IF (T .EQ. 4.0D0) GO TO 20
82	S = R/T
83	U = 1.0D0 + 2.0D0*S
84	P = U*P
85	R = (S/U)*2 R
86	GO TO 10
87	20 PYTHAG = P
88	RETURN
89	END
90	SUBROUTINE BAKVEC(NM,N,T,E,M,Z,IERR)
91	C
92	INTEGER I,J,M,N,NM,IERR
93	DOUBLE PRECISION T(NM,3),E(N),Z(NM,M)
94	C
95	C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A NONSYMMETRIC
96	C TRIDIAGONAL MATRIX BY BACK TRANSFORMING THOSE OF THE
97	C CORRESPONDING SYMMETRIC MATRIX DETERMINED BY FIGI.
98	C
99	C ON INPUT
100	C
101	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
102	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
103	C DIMENSION STATEMENT.
104	C
105	C N IS THE ORDER OF THE MATRIX.
106	C
107	C T CONTAINS THE NONSYMMETRIC MATRIX. ITS SUBDIAGONAL IS
108	C STORED IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN,
109	C ITS DIAGONAL IN THE N POSITIONS OF THE SECOND COLUMN,
110	C AND ITS SUPERDIAGONAL IN THE FIRST N-1 POSITIONS OF
111	C THE THIRD COLUMN. T(1,1) AND T(N,3) ARE ARBITRARY.
112	C
113	C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE SYMMETRIC
114	C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY.
115	C
116	C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
117	C
118	C Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED
119	C IN ITS FIRST M COLUMNS.
120	C
121	C ON OUTPUT
122	C
123	C T IS UNALTERED.
124	C
125	C E IS DESTROYED.
126	C
127	C Z CONTAINS THE TRANSFORMED EIGENVECTORS
128	C IN ITS FIRST M COLUMNS.
129	C
130	C IERR IS SET TO
131	C ZERO FOR NORMAL RETURN,
132	C 2*N+I IF E(I) IS ZERO WITH T(I,1) OR T(I-1,3) NON-ZERO.
133	C IN THIS CASE, THE SYMMETRIC MATRIX IS NOT SIMILAR
134	C TO THE ORIGINAL MATRIX, AND THE EIGENVECTORS
135	C CANNOT BE FOUND BY THIS PROGRAM.
136	C
137	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
138	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
139	C
140	C THIS VERSION DATED AUGUST 1983.
141	C
142	C ------------------------------------------------------------------
143	C
144	IERR = 0
145	IF (M .EQ. 0) GO TO 1001
146	E(1) = 1.0D0
147	IF (N .EQ. 1) GO TO 1001
148	C
149	DO 100 I = 2, N
150	IF (E(I) .NE. 0.0D0) GO TO 80
151	IF (T(I,1) .NE. 0.0D0 .OR. T(I-1,3) .NE. 0.0D0) GO TO 1000
152	E(I) = 1.0D0
153	GO TO 100
154	80 E(I) = E(I-1) * E(I) / T(I-1,3)
155	100 CONTINUE
156	C
157	DO 120 J = 1, M
158	C
159	DO 120 I = 2, N
160	Z(I,J) = Z(I,J) * E(I)
161	120 CONTINUE
162	C
163	GO TO 1001
164	C .......... SET ERROR -- EIGENVECTORS CANNOT BE
165	C FOUND BY THIS PROGRAM ..........
166	1000 IERR = 2 * N + I
167	1001 RETURN
168	END
169	SUBROUTINE BALANC(NM,N,A,LOW,IGH,SCALE)
170	C
171	INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
172	DOUBLE PRECISION A(NM,N),SCALE(N)
173	DOUBLE PRECISION C,F,G,R,S,B2,RADIX
174	LOGICAL NOCONV
175	C
176	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALANCE,
177	C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
178	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
179	C
180	C THIS SUBROUTINE BALANCES A REAL MATRIX AND ISOLATES
181	C EIGENVALUES WHENEVER POSSIBLE.
182	C
183	C ON INPUT
184	C
185	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
186	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
187	C DIMENSION STATEMENT.
188	C
189	C N IS THE ORDER OF THE MATRIX.
190	C
191	C A CONTAINS THE INPUT MATRIX TO BE BALANCED.
192	C
193	C ON OUTPUT
194	C
195	C A CONTAINS THE BALANCED MATRIX.
196	C
197	C LOW AND IGH ARE TWO INTEGERS SUCH THAT A(I,J)
198	C IS EQUAL TO ZERO IF
199	C (1) I IS GREATER THAN J AND
200	C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
201	C
202	C SCALE CONTAINS INFORMATION DETERMINING THE
203	C PERMUTATIONS AND SCALING FACTORS USED.
204	C
205	C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
206	C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
207	C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
208	C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
209	C SCALE(J) = P(J), FOR J = 1,...,LOW-1
210	C = D(J,J), J = LOW,...,IGH
211	C = P(J) J = IGH+1,...,N.
212	C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
213	C THEN 1 TO LOW-1.
214	C
215	C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
216	C
217	C THE ALGOL PROCEDURE EXC CONTAINED IN BALANCE APPEARS IN
218	C BALANC IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
219	C K,L HAVE BEEN REVERSED.)
220	C
221	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
222	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
223	C
224	C THIS VERSION DATED AUGUST 1983.
225	C
226	C ------------------------------------------------------------------
227	C
228	RADIX = 16.0D0
229	C
230	B2 = RADIX * RADIX
231	K = 1
232	L = N
233	GO TO 100
234	C .......... IN-LINE PROCEDURE FOR ROW AND
235	C COLUMN EXCHANGE ..........
236	20 SCALE(M) = J
237	IF (J .EQ. M) GO TO 50
238	C
239	DO 30 I = 1, L
240	F = A(I,J)
241	A(I,J) = A(I,M)
242	A(I,M) = F
243	30 CONTINUE
244	C
245	DO 40 I = K, N
246	F = A(J,I)
247	A(J,I) = A(M,I)
248	A(M,I) = F
249	40 CONTINUE
250	C
251	50 GO TO (80,130), IEXC
252	C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
253	C AND PUSH THEM DOWN ..........
254	80 IF (L .EQ. 1) GO TO 280
255	L = L - 1
256	C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
257	100 DO 120 JJ = 1, L
258	J = L + 1 - JJ
259	C
260	DO 110 I = 1, L
261	IF (I .EQ. J) GO TO 110
262	IF (A(J,I) .NE. 0.0D0) GO TO 120
263	110 CONTINUE
264	C
265	M = L
266	IEXC = 1
267	GO TO 20
268	120 CONTINUE
269	C
270	GO TO 140
271	C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
272	C AND PUSH THEM LEFT ..........
273	130 K = K + 1
274	C
275	140 DO 170 J = K, L
276	C
277	DO 150 I = K, L
278	IF (I .EQ. J) GO TO 150
279	IF (A(I,J) .NE. 0.0D0) GO TO 170
280	150 CONTINUE
281	C
282	M = K
283	IEXC = 2
284	GO TO 20
285	170 CONTINUE
286	C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
287	DO 180 I = K, L
288	180 SCALE(I) = 1.0D0
289	C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
290	190 NOCONV = .FALSE.
291	C
292	DO 270 I = K, L
293	C = 0.0D0
294	R = 0.0D0
295	C
296	DO 200 J = K, L
297	IF (J .EQ. I) GO TO 200
298	C = C + DABS(A(J,I))
299	R = R + DABS(A(I,J))
300	200 CONTINUE
301	C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
302	IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GO TO 270
303	G = R / RADIX
304	F = 1.0D0
305	S = C + R
306	210 IF (C .GE. G) GO TO 220
307	F = F * RADIX
308	C = C * B2
309	GO TO 210
310	220 G = R * RADIX
311	230 IF (C .LT. G) GO TO 240
312	F = F / RADIX
313	C = C / B2
314	GO TO 230
315	C .......... NOW BALANCE ..........
316	240 IF ((C + R) / F .GE. 0.95D0 * S) GO TO 270
317	G = 1.0D0 / F
318	SCALE(I) = SCALE(I) * F
319	NOCONV = .TRUE.
320	C
321	DO 250 J = K, N
322	250 A(I,J) = A(I,J) * G
323	C
324	DO 260 J = 1, L
325	260 A(J,I) = A(J,I) * F
326	C
327	270 CONTINUE
328	C
329	IF (NOCONV) GO TO 190
330	C
331	280 LOW = K
332	IGH = L
333	RETURN
334	END
335	SUBROUTINE BALBAK(NM,N,LOW,IGH,SCALE,M,Z)
336	C
337	INTEGER I,J,K,M,N,II,NM,IGH,LOW
338	DOUBLE PRECISION SCALE(N),Z(NM,M)
339	DOUBLE PRECISION S
340	C
341	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALBAK,
342	C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
343	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
344	C
345	C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL GENERAL
346	C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
347	C BALANCED MATRIX DETERMINED BY BALANC.
348	C
349	C ON INPUT
350	C
351	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
352	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
353	C DIMENSION STATEMENT.
354	C
355	C N IS THE ORDER OF THE MATRIX.
356	C
357	C LOW AND IGH ARE INTEGERS DETERMINED BY BALANC.
358	C
359	C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
360	C AND SCALING FACTORS USED BY BALANC.
361	C
362	C M IS THE NUMBER OF COLUMNS OF Z TO BE BACK TRANSFORMED.
363	C
364	C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGEN-
365	C VECTORS TO BE BACK TRANSFORMED IN ITS FIRST M COLUMNS.
366	C
367	C ON OUTPUT
368	C
369	C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE
370	C TRANSFORMED EIGENVECTORS IN ITS FIRST M COLUMNS.
371	C
372	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
373	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
374	C
375	C THIS VERSION DATED AUGUST 1983.
376	C
377	C ------------------------------------------------------------------
378	C
379	IF (M .EQ. 0) GO TO 200
380	IF (IGH .EQ. LOW) GO TO 120
381	C
382	DO 110 I = LOW, IGH
383	S = SCALE(I)
384	C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
385	C IF THE FOREGOING STATEMENT IS REPLACED BY
386	C S=1.0D0/SCALE(I). ..........
387	DO 100 J = 1, M
388	100 Z(I,J) = Z(I,J) * S
389	C
390	110 CONTINUE
391	C ......... FOR I=LOW-1 STEP -1 UNTIL 1,
392	C IGH+1 STEP 1 UNTIL N DO -- ..........
393	120 DO 140 II = 1, N
394	I = II
395	IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140
396	IF (I .LT. LOW) I = LOW - II
397	K = SCALE(I)
398	IF (K .EQ. I) GO TO 140
399	C
400	DO 130 J = 1, M
401	S = Z(I,J)
402	Z(I,J) = Z(K,J)
403	Z(K,J) = S
404	130 CONTINUE
405	C
406	140 CONTINUE
407	C
408	200 RETURN
409	END
410	SUBROUTINE BANDR(NM,N,MB,A,D,E,E2,MATZ,Z)
411	C
412	INTEGER J,K,L,N,R,I1,I2,J1,J2,KR,MB,MR,M1,NM,N2,R1,UGL,MAXL,MAXR
413	DOUBLE PRECISION A(NM,MB),D(N),E(N),E2(N),Z(NM,N)
414	DOUBLE PRECISION G,U,B1,B2,C2,F1,F2,S2,DMIN,DMINRT
415	LOGICAL MATZ
416	C
417	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BANDRD,
418	C NUM. MATH. 12, 231-241(1968) BY SCHWARZ.
419	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 273-283(1971).
420	C
421	C THIS SUBROUTINE REDUCES A REAL SYMMETRIC BAND MATRIX
422	C TO A SYMMETRIC TRIDIAGONAL MATRIX USING AND OPTIONALLY
423	C ACCUMULATING ORTHOGONAL SIMILARITY TRANSFORMATIONS.
424	C
425	C ON INPUT
426	C
427	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
428	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
429	C DIMENSION STATEMENT.
430	C
431	C N IS THE ORDER OF THE MATRIX.
432	C
433	C MB IS THE (HALF) BAND WIDTH OF THE MATRIX, DEFINED AS THE
434	C NUMBER OF ADJACENT DIAGONALS, INCLUDING THE PRINCIPAL
435	C DIAGONAL, REQUIRED TO SPECIFY THE NON-ZERO PORTION OF THE
436	C LOWER TRIANGLE OF THE MATRIX.
437	C
438	C A CONTAINS THE LOWER TRIANGLE OF THE SYMMETRIC BAND INPUT
439	C MATRIX STORED AS AN N BY MB ARRAY. ITS LOWEST SUBDIAGONAL
440	C IS STORED IN THE LAST N+1-MB POSITIONS OF THE FIRST COLUMN,
441	C ITS NEXT SUBDIAGONAL IN THE LAST N+2-MB POSITIONS OF THE
442	C SECOND COLUMN, FURTHER SUBDIAGONALS SIMILARLY, AND FINALLY
443	C ITS PRINCIPAL DIAGONAL IN THE N POSITIONS OF THE LAST COLUMN.
444	C CONTENTS OF STORAGES NOT PART OF THE MATRIX ARE ARBITRARY.
445	C
446	C MATZ SHOULD BE SET TO .TRUE. IF THE TRANSFORMATION MATRIX IS
447	C TO BE ACCUMULATED, AND TO .FALSE. OTHERWISE.
448	C
449	C ON OUTPUT
450	C
451	C A HAS BEEN DESTROYED, EXCEPT FOR ITS LAST TWO COLUMNS WHICH
452	C CONTAIN A COPY OF THE TRIDIAGONAL MATRIX.
453	C
454	C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX.
455	C
456	C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
457	C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO.
458	C
459	C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
460	C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
461	C
462	C Z CONTAINS THE ORTHOGONAL TRANSFORMATION MATRIX PRODUCED IN
463	C THE REDUCTION IF MATZ HAS BEEN SET TO .TRUE. OTHERWISE, Z
464	C IS NOT REFERENCED.
465	C
466	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
467	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
468	C
469	C THIS VERSION DATED AUGUST 1983.
470	C
471	C ------------------------------------------------------------------
472	C
473	DMIN = 2.0D0**(-64)
474	DMINRT = 2.0D0**(-32)
475	C .......... INITIALIZE DIAGONAL SCALING MATRIX ..........
476	DO 30 J = 1, N
477	30 D(J) = 1.0D0
478	C
479	IF (.NOT. MATZ) GO TO 60
480	C
481	DO 50 J = 1, N
482	C
483	DO 40 K = 1, N
484	40 Z(J,K) = 0.0D0
485	C
486	Z(J,J) = 1.0D0
487	50 CONTINUE
488	C
489	60 M1 = MB - 1
490	IF (M1 - 1) 900, 800, 70
491	70 N2 = N - 2
492	C
493	DO 700 K = 1, N2
494	MAXR = MIN0(M1,N-K)
495	C .......... FOR R=MAXR STEP -1 UNTIL 2 DO -- ..........
496	DO 600 R1 = 2, MAXR
497	R = MAXR + 2 - R1
498	KR = K + R
499	MR = MB - R
500	G = A(KR,MR)
501	A(KR-1,1) = A(KR-1,MR+1)
502	UGL = K
503	C
504	DO 500 J = KR, N, M1
505	J1 = J - 1
506	J2 = J1 - 1
507	IF (G .EQ. 0.0D0) GO TO 600
508	B1 = A(J1,1) / G
509	B2 = B1 * D(J1) / D(J)
510	S2 = 1.0D0 / (1.0D0 + B1 * B2)
511	IF (S2 .GE. 0.5D0 ) GO TO 450
512	B1 = G / A(J1,1)
513	B2 = B1 * D(J) / D(J1)
514	C2 = 1.0D0 - S2
515	D(J1) = C2 * D(J1)
516	D(J) = C2 * D(J)
517	F1 = 2.0D0 * A(J,M1)
518	F2 = B1 * A(J1,MB)
519	A(J,M1) = -B2 * (B1 * A(J,M1) - A(J,MB)) - F2 + A(J,M1)
520	A(J1,MB) = B2 * (B2 * A(J,MB) + F1) + A(J1,MB)
521	A(J,MB) = B1 * (F2 - F1) + A(J,MB)
522	C
523	DO 200 L = UGL, J2
524	I2 = MB - J + L
525	U = A(J1,I2+1) + B2 * A(J,I2)
526	A(J,I2) = -B1 * A(J1,I2+1) + A(J,I2)
527	A(J1,I2+1) = U
528	200 CONTINUE
529	C
530	UGL = J
531	A(J1,1) = A(J1,1) + B2 * G
532	IF (J .EQ. N) GO TO 350
533	MAXL = MIN0(M1,N-J1)
534	C
535	DO 300 L = 2, MAXL
536	I1 = J1 + L
537	I2 = MB - L
538	U = A(I1,I2) + B2 * A(I1,I2+1)
539	A(I1,I2+1) = -B1 * A(I1,I2) + A(I1,I2+1)
540	A(I1,I2) = U
541	300 CONTINUE
542	C
543	I1 = J + M1
544	IF (I1 .GT. N) GO TO 350
545	G = B2 * A(I1,1)
546	350 IF (.NOT. MATZ) GO TO 500
547	C
548	DO 400 L = 1, N
549	U = Z(L,J1) + B2 * Z(L,J)
550	Z(L,J) = -B1 * Z(L,J1) + Z(L,J)
551	Z(L,J1) = U
552	400 CONTINUE
553	C
554	GO TO 500
555	C
556	450 U = D(J1)
557	D(J1) = S2 * D(J)
558	D(J) = S2 * U
559	F1 = 2.0D0 * A(J,M1)
560	F2 = B1 * A(J,MB)
561	U = B1 * (F2 - F1) + A(J1,MB)
562	A(J,M1) = B2 * (B1 * A(J,M1) - A(J1,MB)) + F2 - A(J,M1)
563	A(J1,MB) = B2 * (B2 * A(J1,MB) + F1) + A(J,MB)
564	A(J,MB) = U
565	C
566	DO 460 L = UGL, J2
567	I2 = MB - J + L
568	U = B2 * A(J1,I2+1) + A(J,I2)
569	A(J,I2) = -A(J1,I2+1) + B1 * A(J,I2)
570	A(J1,I2+1) = U
571	460 CONTINUE
572	C
573	UGL = J
574	A(J1,1) = B2 * A(J1,1) + G
575	IF (J .EQ. N) GO TO 480
576	MAXL = MIN0(M1,N-J1)
577	C
578	DO 470 L = 2, MAXL
579	I1 = J1 + L
580	I2 = MB - L
581	U = B2 * A(I1,I2) + A(I1,I2+1)
582	A(I1,I2+1) = -A(I1,I2) + B1 * A(I1,I2+1)
583	A(I1,I2) = U
584	470 CONTINUE
585	C
586	I1 = J + M1
587	IF (I1 .GT. N) GO TO 480
588	G = A(I1,1)
589	A(I1,1) = B1 * A(I1,1)
590	480 IF (.NOT. MATZ) GO TO 500
591	C
592	DO 490 L = 1, N
593	U = B2 * Z(L,J1) + Z(L,J)
594	Z(L,J) = -Z(L,J1) + B1 * Z(L,J)
595	Z(L,J1) = U
596	490 CONTINUE
597	C
598	500 CONTINUE
599	C
600	600 CONTINUE
601	C
602	IF (MOD(K,64) .NE. 0) GO TO 700
603	C .......... RESCALE TO AVOID UNDERFLOW OR OVERFLOW ..........
604	DO 650 J = K, N
605	IF (D(J) .GE. DMIN) GO TO 650
606	MAXL = MAX0(1,MB+1-J)
607	C
608	DO 610 L = MAXL, M1
609	610 A(J,L) = DMINRT * A(J,L)
610	C
611	IF (J .EQ. N) GO TO 630
612	MAXL = MIN0(M1,N-J)
613	C
614	DO 620 L = 1, MAXL
615	I1 = J + L
616	I2 = MB - L
617	A(I1,I2) = DMINRT * A(I1,I2)
618	620 CONTINUE
619	C
620	630 IF (.NOT. MATZ) GO TO 645
621	C
622	DO 640 L = 1, N
623	640 Z(L,J) = DMINRT * Z(L,J)
624	C
625	645 A(J,MB) = DMIN * A(J,MB)
626	D(J) = D(J) / DMIN
627	650 CONTINUE
628	C
629	700 CONTINUE
630	C .......... FORM SQUARE ROOT OF SCALING MATRIX ..........
631	800 DO 810 J = 2, N
632	810 E(J) = DSQRT(D(J))
633	C
634	IF (.NOT. MATZ) GO TO 840
635	C
636	DO 830 J = 1, N
637	C
638	DO 820 K = 2, N
639	820 Z(J,K) = E(K) * Z(J,K)
640	C
641	830 CONTINUE
642	C
643	840 U = 1.0D0
644	C
645	DO 850 J = 2, N
646	A(J,M1) = U * E(J) * A(J,M1)
647	U = E(J)
648	E2(J) = A(J,M1) ** 2
649	A(J,MB) = D(J) * A(J,MB)
650	D(J) = A(J,MB)
651	E(J) = A(J,M1)
652	850 CONTINUE
653	C
654	D(1) = A(1,MB)
655	E(1) = 0.0D0
656	E2(1) = 0.0D0
657	GO TO 1001
658	C
659	900 DO 950 J = 1, N
660	D(J) = A(J,MB)
661	E(J) = 0.0D0
662	E2(J) = 0.0D0
663	950 CONTINUE
664	C
665	1001 RETURN
666	END
667	SUBROUTINE BANDV(NM,N,MBW,A,E21,M,W,Z,IERR,NV,RV,RV6)
668	C
669	INTEGER I,J,K,M,N,R,II,IJ,JJ,KJ,MB,M1,NM,NV,IJ1,ITS,KJ1,MBW,M21,
670	X IERR,MAXJ,MAXK,GROUP
671	DOUBLE PRECISION A(NM,MBW),W(M),Z(NM,M),RV(NV),RV6(N)
672	DOUBLE PRECISION U,V,UK,XU,X0,X1,E21,EPS2,EPS3,EPS4,NORM,ORDER,
673	X EPSLON,PYTHAG
674	C
675	C THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A REAL SYMMETRIC
676	C BAND MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES, USING INVERSE
677	C ITERATION. THE SUBROUTINE MAY ALSO BE USED TO SOLVE SYSTEMS
678	C OF LINEAR EQUATIONS WITH A SYMMETRIC OR NON-SYMMETRIC BAND
679	C COEFFICIENT MATRIX.
680	C
681	C ON INPUT
682	C
683	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
684	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
685	C DIMENSION STATEMENT.
686	C
687	C N IS THE ORDER OF THE MATRIX.
688	C
689	C MBW IS THE NUMBER OF COLUMNS OF THE ARRAY A USED TO STORE THE
690	C BAND MATRIX. IF THE MATRIX IS SYMMETRIC, MBW IS ITS (HALF)
691	C BAND WIDTH, DENOTED MB AND DEFINED AS THE NUMBER OF ADJACENT
692	C DIAGONALS, INCLUDING THE PRINCIPAL DIAGONAL, REQUIRED TO
693	C SPECIFY THE NON-ZERO PORTION OF THE LOWER TRIANGLE OF THE
694	C MATRIX. IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS
695	C OF LINEAR EQUATIONS AND THE COEFFICIENT MATRIX IS NOT
696	C SYMMETRIC, IT MUST HOWEVER HAVE THE SAME NUMBER OF ADJACENT
697	C DIAGONALS ABOVE THE MAIN DIAGONAL AS BELOW, AND IN THIS
698	C CASE, MBW=2*MB-1.
699	C
700	C A CONTAINS THE LOWER TRIANGLE OF THE SYMMETRIC BAND INPUT
701	C MATRIX STORED AS AN N BY MB ARRAY. ITS LOWEST SUBDIAGONAL
702	C IS STORED IN THE LAST N+1-MB POSITIONS OF THE FIRST COLUMN,
703	C ITS NEXT SUBDIAGONAL IN THE LAST N+2-MB POSITIONS OF THE
704	C SECOND COLUMN, FURTHER SUBDIAGONALS SIMILARLY, AND FINALLY
705	C ITS PRINCIPAL DIAGONAL IN THE N POSITIONS OF COLUMN MB.
706	C IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS OF LINEAR
707	C EQUATIONS AND THE COEFFICIENT MATRIX IS NOT SYMMETRIC, A IS
708	C N BY 2*MB-1 INSTEAD WITH LOWER TRIANGLE AS ABOVE AND WITH
709	C ITS FIRST SUPERDIAGONAL STORED IN THE FIRST N-1 POSITIONS OF
710	C COLUMN MB+1, ITS SECOND SUPERDIAGONAL IN THE FIRST N-2
711	C POSITIONS OF COLUMN MB+2, FURTHER SUPERDIAGONALS SIMILARLY,
712	C AND FINALLY ITS HIGHEST SUPERDIAGONAL IN THE FIRST N+1-MB
713	C POSITIONS OF THE LAST COLUMN.
714	C CONTENTS OF STORAGES NOT PART OF THE MATRIX ARE ARBITRARY.
715	C
716	C E21 SPECIFIES THE ORDERING OF THE EIGENVALUES AND CONTAINS
717	C 0.0D0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, OR
718	C 2.0D0 IF THE EIGENVALUES ARE IN DESCENDING ORDER.
719	C IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS OF LINEAR
720	C EQUATIONS, E21 SHOULD BE SET TO 1.0D0 IF THE COEFFICIENT
721	C MATRIX IS SYMMETRIC AND TO -1.0D0 IF NOT.
722	C
723	C M IS THE NUMBER OF SPECIFIED EIGENVALUES OR THE NUMBER OF
724	C SYSTEMS OF LINEAR EQUATIONS.
725	C
726	C W CONTAINS THE M EIGENVALUES IN ASCENDING OR DESCENDING ORDER.
727	C IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS OF LINEAR
728	C EQUATIONS (A-W(R)I)X(R)=B(R), WHERE I IS THE IDENTITY
729	C MATRIX, W(R) SHOULD BE SET ACCORDINGLY, FOR R=1,2,...,M.
730	C
731	C Z CONTAINS THE CONSTANT MATRIX COLUMNS (B(R),R=1,2,...,M), IF
732	C THE SUBROUTINE IS USED TO SOLVE SYSTEMS OF LINEAR EQUATIONS.
733	C
734	C NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER RV
735	C AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT.
736	C
737	C ON OUTPUT
738	C
739	C A AND W ARE UNALTERED.
740	C
741	C Z CONTAINS THE ASSOCIATED SET OF ORTHOGONAL EIGENVECTORS.
742	C ANY VECTOR WHICH FAILS TO CONVERGE IS SET TO ZERO. IF THE
743	C SUBROUTINE IS USED TO SOLVE SYSTEMS OF LINEAR EQUATIONS,
744	C Z CONTAINS THE SOLUTION MATRIX COLUMNS (X(R),R=1,2,...,M).
745	C
746	C IERR IS SET TO
747	C ZERO FOR NORMAL RETURN,
748	C -R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH
749	C EIGENVALUE FAILS TO CONVERGE, OR IF THE R-TH
750	C SYSTEM OF LINEAR EQUATIONS IS NEARLY SINGULAR.
751	C
752	C RV AND RV6 ARE TEMPORARY STORAGE ARRAYS. NOTE THAT RV IS
753	C OF DIMENSION AT LEAST N(2MB-1). IF THE SUBROUTINE
754	C IS BEING USED TO SOLVE SYSTEMS OF LINEAR EQUATIONS, THE
755	C DETERMINANT (UP TO SIGN) OF A-W(M)*I IS AVAILABLE, UPON
756	C RETURN, AS THE PRODUCT OF THE FIRST N ELEMENTS OF RV.
757	C
758	C CALLS PYTHAG FOR DSQRT(AA + BB) .
759	C
760	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
761	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
762	C
763	C THIS VERSION DATED AUGUST 1983.
764	C
765	C ------------------------------------------------------------------
766	C
767	IERR = 0
768	IF (M .EQ. 0) GO TO 1001
769	MB = MBW
770	IF (E21 .LT. 0.0D0) MB = (MBW + 1) / 2
771	M1 = MB - 1
772	M21 = M1 + MB
773	ORDER = 1.0D0 - DABS(E21)
774	C .......... FIND VECTORS BY INVERSE ITERATION ..........
775	DO 920 R = 1, M
776	ITS = 1
777	X1 = W(R)
778	IF (R .NE. 1) GO TO 100
779	C .......... COMPUTE NORM OF MATRIX ..........
780	NORM = 0.0D0
781	C
782	DO 60 J = 1, MB
783	JJ = MB + 1 - J
784	KJ = JJ + M1
785	IJ = 1
786	V = 0.0D0
787	C
788	DO 40 I = JJ, N
789	V = V + DABS(A(I,J))
790	IF (E21 .GE. 0.0D0) GO TO 40
791	V = V + DABS(A(IJ,KJ))
792	IJ = IJ + 1
793	40 CONTINUE
794	C
795	NORM = DMAX1(NORM,V)
796	60 CONTINUE
797	C
798	IF (E21 .LT. 0.0D0) NORM = 0.5D0 * NORM
799	C .......... EPS2 IS THE CRITERION FOR GROUPING,
800	C EPS3 REPLACES ZERO PIVOTS AND EQUAL
801	C ROOTS ARE MODIFIED BY EPS3,
802	C EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW ..........
803	IF (NORM .EQ. 0.0D0) NORM = 1.0D0
804	EPS2 = 1.0D-3 * NORM * DABS(ORDER)
805	EPS3 = EPSLON(NORM)
806	UK = N
807	UK = DSQRT(UK)
808	EPS4 = UK * EPS3
809	80 GROUP = 0
810	GO TO 120
811	C .......... LOOK FOR CLOSE OR COINCIDENT ROOTS ..........
812	100 IF (DABS(X1-X0) .GE. EPS2) GO TO 80
813	GROUP = GROUP + 1
814	IF (ORDER * (X1 - X0) .LE. 0.0D0) X1 = X0 + ORDER * EPS3
815	C .......... EXPAND MATRIX, SUBTRACT EIGENVALUE,
816	C AND INITIALIZE VECTOR ..........
817	120 DO 200 I = 1, N
818	IJ = I + MIN0(0,I-M1) * N
819	KJ = IJ + MB * N
820	IJ1 = KJ + M1 * N
821	IF (M1 .EQ. 0) GO TO 180
822	C
823	DO 150 J = 1, M1
824	IF (IJ .GT. M1) GO TO 125
825	IF (IJ .GT. 0) GO TO 130
826	RV(IJ1) = 0.0D0
827	IJ1 = IJ1 + N
828	GO TO 130
829	125 RV(IJ) = A(I,J)
830	130 IJ = IJ + N
831	II = I + J
832	IF (II .GT. N) GO TO 150
833	JJ = MB - J
834	IF (E21 .GE. 0.0D0) GO TO 140
835	II = I
836	JJ = MB + J
837	140 RV(KJ) = A(II,JJ)
838	KJ = KJ + N
839	150 CONTINUE
840	C
841	180 RV(IJ) = A(I,MB) - X1
842	RV6(I) = EPS4
843	IF (ORDER .EQ. 0.0D0) RV6(I) = Z(I,R)
844	200 CONTINUE
845	C
846	IF (M1 .EQ. 0) GO TO 600
847	C .......... ELIMINATION WITH INTERCHANGES ..........
848	DO 580 I = 1, N
849	II = I + 1
850	MAXK = MIN0(I+M1-1,N)
851	MAXJ = MIN0(N-I,M21-2) * N
852	C
853	DO 360 K = I, MAXK
854	KJ1 = K
855	J = KJ1 + N
856	JJ = J + MAXJ
857	C
858	DO 340 KJ = J, JJ, N
859	RV(KJ1) = RV(KJ)
860	KJ1 = KJ
861	340 CONTINUE
862	C
863	RV(KJ1) = 0.0D0
864	360 CONTINUE
865	C
866	IF (I .EQ. N) GO TO 580
867	U = 0.0D0
868	MAXK = MIN0(I+M1,N)
869	MAXJ = MIN0(N-II,M21-2) * N
870	C
871	DO 450 J = I, MAXK
872	IF (DABS(RV(J)) .LT. DABS(U)) GO TO 450
873	U = RV(J)
874	K = J
875	450 CONTINUE
876	C
877	J = I + N
878	JJ = J + MAXJ
879	IF (K .EQ. I) GO TO 520
880	KJ = K
881	C
882	DO 500 IJ = I, JJ, N
883	V = RV(IJ)
884	RV(IJ) = RV(KJ)
885	RV(KJ) = V
886	KJ = KJ + N
887	500 CONTINUE
888	C
889	IF (ORDER .NE. 0.0D0) GO TO 520
890	V = RV6(I)
891	RV6(I) = RV6(K)
892	RV6(K) = V
893	520 IF (U .EQ. 0.0D0) GO TO 580
894	C
895	DO 560 K = II, MAXK
896	V = RV(K) / U
897	KJ = K
898	C
899	DO 540 IJ = J, JJ, N
900	KJ = KJ + N
901	RV(KJ) = RV(KJ) - V * RV(IJ)
902	540 CONTINUE
903	C
904	IF (ORDER .EQ. 0.0D0) RV6(K) = RV6(K) - V * RV6(I)
905	560 CONTINUE
906	C
907	580 CONTINUE
908	C .......... BACK SUBSTITUTION
909	C FOR I=N STEP -1 UNTIL 1 DO -- ..........
910	600 DO 630 II = 1, N
911	I = N + 1 - II
912	MAXJ = MIN0(II,M21)
913	IF (MAXJ .EQ. 1) GO TO 620
914	IJ1 = I
915	J = IJ1 + N
916	JJ = J + (MAXJ - 2) * N
917	C
918	DO 610 IJ = J, JJ, N
919	IJ1 = IJ1 + 1
920	RV6(I) = RV6(I) - RV(IJ) * RV6(IJ1)
921	610 CONTINUE
922	C
923	620 V = RV(I)
924	IF (DABS(V) .GE. EPS3) GO TO 625
925	C .......... SET ERROR -- NEARLY SINGULAR LINEAR SYSTEM ..........
926	IF (ORDER .EQ. 0.0D0) IERR = -R
927	V = DSIGN(EPS3,V)
928	625 RV6(I) = RV6(I) / V
929	630 CONTINUE
930	C
931	XU = 1.0D0
932	IF (ORDER .EQ. 0.0D0) GO TO 870
933	C .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS
934	C MEMBERS OF GROUP ..........
935	IF (GROUP .EQ. 0) GO TO 700
936	C
937	DO 680 JJ = 1, GROUP
938	J = R - GROUP - 1 + JJ
939	XU = 0.0D0
940	C
941	DO 640 I = 1, N
942	640 XU = XU + RV6(I) * Z(I,J)
943	C
944	DO 660 I = 1, N
945	660 RV6(I) = RV6(I) - XU * Z(I,J)
946	C
947	680 CONTINUE
948	C
949	700 NORM = 0.0D0
950	C
951	DO 720 I = 1, N
952	720 NORM = NORM + DABS(RV6(I))
953	C
954	IF (NORM .GE. 0.1D0) GO TO 840
955	C .......... IN-LINE PROCEDURE FOR CHOOSING
956	C A NEW STARTING VECTOR ..........
957	IF (ITS .GE. N) GO TO 830
958	ITS = ITS + 1
959	XU = EPS4 / (UK + 1.0D0)
960	RV6(1) = EPS4
961	C
962	DO 760 I = 2, N
963	760 RV6(I) = XU
964	C
965	RV6(ITS) = RV6(ITS) - EPS4 * UK
966	GO TO 600
967	C .......... SET ERROR -- NON-CONVERGED EIGENVECTOR ..........
968	830 IERR = -R
969	XU = 0.0D0
970	GO TO 870
971	C .......... NORMALIZE SO THAT SUM OF SQUARES IS
972	C 1 AND EXPAND TO FULL ORDER ..........
973	840 U = 0.0D0
974	C
975	DO 860 I = 1, N
976	860 U = PYTHAG(U,RV6(I))
977	C
978	XU = 1.0D0 / U
979	C
980	870 DO 900 I = 1, N
981	900 Z(I,R) = RV6(I) * XU
982	C
983	X0 = X1
984	920 CONTINUE
985	C
986	1001 RETURN
987	END
988	SUBROUTINE BISECT(N,EPS1,D,E,E2,LB,UB,MM,M,W,IND,IERR,RV4,RV5)
989	C
990	INTEGER I,J,K,L,M,N,P,Q,R,S,II,MM,M1,M2,TAG,IERR,ISTURM
991	DOUBLE PRECISION D(N),E(N),E2(N),W(MM),RV4(N),RV5(N)
992	DOUBLE PRECISION U,V,LB,T1,T2,UB,XU,X0,X1,EPS1,TST1,TST2,EPSLON
993	INTEGER IND(MM)
994	C
995	C THIS SUBROUTINE IS A TRANSLATION OF THE BISECTION TECHNIQUE
996	C IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON.
997	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971).
998	C
999	C THIS SUBROUTINE FINDS THOSE EIGENVALUES OF A TRIDIAGONAL
1000	C SYMMETRIC MATRIX WHICH LIE IN A SPECIFIED INTERVAL,
1001	C USING BISECTION.
1002	C
1003	C ON INPUT
1004	C
1005	C N IS THE ORDER OF THE MATRIX.
1006	C
1007	C EPS1 IS AN ABSOLUTE ERROR TOLERANCE FOR THE COMPUTED
1008	C EIGENVALUES. IF THE INPUT EPS1 IS NON-POSITIVE,
1009	C IT IS RESET FOR EACH SUBMATRIX TO A DEFAULT VALUE,
1010	C NAMELY, MINUS THE PRODUCT OF THE RELATIVE MACHINE
1011	C PRECISION AND THE 1-NORM OF THE SUBMATRIX.
1012	C
1013	C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
1014	C
1015	C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
1016	C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY.
1017	C
1018	C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
1019	C E2(1) IS ARBITRARY.
1020	C
1021	C LB AND UB DEFINE THE INTERVAL TO BE SEARCHED FOR EIGENVALUES.
1022	C IF LB IS NOT LESS THAN UB, NO EIGENVALUES WILL BE FOUND.
1023	C
1024	C MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF
1025	C EIGENVALUES IN THE INTERVAL. WARNING. IF MORE THAN
1026	C MM EIGENVALUES ARE DETERMINED TO LIE IN THE INTERVAL,
1027	C AN ERROR RETURN IS MADE WITH NO EIGENVALUES FOUND.
1028	C
1029	C ON OUTPUT
1030	C
1031	C EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS
1032	C (LAST) DEFAULT VALUE.
1033	C
1034	C D AND E ARE UNALTERED.
1035	C
1036	C ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED
1037	C AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE
1038	C MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES.
1039	C E2(1) IS ALSO SET TO ZERO.
1040	C
1041	C M IS THE NUMBER OF EIGENVALUES DETERMINED TO LIE IN (LB,UB).
1042	C
1043	C W CONTAINS THE M EIGENVALUES IN ASCENDING ORDER.
1044	C
1045	C IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES
1046	C ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W --
1047	C 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM
1048	C THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC..
1049	C
1050	C IERR IS SET TO
1051	C ZERO FOR NORMAL RETURN,
1052	C 3*N+1 IF M EXCEEDS MM.
1053	C
1054	C RV4 AND RV5 ARE TEMPORARY STORAGE ARRAYS.
1055	C
1056	C THE ALGOL PROCEDURE STURMCNT CONTAINED IN TRISTURM
1057	C APPEARS IN BISECT IN-LINE.
1058	C
1059	C NOTE THAT SUBROUTINE TQL1 OR IMTQL1 IS GENERALLY FASTER THAN
1060	C BISECT, IF MORE THAN N/4 EIGENVALUES ARE TO BE FOUND.
1061	C
1062	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
1063	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
1064	C
1065	C THIS VERSION DATED AUGUST 1983.
1066	C
1067	C ------------------------------------------------------------------
1068	C
1069	IERR = 0
1070	TAG = 0
1071	T1 = LB
1072	T2 = UB
1073	C .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES ..........
1074	DO 40 I = 1, N
1075	IF (I .EQ. 1) GO TO 20
1076	TST1 = DABS(D(I)) + DABS(D(I-1))
1077	TST2 = TST1 + DABS(E(I))
1078	IF (TST2 .GT. TST1) GO TO 40
1079	20 E2(I) = 0.0D0
1080	40 CONTINUE
1081	C .......... DETERMINE THE NUMBER OF EIGENVALUES
1082	C IN THE INTERVAL ..........
1083	P = 1
1084	Q = N
1085	X1 = UB
1086	ISTURM = 1
1087	GO TO 320
1088	60 M = S
1089	X1 = LB
1090	ISTURM = 2
1091	GO TO 320
1092	80 M = M - S
1093	IF (M .GT. MM) GO TO 980
1094	Q = 0
1095	R = 0
1096	C .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING
1097	C INTERVAL BY THE GERSCHGORIN BOUNDS ..........
1098	100 IF (R .EQ. M) GO TO 1001
1099	TAG = TAG + 1
1100	P = Q + 1
1101	XU = D(P)
1102	X0 = D(P)
1103	U = 0.0D0
1104	C
1105	DO 120 Q = P, N
1106	X1 = U
1107	U = 0.0D0
1108	V = 0.0D0
1109	IF (Q .EQ. N) GO TO 110
1110	U = DABS(E(Q+1))
1111	V = E2(Q+1)
1112	110 XU = DMIN1(D(Q)-(X1+U),XU)
1113	X0 = DMAX1(D(Q)+(X1+U),X0)
1114	IF (V .EQ. 0.0D0) GO TO 140
1115	120 CONTINUE
1116	C
1117	140 X1 = EPSLON(DMAX1(DABS(XU),DABS(X0)))
1118	IF (EPS1 .LE. 0.0D0) EPS1 = -X1
1119	IF (P .NE. Q) GO TO 180
1120	C .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL ..........
1121	IF (T1 .GT. D(P) .OR. D(P) .GE. T2) GO TO 940
1122	M1 = P
1123	M2 = P
1124	RV5(P) = D(P)
1125	GO TO 900
1126	180 X1 = X1 * (Q - P + 1)
1127	LB = DMAX1(T1,XU-X1)
1128	UB = DMIN1(T2,X0+X1)
1129	X1 = LB
1130	ISTURM = 3
1131	GO TO 320
1132	200 M1 = S + 1
1133	X1 = UB
1134	ISTURM = 4
1135	GO TO 320
1136	220 M2 = S
1137	IF (M1 .GT. M2) GO TO 940
1138	C .......... FIND ROOTS BY BISECTION ..........
1139	X0 = UB
1140	ISTURM = 5
1141	C
1142	DO 240 I = M1, M2
1143	RV5(I) = UB
1144	RV4(I) = LB
1145	240 CONTINUE
1146	C .......... LOOP FOR K-TH EIGENVALUE
1147	C FOR K=M2 STEP -1 UNTIL M1 DO --
1148	C (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) ..........
1149	K = M2
1150	250 XU = LB
1151	C .......... FOR I=K STEP -1 UNTIL M1 DO -- ..........
1152	DO 260 II = M1, K
1153	I = M1 + K - II
1154	IF (XU .GE. RV4(I)) GO TO 260
1155	XU = RV4(I)
1156	GO TO 280
1157	260 CONTINUE
1158	C
1159	280 IF (X0 .GT. RV5(K)) X0 = RV5(K)
1160	C .......... NEXT BISECTION STEP ..........
1161	300 X1 = (XU + X0) * 0.5D0
1162	IF ((X0 - XU) .LE. DABS(EPS1)) GO TO 420
1163	TST1 = 2.0D0 * (DABS(XU) + DABS(X0))
1164	TST2 = TST1 + (X0 - XU)
1165	IF (TST2 .EQ. TST1) GO TO 420
1166	C .......... IN-LINE PROCEDURE FOR STURM SEQUENCE ..........
1167	320 S = P - 1
1168	U = 1.0D0
1169	C
1170	DO 340 I = P, Q
1171	IF (U .NE. 0.0D0) GO TO 325
1172	V = DABS(E(I)) / EPSLON(1.0D0)
1173	IF (E2(I) .EQ. 0.0D0) V = 0.0D0
1174	GO TO 330
1175	325 V = E2(I) / U
1176	330 U = D(I) - X1 - V
1177	IF (U .LT. 0.0D0) S = S + 1
1178	340 CONTINUE
1179	C
1180	GO TO (60,80,200,220,360), ISTURM
1181	C .......... REFINE INTERVALS ..........
1182	360 IF (S .GE. K) GO TO 400
1183	XU = X1
1184	IF (S .GE. M1) GO TO 380
1185	RV4(M1) = X1
1186	GO TO 300
1187	380 RV4(S+1) = X1
1188	IF (RV5(S) .GT. X1) RV5(S) = X1
1189	GO TO 300
1190	400 X0 = X1
1191	GO TO 300
1192	C .......... K-TH EIGENVALUE FOUND ..........
1193	420 RV5(K) = X1
1194	K = K - 1
1195	IF (K .GE. M1) GO TO 250
1196	C .......... ORDER EIGENVALUES TAGGED WITH THEIR
1197	C SUBMATRIX ASSOCIATIONS ..........
1198	900 S = R
1199	R = R + M2 - M1 + 1
1200	J = 1
1201	K = M1
1202	C
1203	DO 920 L = 1, R
1204	IF (J .GT. S) GO TO 910
1205	IF (K .GT. M2) GO TO 940
1206	IF (RV5(K) .GE. W(L)) GO TO 915
1207	C
1208	DO 905 II = J, S
1209	I = L + S - II
1210	W(I+1) = W(I)
1211	IND(I+1) = IND(I)
1212	905 CONTINUE
1213	C
1214	910 W(L) = RV5(K)
1215	IND(L) = TAG
1216	K = K + 1
1217	GO TO 920
1218	915 J = J + 1
1219	920 CONTINUE
1220	C
1221	940 IF (Q .LT. N) GO TO 100
1222	GO TO 1001
1223	C .......... SET ERROR -- UNDERESTIMATE OF NUMBER OF
1224	C EIGENVALUES IN INTERVAL ..........
1225	980 IERR = 3 * N + 1
1226	1001 LB = T1
1227	UB = T2
1228	RETURN
1229	END
1230	SUBROUTINE BQR(NM,N,MB,A,T,R,IERR,NV,RV)
1231	C
1232	INTEGER I,J,K,L,M,N,II,IK,JK,JM,KJ,KK,KM,LL,MB,MK,MN,MZ,
1233	X M1,M2,M3,M4,NI,NM,NV,ITS,KJ1,M21,M31,IERR,IMULT
1234	DOUBLE PRECISION A(NM,MB),RV(NV)
1235	DOUBLE PRECISION F,G,Q,R,S,T,TST1,TST2,SCALE,PYTHAG
1236	C
1237	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BQR,
1238	C NUM. MATH. 16, 85-92(1970) BY MARTIN, REINSCH, AND WILKINSON.
1239	C HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 266-272(1971).
1240	C
1241	C THIS SUBROUTINE FINDS THE EIGENVALUE OF SMALLEST (USUALLY)
1242	C MAGNITUDE OF A REAL SYMMETRIC BAND MATRIX USING THE
1243	C QR ALGORITHM WITH SHIFTS OF ORIGIN. CONSECUTIVE CALLS
1244	C CAN BE MADE TO FIND FURTHER EIGENVALUES.
1245	C
1246	C ON INPUT
1247	C
1248	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
1249	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
1250	C DIMENSION STATEMENT.
1251	C
1252	C N IS THE ORDER OF THE MATRIX.
1253	C
1254	C MB IS THE (HALF) BAND WIDTH OF THE MATRIX, DEFINED AS THE
1255	C NUMBER OF ADJACENT DIAGONALS, INCLUDING THE PRINCIPAL
1256	C DIAGONAL, REQUIRED TO SPECIFY THE NON-ZERO PORTION OF THE
1257	C LOWER TRIANGLE OF THE MATRIX.
1258	C
1259	C A CONTAINS THE LOWER TRIANGLE OF THE SYMMETRIC BAND INPUT
1260	C MATRIX STORED AS AN N BY MB ARRAY. ITS LOWEST SUBDIAGONAL
1261	C IS STORED IN THE LAST N+1-MB POSITIONS OF THE FIRST COLUMN,
1262	C ITS NEXT SUBDIAGONAL IN THE LAST N+2-MB POSITIONS OF THE
1263	C SECOND COLUMN, FURTHER SUBDIAGONALS SIMILARLY, AND FINALLY
1264	C ITS PRINCIPAL DIAGONAL IN THE N POSITIONS OF THE LAST COLUMN.
1265	C CONTENTS OF STORAGES NOT PART OF THE MATRIX ARE ARBITRARY.
1266	C ON A SUBSEQUENT CALL, ITS OUTPUT CONTENTS FROM THE PREVIOUS
1267	C CALL SHOULD BE PASSED.
1268	C
1269	C T SPECIFIES THE SHIFT (OF EIGENVALUES) APPLIED TO THE DIAGONAL
1270	C OF A IN FORMING THE INPUT MATRIX. WHAT IS ACTUALLY DETERMINED
1271	C IS THE EIGENVALUE OF A+TI (I IS THE IDENTITY MATRIX) NEAREST
1272	C TO T. ON A SUBSEQUENT CALL, THE OUTPUT VALUE OF T FROM THE
1273	C PREVIOUS CALL SHOULD BE PASSED IF THE NEXT NEAREST EIGENVALUE
1274	C IS SOUGHT.
1275	C
1276	C R SHOULD BE SPECIFIED AS ZERO ON THE FIRST CALL, AND AS ITS
1277	C OUTPUT VALUE FROM THE PREVIOUS CALL ON A SUBSEQUENT CALL.
1278	C IT IS USED TO DETERMINE WHEN THE LAST ROW AND COLUMN OF
1279	C THE TRANSFORMED BAND MATRIX CAN BE REGARDED AS NEGLIGIBLE.
1280	C
1281	C NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER RV
1282	C AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT.
1283	C
1284	C ON OUTPUT
1285	C
1286	C A CONTAINS THE TRANSFORMED BAND MATRIX. THE MATRIX A+TI
1287	C DERIVED FROM THE OUTPUT PARAMETERS IS SIMILAR TO THE
1288	C INPUT A+TI TO WITHIN ROUNDING ERRORS. ITS LAST ROW AND
1289	C COLUMN ARE NULL (IF IERR IS ZERO).
1290	C
1291	C T CONTAINS THE COMPUTED EIGENVALUE OF A+TI (IF IERR IS ZERO).
1292	C
1293	C R CONTAINS THE MAXIMUM OF ITS INPUT VALUE AND THE NORM OF THE
1294	C LAST COLUMN OF THE INPUT MATRIX A.
1295	C
1296	C IERR IS SET TO
1297	C ZERO FOR NORMAL RETURN,
1298	C N IF THE EIGENVALUE HAS NOT BEEN
1299	C DETERMINED AFTER 30 ITERATIONS.
1300	C
1301	C RV IS A TEMPORARY STORAGE ARRAY OF DIMENSION AT LEAST
1302	C (2MB2+4MB-3). THE FIRST (3*MB-2) LOCATIONS CORRESPOND
1303	C TO THE ALGOL ARRAY B, THE NEXT (2*MB-1) LOCATIONS CORRESPOND
1304	C TO THE ALGOL ARRAY H, AND THE FINAL (2MB*2-MB) LOCATIONS
1305	C CORRESPOND TO THE MB BY (2*MB-1) ALGOL ARRAY U.
1306	C
1307	C NOTE. FOR A SUBSEQUENT CALL, N SHOULD BE REPLACED BY N-1, BUT
1308	C MB SHOULD NOT BE ALTERED EVEN WHEN IT EXCEEDS THE CURRENT N.
1309	C
1310	C CALLS PYTHAG FOR DSQRT(AA + BB) .
1311	C
1312	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
1313	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
1314	C
1315	C THIS VERSION DATED AUGUST 1983.
1316	C
1317	C ------------------------------------------------------------------
1318	C
1319	IERR = 0
1320	M1 = MIN0(MB,N)
1321	M = M1 - 1
1322	M2 = M + M
1323	M21 = M2 + 1
1324	M3 = M21 + M
1325	M31 = M3 + 1
1326	M4 = M31 + M2
1327	MN = M + N
1328	MZ = MB - M1
1329	ITS = 0
1330	C .......... TEST FOR CONVERGENCE ..........
1331	40 G = A(N,MB)
1332	IF (M .EQ. 0) GO TO 360
1333	F = 0.0D0
1334	C
1335	DO 50 K = 1, M
1336	MK = K + MZ
1337	F = F + DABS(A(N,MK))
1338	50 CONTINUE
1339	C
1340	IF (ITS .EQ. 0 .AND. F .GT. R) R = F
1341	TST1 = R
1342	TST2 = TST1 + F
1343	IF (TST2 .LE. TST1) GO TO 360
1344	IF (ITS .EQ. 30) GO TO 1000
1345	ITS = ITS + 1
1346	C .......... FORM SHIFT FROM BOTTOM 2 BY 2 MINOR ..........
1347	IF (F .GT. 0.25D0 * R .AND. ITS .LT. 5) GO TO 90
1348	F = A(N,MB-1)
1349	IF (F .EQ. 0.0D0) GO TO 70
1350	Q = (A(N-1,MB) - G) / (2.0D0 * F)
1351	S = PYTHAG(Q,1.0D0)
1352	G = G - F / (Q + DSIGN(S,Q))
1353	70 T = T + G
1354	C
1355	DO 80 I = 1, N
1356	80 A(I,MB) = A(I,MB) - G
1357	C
1358	90 DO 100 K = M31, M4
1359	100 RV(K) = 0.0D0
1360	C
1361	DO 350 II = 1, MN
1362	I = II - M
1363	NI = N - II
1364	IF (NI .LT. 0) GO TO 230
1365	C .......... FORM COLUMN OF SHIFTED MATRIX A-G*I ..........
1366	L = MAX0(1,2-I)
1367	C
1368	DO 110 K = 1, M3
1369	110 RV(K) = 0.0D0
1370	C
1371	DO 120 K = L, M1
1372	KM = K + M
1373	MK = K + MZ
1374	RV(KM) = A(II,MK)
1375	120 CONTINUE
1376	C
1377	LL = MIN0(M,NI)
1378	IF (LL .EQ. 0) GO TO 135
1379	C
1380	DO 130 K = 1, LL
1381	KM = K + M21
1382	IK = II + K
1383	MK = MB - K
1384	RV(KM) = A(IK,MK)
1385	130 CONTINUE
1386	C .......... PRE-MULTIPLY WITH HOUSEHOLDER REFLECTIONS ..........
1387	135 LL = M2
1388	IMULT = 0
1389	C .......... MULTIPLICATION PROCEDURE ..........
1390	140 KJ = M4 - M1
1391	C
1392	DO 170 J = 1, LL
1393	KJ = KJ + M1
1394	JM = J + M3
1395	IF (RV(JM) .EQ. 0.0D0) GO TO 170
1396	F = 0.0D0
1397	C
1398	DO 150 K = 1, M1
1399	KJ = KJ + 1
1400	JK = J + K - 1
1401	F = F + RV(KJ) * RV(JK)
1402	150 CONTINUE
1403	C
1404	F = F / RV(JM)
1405	KJ = KJ - M1
1406	C
1407	DO 160 K = 1, M1
1408	KJ = KJ + 1
1409	JK = J + K - 1
1410	RV(JK) = RV(JK) - RV(KJ) * F
1411	160 CONTINUE
1412	C
1413	KJ = KJ - M1
1414	170 CONTINUE
1415	C
1416	IF (IMULT .NE. 0) GO TO 280
1417	C .......... HOUSEHOLDER REFLECTION ..........
1418	F = RV(M21)
1419	S = 0.0D0
1420	RV(M4) = 0.0D0
1421	SCALE = 0.0D0
1422	C
1423	DO 180 K = M21, M3
1424	180 SCALE = SCALE + DABS(RV(K))
1425	C
1426	IF (SCALE .EQ. 0.0D0) GO TO 210
1427	C
1428	DO 190 K = M21, M3
1429	190 S = S + (RV(K)/SCALE)**2
1430	C
1431	S = SCALE * SCALE * S
1432	G = -DSIGN(DSQRT(S),F)
1433	RV(M21) = G
1434	RV(M4) = S - F * G
1435	KJ = M4 + M2 * M1 + 1
1436	RV(KJ) = F - G
1437	C
1438	DO 200 K = 2, M1
1439	KJ = KJ + 1
1440	KM = K + M2
1441	RV(KJ) = RV(KM)
1442	200 CONTINUE
1443	C .......... SAVE COLUMN OF TRIANGULAR FACTOR R ..........
1444	210 DO 220 K = L, M1
1445	KM = K + M
1446	MK = K + MZ
1447	A(II,MK) = RV(KM)
1448	220 CONTINUE
1449	C
1450	230 L = MAX0(1,M1+1-I)
1451	IF (I .LE. 0) GO TO 300
1452	C .......... PERFORM ADDITIONAL STEPS ..........
1453	DO 240 K = 1, M21
1454	240 RV(K) = 0.0D0
1455	C
1456	LL = MIN0(M1,NI+M1)
1457	C .......... GET ROW OF TRIANGULAR FACTOR R ..........
1458	DO 250 KK = 1, LL
1459	K = KK - 1
1460	KM = K + M1
1461	IK = I + K
1462	MK = MB - K
1463	RV(KM) = A(IK,MK)
1464	250 CONTINUE
1465	C .......... POST-MULTIPLY WITH HOUSEHOLDER REFLECTIONS ..........
1466	LL = M1
1467	IMULT = 1
1468	GO TO 140
1469	C .......... STORE COLUMN OF NEW A MATRIX ..........
1470	280 DO 290 K = L, M1
1471	MK = K + MZ
1472	A(I,MK) = RV(K)
1473	290 CONTINUE
1474	C .......... UPDATE HOUSEHOLDER REFLECTIONS ..........
1475	300 IF (L .GT. 1) L = L - 1
1476	KJ1 = M4 + L * M1
1477	C
1478	DO 320 J = L, M2
1479	JM = J + M3
1480	RV(JM) = RV(JM+1)
1481	C
1482	DO 320 K = 1, M1
1483	KJ1 = KJ1 + 1
1484	KJ = KJ1 - M1
1485	RV(KJ) = RV(KJ1)
1486	320 CONTINUE
1487	C
1488	350 CONTINUE
1489	C
1490	GO TO 40
1491	C .......... CONVERGENCE ..........
1492	360 T = T + G
1493	C
1494	DO 380 I = 1, N
1495	380 A(I,MB) = A(I,MB) - G
1496	C
1497	DO 400 K = 1, M1
1498	MK = K + MZ
1499	A(N,MK) = 0.0D0
1500	400 CONTINUE
1501	C
1502	GO TO 1001
1503	C .......... SET ERROR -- NO CONVERGENCE TO
1504	C EIGENVALUE AFTER 30 ITERATIONS ..........
1505	1000 IERR = N
1506	1001 RETURN
1507	END
1508	SUBROUTINE CBABK2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
1509	C
1510	INTEGER I,J,K,M,N,II,NM,IGH,LOW
1511	DOUBLE PRECISION SCALE(N),ZR(NM,M),ZI(NM,M)
1512	DOUBLE PRECISION S
1513	C
1514	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
1515	C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
1516	C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
1517	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
1518	C
1519	C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
1520	C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
1521	C BALANCED MATRIX DETERMINED BY CBAL.
1522	C
1523	C ON INPUT
1524	C
1525	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
1526	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
1527	C DIMENSION STATEMENT.
1528	C
1529	C N IS THE ORDER OF THE MATRIX.
1530	C
1531	C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
1532	C
1533	C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
1534	C AND SCALING FACTORS USED BY CBAL.
1535	C
1536	C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
1537	C
1538	C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
1539	C RESPECTIVELY, OF THE EIGENVECTORS TO BE
1540	C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
1541	C
1542	C ON OUTPUT
1543	C
1544	C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
1545	C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
1546	C IN THEIR FIRST M COLUMNS.
1547	C
1548	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
1549	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
1550	C
1551	C THIS VERSION DATED AUGUST 1983.
1552	C
1553	C ------------------------------------------------------------------
1554	C
1555	IF (M .EQ. 0) GO TO 200
1556	IF (IGH .EQ. LOW) GO TO 120
1557	C
1558	DO 110 I = LOW, IGH
1559	S = SCALE(I)
1560	C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
1561	C IF THE FOREGOING STATEMENT IS REPLACED BY
1562	C S=1.0D0/SCALE(I). ..........
1563	DO 100 J = 1, M
1564	ZR(I,J) = ZR(I,J) * S
1565	ZI(I,J) = ZI(I,J) * S
1566	100 CONTINUE
1567	C
1568	110 CONTINUE
1569	C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
1570	C IGH+1 STEP 1 UNTIL N DO -- ..........
1571	120 DO 140 II = 1, N
1572	I = II
1573	IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140
1574	IF (I .LT. LOW) I = LOW - II
1575	K = SCALE(I)
1576	IF (K .EQ. I) GO TO 140
1577	C
1578	DO 130 J = 1, M
1579	S = ZR(I,J)
1580	ZR(I,J) = ZR(K,J)
1581	ZR(K,J) = S
1582	S = ZI(I,J)
1583	ZI(I,J) = ZI(K,J)
1584	ZI(K,J) = S
1585	130 CONTINUE
1586	C
1587	140 CONTINUE
1588	C
1589	200 RETURN
1590	END
1591	SUBROUTINE CBAL(NM,N,AR,AI,LOW,IGH,SCALE)
1592	C
1593	INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
1594	DOUBLE PRECISION AR(NM,N),AI(NM,N),SCALE(N)
1595	DOUBLE PRECISION C,F,G,R,S,B2,RADIX
1596	LOGICAL NOCONV
1597	C
1598	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
1599	C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
1600	C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
1601	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
1602	C
1603	C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
1604	C EIGENVALUES WHENEVER POSSIBLE.
1605	C
1606	C ON INPUT
1607	C
1608	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
1609	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
1610	C DIMENSION STATEMENT.
1611	C
1612	C N IS THE ORDER OF THE MATRIX.
1613	C
1614	C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
1615	C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
1616	C
1617	C ON OUTPUT
1618	C
1619	C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
1620	C RESPECTIVELY, OF THE BALANCED MATRIX.
1621	C
1622	C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
1623	C ARE EQUAL TO ZERO IF
1624	C (1) I IS GREATER THAN J AND
1625	C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
1626	C
1627	C SCALE CONTAINS INFORMATION DETERMINING THE
1628	C PERMUTATIONS AND SCALING FACTORS USED.
1629	C
1630	C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
1631	C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
1632	C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
1633	C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
1634	C SCALE(J) = P(J), FOR J = 1,...,LOW-1
1635	C = D(J,J) J = LOW,...,IGH
1636	C = P(J) J = IGH+1,...,N.
1637	C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
1638	C THEN 1 TO LOW-1.
1639	C
1640	C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
1641	C
1642	C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
1643	C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
1644	C K,L HAVE BEEN REVERSED.)
1645	C
1646	C ARITHMETIC IS REAL THROUGHOUT.
1647	C
1648	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
1649	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
1650	C
1651	C THIS VERSION DATED AUGUST 1983.
1652	C
1653	C ------------------------------------------------------------------
1654	C
1655	RADIX = 16.0D0
1656	C
1657	B2 = RADIX * RADIX
1658	K = 1
1659	L = N
1660	GO TO 100
1661	C .......... IN-LINE PROCEDURE FOR ROW AND
1662	C COLUMN EXCHANGE ..........
1663	20 SCALE(M) = J
1664	IF (J .EQ. M) GO TO 50
1665	C
1666	DO 30 I = 1, L
1667	F = AR(I,J)
1668	AR(I,J) = AR(I,M)
1669	AR(I,M) = F
1670	F = AI(I,J)
1671	AI(I,J) = AI(I,M)
1672	AI(I,M) = F
1673	30 CONTINUE
1674	C
1675	DO 40 I = K, N
1676	F = AR(J,I)
1677	AR(J,I) = AR(M,I)
1678	AR(M,I) = F
1679	F = AI(J,I)
1680	AI(J,I) = AI(M,I)
1681	AI(M,I) = F
1682	40 CONTINUE
1683	C
1684	50 GO TO (80,130), IEXC
1685	C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
1686	C AND PUSH THEM DOWN ..........
1687	80 IF (L .EQ. 1) GO TO 280
1688	L = L - 1
1689	C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
1690	100 DO 120 JJ = 1, L
1691	J = L + 1 - JJ
1692	C
1693	DO 110 I = 1, L
1694	IF (I .EQ. J) GO TO 110
1695	IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GO TO 120
1696	110 CONTINUE
1697	C
1698	M = L
1699	IEXC = 1
1700	GO TO 20
1701	120 CONTINUE
1702	C
1703	GO TO 140
1704	C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
1705	C AND PUSH THEM LEFT ..........
1706	130 K = K + 1
1707	C
1708	140 DO 170 J = K, L
1709	C
1710	DO 150 I = K, L
1711	IF (I .EQ. J) GO TO 150
1712	IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GO TO 170
1713	150 CONTINUE
1714	C
1715	M = K
1716	IEXC = 2
1717	GO TO 20
1718	170 CONTINUE
1719	C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
1720	DO 180 I = K, L
1721	180 SCALE(I) = 1.0D0
1722	C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
1723	190 NOCONV = .FALSE.
1724	C
1725	DO 270 I = K, L
1726	C = 0.0D0
1727	R = 0.0D0
1728	C
1729	DO 200 J = K, L
1730	IF (J .EQ. I) GO TO 200
1731	C = C + DABS(AR(J,I)) + DABS(AI(J,I))
1732	R = R + DABS(AR(I,J)) + DABS(AI(I,J))
1733	200 CONTINUE
1734	C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
1735	IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GO TO 270
1736	G = R / RADIX
1737	F = 1.0D0
1738	S = C + R
1739	210 IF (C .GE. G) GO TO 220
1740	F = F * RADIX
1741	C = C * B2
1742	GO TO 210
1743	220 G = R * RADIX
1744	230 IF (C .LT. G) GO TO 240
1745	F = F / RADIX
1746	C = C / B2
1747	GO TO 230
1748	C .......... NOW BALANCE ..........
1749	240 IF ((C + R) / F .GE. 0.95D0 * S) GO TO 270
1750	G = 1.0D0 / F
1751	SCALE(I) = SCALE(I) * F
1752	NOCONV = .TRUE.
1753	C
1754	DO 250 J = K, N
1755	AR(I,J) = AR(I,J) * G
1756	AI(I,J) = AI(I,J) * G
1757	250 CONTINUE
1758	C
1759	DO 260 J = 1, L
1760	AR(J,I) = AR(J,I) * F
1761	AI(J,I) = AI(J,I) * F
1762	260 CONTINUE
1763	C
1764	270 CONTINUE
1765	C
1766	IF (NOCONV) GO TO 190
1767	C
1768	280 LOW = K
1769	IGH = L
1770	RETURN
1771	END
1772	SUBROUTINE CG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
1773	C
1774	INTEGER N,NM,IS1,IS2,IERR,MATZ
1775	DOUBLE PRECISION AR(NM,N),AI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N),
1776	X FV1(N),FV2(N),FV3(N)
1777	C
1778	C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
1779	C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
1780	C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
1781	C OF A COMPLEX GENERAL MATRIX.
1782	C
1783	C ON INPUT
1784	C
1785	C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
1786	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
1787	C DIMENSION STATEMENT.
1788	C
1789	C N IS THE ORDER OF THE MATRIX A=(AR,AI).
1790	C
1791	C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
1792	C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
1793	C
1794	C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
1795	C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
1796	C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
1797	C
1798	C ON OUTPUT
1799	C
1800	C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
1801	C RESPECTIVELY, OF THE EIGENVALUES.
1802	C
1803	C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
1804	C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
1805	C
1806	C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
1807	C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
1808	C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
1809	C
1810	C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
1811	C
1812	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
1813	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
1814	C
1815	C THIS VERSION DATED AUGUST 1983.
1816	C
1817	C ------------------------------------------------------------------
1818	C
1819	IF (N .LE. NM) GO TO 10
1820	IERR = 10 * N
1821	GO TO 50
1822	C
1823	10 CALL CBAL(NM,N,AR,AI,IS1,IS2,FV1)
1824	CALL CORTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
1825	IF (MATZ .NE. 0) GO TO 20
1826	C .......... FIND EIGENVALUES ONLY ..........
1827	CALL COMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
1828	GO TO 50
1829	C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
1830	20 CALL COMQR2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
1831	IF (IERR .NE. 0) GO TO 50
1832	CALL CBABK2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
1833	50 RETURN
1834	END
1835	SUBROUTINE CH(NM,N,AR,AI,W,MATZ,ZR,ZI,FV1,FV2,FM1,IERR)
1836	C
1837	INTEGER I,J,N,NM,IERR,MATZ
1838	DOUBLE PRECISION AR(NM,N),AI(NM,N),W(N),ZR(NM,N),ZI(NM,N),
1839	X FV1(N),FV2(N),FM1(2,N)
1840	C
1841	C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
1842	C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
1843	C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
1844	C OF A COMPLEX HERMITIAN MATRIX.
1845	C
1846	C ON INPUT
1847	C
1848	C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
1849	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
1850	C DIMENSION STATEMENT.
1851	C
1852	C N IS THE ORDER OF THE MATRIX A=(AR,AI).
1853	C
1854	C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
1855	C RESPECTIVELY, OF THE COMPLEX HERMITIAN MATRIX.
1856	C
1857	C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
1858	C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
1859	C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
1860	C
1861	C ON OUTPUT
1862	C
1863	C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER.
1864	C
1865	C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
1866	C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
1867	C
1868	C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
1869	C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT
1870	C AND TQL2. THE NORMAL COMPLETION CODE IS ZERO.
1871	C
1872	C FV1, FV2, AND FM1 ARE TEMPORARY STORAGE ARRAYS.
1873	C
1874	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
1875	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
1876	C
1877	C THIS VERSION DATED AUGUST 1983.
1878	C
1879	C ------------------------------------------------------------------
1880	C
1881	IF (N .LE. NM) GO TO 10
1882	IERR = 10 * N
1883	GO TO 50
1884	C
1885	10 CALL HTRIDI(NM,N,AR,AI,W,FV1,FV2,FM1)
1886	IF (MATZ .NE. 0) GO TO 20
1887	C .......... FIND EIGENVALUES ONLY ..........
1888	CALL TQLRAT(N,W,FV2,IERR)
1889	GO TO 50
1890	C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
1891	20 DO 40 I = 1, N
1892	C
1893	DO 30 J = 1, N
1894	ZR(J,I) = 0.0D0
1895	30 CONTINUE
1896	C
1897	ZR(I,I) = 1.0D0
1898	40 CONTINUE
1899	C
1900	CALL TQL2(NM,N,W,FV1,ZR,IERR)
1901	IF (IERR .NE. 0) GO TO 50
1902	CALL HTRIBK(NM,N,AR,AI,FM1,N,ZR,ZI)
1903	50 RETURN
1904	END
1905	SUBROUTINE CINVIT(NM,N,AR,AI,WR,WI,SELECT,MM,M,ZR,ZI,
1906	X IERR,RM1,RM2,RV1,RV2)
1907	C
1908	INTEGER I,J,K,M,N,S,II,MM,MP,NM,UK,IP1,ITS,KM1,IERR
1909	DOUBLE PRECISION AR(NM,N),AI(NM,N),WR(N),WI(N),ZR(NM,MM),
1910	X ZI(NM,MM),RM1(N,N),RM2(N,N),RV1(N),RV2(N)
1911	DOUBLE PRECISION X,Y,EPS3,NORM,NORMV,EPSLON,GROWTO,ILAMBD,PYTHAG,
1912	X RLAMBD,UKROOT
1913	LOGICAL SELECT(N)
1914	C
1915	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE CX INVIT
1916	C BY PETERS AND WILKINSON.
1917	C HANDBOOK FOR AUTO. COMP. VOL.II-LINEAR ALGEBRA, 418-439(1971).
1918	C
1919	C THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A COMPLEX UPPER
1920	C HESSENBERG MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES,
1921	C USING INVERSE ITERATION.
1922	C
1923	C ON INPUT
1924	C
1925	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
1926	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
1927	C DIMENSION STATEMENT.
1928	C
1929	C N IS THE ORDER OF THE MATRIX.
1930	C
1931	C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
1932	C RESPECTIVELY, OF THE HESSENBERG MATRIX.
1933	C
1934	C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, RESPECTIVELY,
1935	C OF THE EIGENVALUES OF THE MATRIX. THE EIGENVALUES MUST BE
1936	C STORED IN A MANNER IDENTICAL TO THAT OF SUBROUTINE COMLR,
1937	C WHICH RECOGNIZES POSSIBLE SPLITTING OF THE MATRIX.
1938	C
1939	C SELECT SPECIFIES THE EIGENVECTORS TO BE FOUND. THE
1940	C EIGENVECTOR CORRESPONDING TO THE J-TH EIGENVALUE IS
1941	C SPECIFIED BY SETTING SELECT(J) TO .TRUE..
1942	C
1943	C MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF
1944	C EIGENVECTORS TO BE FOUND.
1945	C
1946	C ON OUTPUT
1947	C
1948	C AR, AI, WI, AND SELECT ARE UNALTERED.
1949	C
1950	C WR MAY HAVE BEEN ALTERED SINCE CLOSE EIGENVALUES ARE PERTURBED
1951	C SLIGHTLY IN SEARCHING FOR INDEPENDENT EIGENVECTORS.
1952	C
1953	C M IS THE NUMBER OF EIGENVECTORS ACTUALLY FOUND.
1954	C
1955	C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, RESPECTIVELY,
1956	C OF THE EIGENVECTORS. THE EIGENVECTORS ARE NORMALIZED
1957	C SO THAT THE COMPONENT OF LARGEST MAGNITUDE IS 1.
1958	C ANY VECTOR WHICH FAILS THE ACCEPTANCE TEST IS SET TO ZERO.
1959	C
1960	C IERR IS SET TO
1961	C ZERO FOR NORMAL RETURN,
1962	C -(2*N+1) IF MORE THAN MM EIGENVECTORS HAVE BEEN SPECIFIED,
1963	C -K IF THE ITERATION CORRESPONDING TO THE K-TH
1964	C VALUE FAILS,
1965	C -(N+K) IF BOTH ERROR SITUATIONS OCCUR.
1966	C
1967	C RM1, RM2, RV1, AND RV2 ARE TEMPORARY STORAGE ARRAYS.
1968	C
1969	C THE ALGOL PROCEDURE GUESSVEC APPEARS IN CINVIT IN LINE.
1970	C
1971	C CALLS CDIV FOR COMPLEX DIVISION.
1972	C CALLS PYTHAG FOR DSQRT(AA + BB) .
1973	C
1974	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
1975	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
1976	C
1977	C THIS VERSION DATED AUGUST 1983.
1978	C
1979	C ------------------------------------------------------------------
1980	C
1981	IERR = 0
1982	UK = 0
1983	S = 1
1984	C
1985	DO 980 K = 1, N
1986	IF (.NOT. SELECT(K)) GO TO 980
1987	IF (S .GT. MM) GO TO 1000
1988	IF (UK .GE. K) GO TO 200
1989	C .......... CHECK FOR POSSIBLE SPLITTING ..........
1990	DO 120 UK = K, N
1991	IF (UK .EQ. N) GO TO 140
1992	IF (AR(UK+1,UK) .EQ. 0.0D0 .AND. AI(UK+1,UK) .EQ. 0.0D0)
1993	X GO TO 140
1994	120 CONTINUE
1995	C .......... COMPUTE INFINITY NORM OF LEADING UK BY UK
1996	C (HESSENBERG) MATRIX ..........
1997	140 NORM = 0.0D0
1998	MP = 1
1999	C
2000	DO 180 I = 1, UK
2001	X = 0.0D0
2002	C
2003	DO 160 J = MP, UK
2004	160 X = X + PYTHAG(AR(I,J),AI(I,J))
2005	C
2006	IF (X .GT. NORM) NORM = X
2007	MP = I
2008	180 CONTINUE
2009	C .......... EPS3 REPLACES ZERO PIVOT IN DECOMPOSITION
2010	C AND CLOSE ROOTS ARE MODIFIED BY EPS3 ..........
2011	IF (NORM .EQ. 0.0D0) NORM = 1.0D0
2012	EPS3 = EPSLON(NORM)
2013	C .......... GROWTO IS THE CRITERION FOR GROWTH ..........
2014	UKROOT = UK
2015	UKROOT = DSQRT(UKROOT)
2016	GROWTO = 0.1D0 / UKROOT
2017	200 RLAMBD = WR(K)
2018	ILAMBD = WI(K)
2019	IF (K .EQ. 1) GO TO 280
2020	KM1 = K - 1
2021	GO TO 240
2022	C .......... PERTURB EIGENVALUE IF IT IS CLOSE
2023	C TO ANY PREVIOUS EIGENVALUE ..........
2024	220 RLAMBD = RLAMBD + EPS3
2025	C .......... FOR I=K-1 STEP -1 UNTIL 1 DO -- ..........
2026	240 DO 260 II = 1, KM1
2027	I = K - II
2028	IF (SELECT(I) .AND. DABS(WR(I)-RLAMBD) .LT. EPS3 .AND.
2029	X DABS(WI(I)-ILAMBD) .LT. EPS3) GO TO 220
2030	260 CONTINUE
2031	C
2032	WR(K) = RLAMBD
2033	C .......... FORM UPPER HESSENBERG (AR,AI)-(RLAMBD,ILAMBD)*I
2034	C AND INITIAL COMPLEX VECTOR ..........
2035	280 MP = 1
2036	C
2037	DO 320 I = 1, UK
2038	C
2039	DO 300 J = MP, UK
2040	RM1(I,J) = AR(I,J)
2041	RM2(I,J) = AI(I,J)
2042	300 CONTINUE
2043	C
2044	RM1(I,I) = RM1(I,I) - RLAMBD
2045	RM2(I,I) = RM2(I,I) - ILAMBD
2046	MP = I
2047	RV1(I) = EPS3
2048	320 CONTINUE
2049	C .......... TRIANGULAR DECOMPOSITION WITH INTERCHANGES,
2050	C REPLACING ZERO PIVOTS BY EPS3 ..........
2051	IF (UK .EQ. 1) GO TO 420
2052	C
2053	DO 400 I = 2, UK
2054	MP = I - 1
2055	IF (PYTHAG(RM1(I,MP),RM2(I,MP)) .LE.
2056	X PYTHAG(RM1(MP,MP),RM2(MP,MP))) GO TO 360
2057	C
2058	DO 340 J = MP, UK
2059	Y = RM1(I,J)
2060	RM1(I,J) = RM1(MP,J)
2061	RM1(MP,J) = Y
2062	Y = RM2(I,J)
2063	RM2(I,J) = RM2(MP,J)
2064	RM2(MP,J) = Y
2065	340 CONTINUE
2066	C
2067	360 IF (RM1(MP,MP) .EQ. 0.0D0 .AND. RM2(MP,MP) .EQ. 0.0D0)
2068	X RM1(MP,MP) = EPS3
2069	CALL CDIV(RM1(I,MP),RM2(I,MP),RM1(MP,MP),RM2(MP,MP),X,Y)
2070	IF (X .EQ. 0.0D0 .AND. Y .EQ. 0.0D0) GO TO 400
2071	C
2072	DO 380 J = I, UK
2073	RM1(I,J) = RM1(I,J) - X * RM1(MP,J) + Y * RM2(MP,J)
2074	RM2(I,J) = RM2(I,J) - X * RM2(MP,J) - Y * RM1(MP,J)
2075	380 CONTINUE
2076	C
2077	400 CONTINUE
2078	C
2079	420 IF (RM1(UK,UK) .EQ. 0.0D0 .AND. RM2(UK,UK) .EQ. 0.0D0)
2080	X RM1(UK,UK) = EPS3
2081	ITS = 0
2082	C .......... BACK SUBSTITUTION
2083	C FOR I=UK STEP -1 UNTIL 1 DO -- ..........
2084	660 DO 720 II = 1, UK
2085	I = UK + 1 - II
2086	X = RV1(I)
2087	Y = 0.0D0
2088	IF (I .EQ. UK) GO TO 700
2089	IP1 = I + 1
2090	C
2091	DO 680 J = IP1, UK
2092	X = X - RM1(I,J) * RV1(J) + RM2(I,J) * RV2(J)
2093	Y = Y - RM1(I,J) * RV2(J) - RM2(I,J) * RV1(J)
2094	680 CONTINUE
2095	C
2096	700 CALL CDIV(X,Y,RM1(I,I),RM2(I,I),RV1(I),RV2(I))
2097	720 CONTINUE
2098	C .......... ACCEPTANCE TEST FOR EIGENVECTOR
2099	C AND NORMALIZATION ..........
2100	ITS = ITS + 1
2101	NORM = 0.0D0
2102	NORMV = 0.0D0
2103	C
2104	DO 780 I = 1, UK
2105	X = PYTHAG(RV1(I),RV2(I))
2106	IF (NORMV .GE. X) GO TO 760
2107	NORMV = X
2108	J = I
2109	760 NORM = NORM + X
2110	780 CONTINUE
2111	C
2112	IF (NORM .LT. GROWTO) GO TO 840
2113	C .......... ACCEPT VECTOR ..........
2114	X = RV1(J)
2115	Y = RV2(J)
2116	C
2117	DO 820 I = 1, UK
2118	CALL CDIV(RV1(I),RV2(I),X,Y,ZR(I,S),ZI(I,S))
2119	820 CONTINUE
2120	C
2121	IF (UK .EQ. N) GO TO 940
2122	J = UK + 1
2123	GO TO 900
2124	C .......... IN-LINE PROCEDURE FOR CHOOSING
2125	C A NEW STARTING VECTOR ..........
2126	840 IF (ITS .GE. UK) GO TO 880
2127	X = UKROOT
2128	Y = EPS3 / (X + 1.0D0)
2129	RV1(1) = EPS3
2130	C
2131	DO 860 I = 2, UK
2132	860 RV1(I) = Y
2133	C
2134	J = UK - ITS + 1
2135	RV1(J) = RV1(J) - EPS3 * X
2136	GO TO 660
2137	C .......... SET ERROR -- UNACCEPTED EIGENVECTOR ..........
2138	880 J = 1
2139	IERR = -K
2140	C .......... SET REMAINING VECTOR COMPONENTS TO ZERO ..........
2141	900 DO 920 I = J, N
2142	ZR(I,S) = 0.0D0
2143	ZI(I,S) = 0.0D0
2144	920 CONTINUE
2145	C
2146	940 S = S + 1
2147	980 CONTINUE
2148	C
2149	GO TO 1001
2150	C .......... SET ERROR -- UNDERESTIMATE OF EIGENVECTOR
2151	C SPACE REQUIRED ..........
2152	1000 IF (IERR .NE. 0) IERR = IERR - N
2153	IF (IERR .EQ. 0) IERR = -(2 * N + 1)
2154	1001 M = S - 1
2155	RETURN
2156	END
2157	SUBROUTINE COMBAK(NM,LOW,IGH,AR,AI,INT,M,ZR,ZI)
2158	C
2159	INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1
2160	DOUBLE PRECISION AR(NM,IGH),AI(NM,IGH),ZR(NM,M),ZI(NM,M)
2161	DOUBLE PRECISION XR,XI
2162	INTEGER INT(IGH)
2163	C
2164	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMBAK,
2165	C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON.
2166	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
2167	C
2168	C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
2169	C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
2170	C UPPER HESSENBERG MATRIX DETERMINED BY COMHES.
2171	C
2172	C ON INPUT
2173	C
2174	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
2175	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
2176	C DIMENSION STATEMENT.
2177	C
2178	C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
2179	C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
2180	C SET LOW=1 AND IGH EQUAL TO THE ORDER OF THE MATRIX.
2181	C
2182	C AR AND AI CONTAIN THE MULTIPLIERS WHICH WERE USED IN THE
2183	C REDUCTION BY COMHES IN THEIR LOWER TRIANGLES
2184	C BELOW THE SUBDIAGONAL.
2185	C
2186	C INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS
2187	C INTERCHANGED IN THE REDUCTION BY COMHES.
2188	C ONLY ELEMENTS LOW THROUGH IGH ARE USED.
2189	C
2190	C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
2191	C
2192	C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
2193	C RESPECTIVELY, OF THE EIGENVECTORS TO BE
2194	C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
2195	C
2196	C ON OUTPUT
2197	C
2198	C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
2199	C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
2200	C IN THEIR FIRST M COLUMNS.
2201	C
2202	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
2203	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
2204	C
2205	C THIS VERSION DATED AUGUST 1983.
2206	C
2207	C ------------------------------------------------------------------
2208	C
2209	IF (M .EQ. 0) GO TO 200
2210	LA = IGH - 1
2211	KP1 = LOW + 1
2212	IF (LA .LT. KP1) GO TO 200
2213	C .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
2214	DO 140 MM = KP1, LA
2215	MP = LOW + IGH - MM
2216	MP1 = MP + 1
2217	C
2218	DO 110 I = MP1, IGH
2219	XR = AR(I,MP-1)
2220	XI = AI(I,MP-1)
2221	IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 110
2222	C
2223	DO 100 J = 1, M
2224	ZR(I,J) = ZR(I,J) + XR * ZR(MP,J) - XI * ZI(MP,J)
2225	ZI(I,J) = ZI(I,J) + XR * ZI(MP,J) + XI * ZR(MP,J)
2226	100 CONTINUE
2227	C
2228	110 CONTINUE
2229	C
2230	I = INT(MP)
2231	IF (I .EQ. MP) GO TO 140
2232	C
2233	DO 130 J = 1, M
2234	XR = ZR(I,J)
2235	ZR(I,J) = ZR(MP,J)
2236	ZR(MP,J) = XR
2237	XI = ZI(I,J)
2238	ZI(I,J) = ZI(MP,J)
2239	ZI(MP,J) = XI
2240	130 CONTINUE
2241	C
2242	140 CONTINUE
2243	C
2244	200 RETURN
2245	END
2246	SUBROUTINE COMHES(NM,N,LOW,IGH,AR,AI,INT)
2247	C
2248	INTEGER I,J,M,N,LA,NM,IGH,KP1,LOW,MM1,MP1
2249	DOUBLE PRECISION AR(NM,N),AI(NM,N)
2250	DOUBLE PRECISION XR,XI,YR,YI
2251	INTEGER INT(IGH)
2252	C
2253	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMHES,
2254	C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON.
2255	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
2256	C
2257	C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
2258	C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
2259	C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
2260	C STABILIZED ELEMENTARY SIMILARITY TRANSFORMATIONS.
2261	C
2262	C ON INPUT
2263	C
2264	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
2265	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
2266	C DIMENSION STATEMENT.
2267	C
2268	C N IS THE ORDER OF THE MATRIX.
2269	C
2270	C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
2271	C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
2272	C SET LOW=1, IGH=N.
2273	C
2274	C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
2275	C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
2276	C
2277	C ON OUTPUT
2278	C
2279	C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
2280	C RESPECTIVELY, OF THE HESSENBERG MATRIX. THE
2281	C MULTIPLIERS WHICH WERE USED IN THE REDUCTION
2282	C ARE STORED IN THE REMAINING TRIANGLES UNDER THE
2283	C HESSENBERG MATRIX.
2284	C
2285	C INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS
2286	C INTERCHANGED IN THE REDUCTION.
2287	C ONLY ELEMENTS LOW THROUGH IGH ARE USED.
2288	C
2289	C CALLS CDIV FOR COMPLEX DIVISION.
2290	C
2291	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
2292	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
2293	C
2294	C THIS VERSION DATED AUGUST 1983.
2295	C
2296	C ------------------------------------------------------------------
2297	C
2298	LA = IGH - 1
2299	KP1 = LOW + 1
2300	IF (LA .LT. KP1) GO TO 200
2301	C
2302	DO 180 M = KP1, LA
2303	MM1 = M - 1
2304	XR = 0.0D0
2305	XI = 0.0D0
2306	I = M
2307	C
2308	DO 100 J = M, IGH
2309	IF (DABS(AR(J,MM1)) + DABS(AI(J,MM1))
2310	X .LE. DABS(XR) + DABS(XI)) GO TO 100
2311	XR = AR(J,MM1)
2312	XI = AI(J,MM1)
2313	I = J
2314	100 CONTINUE
2315	C
2316	INT(M) = I
2317	IF (I .EQ. M) GO TO 130
2318	C .......... INTERCHANGE ROWS AND COLUMNS OF AR AND AI ..........
2319	DO 110 J = MM1, N
2320	YR = AR(I,J)
2321	AR(I,J) = AR(M,J)
2322	AR(M,J) = YR
2323	YI = AI(I,J)
2324	AI(I,J) = AI(M,J)
2325	AI(M,J) = YI
2326	110 CONTINUE
2327	C
2328	DO 120 J = 1, IGH
2329	YR = AR(J,I)
2330	AR(J,I) = AR(J,M)
2331	AR(J,M) = YR
2332	YI = AI(J,I)
2333	AI(J,I) = AI(J,M)
2334	AI(J,M) = YI
2335	120 CONTINUE
2336	C .......... END INTERCHANGE ..........
2337	130 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 180
2338	MP1 = M + 1
2339	C
2340	DO 160 I = MP1, IGH
2341	YR = AR(I,MM1)
2342	YI = AI(I,MM1)
2343	IF (YR .EQ. 0.0D0 .AND. YI .EQ. 0.0D0) GO TO 160
2344	CALL CDIV(YR,YI,XR,XI,YR,YI)
2345	AR(I,MM1) = YR
2346	AI(I,MM1) = YI
2347	C
2348	DO 140 J = M, N
2349	AR(I,J) = AR(I,J) - YR * AR(M,J) + YI * AI(M,J)
2350	AI(I,J) = AI(I,J) - YR * AI(M,J) - YI * AR(M,J)
2351	140 CONTINUE
2352	C
2353	DO 150 J = 1, IGH
2354	AR(J,M) = AR(J,M) + YR * AR(J,I) - YI * AI(J,I)
2355	AI(J,M) = AI(J,M) + YR * AI(J,I) + YI * AR(J,I)
2356	150 CONTINUE
2357	C
2358	160 CONTINUE
2359	C
2360	180 CONTINUE
2361	C
2362	200 RETURN
2363	END
2364	SUBROUTINE COMLR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
2365	C
2366	INTEGER I,J,L,M,N,EN,LL,MM,NM,IGH,IM1,ITN,ITS,LOW,MP1,ENM1,IERR
2367	DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N)
2368	DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,TST1,TST2
2369	C
2370	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMLR,
2371	C NUM. MATH. 12, 369-376(1968) BY MARTIN AND WILKINSON.
2372	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
2373	C
2374	C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
2375	C UPPER HESSENBERG MATRIX BY THE MODIFIED LR METHOD.
2376	C
2377	C ON INPUT
2378	C
2379	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
2380	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
2381	C DIMENSION STATEMENT.
2382	C
2383	C N IS THE ORDER OF THE MATRIX.
2384	C
2385	C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
2386	C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
2387	C SET LOW=1, IGH=N.
2388	C
2389	C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
2390	C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
2391	C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN THE
2392	C MULTIPLIERS WHICH WERE USED IN THE REDUCTION BY COMHES,
2393	C IF PERFORMED.
2394	C
2395	C ON OUTPUT
2396	C
2397	C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
2398	C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
2399	C CALLING COMLR IF SUBSEQUENT CALCULATION OF
2400	C EIGENVECTORS IS TO BE PERFORMED.
2401	C
2402	C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
2403	C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
2404	C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
2405	C FOR INDICES IERR+1,...,N.
2406	C
2407	C IERR IS SET TO
2408	C ZERO FOR NORMAL RETURN,
2409	C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
2410	C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
2411	C
2412	C CALLS CDIV FOR COMPLEX DIVISION.
2413	C CALLS CSROOT FOR COMPLEX SQUARE ROOT.
2414	C
2415	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
2416	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
2417	C
2418	C THIS VERSION DATED AUGUST 1983.
2419	C
2420	C ------------------------------------------------------------------
2421	C
2422	IERR = 0
2423	C .......... STORE ROOTS ISOLATED BY CBAL ..........
2424	DO 200 I = 1, N
2425	IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
2426	WR(I) = HR(I,I)
2427	WI(I) = HI(I,I)
2428	200 CONTINUE
2429	C
2430	EN = IGH
2431	TR = 0.0D0
2432	TI = 0.0D0
2433	ITN = 30*N
2434	C .......... SEARCH FOR NEXT EIGENVALUE ..........
2435	220 IF (EN .LT. LOW) GO TO 1001
2436	ITS = 0
2437	ENM1 = EN - 1
2438	C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
2439	C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
2440	240 DO 260 LL = LOW, EN
2441	L = EN + LOW - LL
2442	IF (L .EQ. LOW) GO TO 300
2443	TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
2444	X + DABS(HR(L,L)) + DABS(HI(L,L))
2445	TST2 = TST1 + DABS(HR(L,L-1)) + DABS(HI(L,L-1))
2446	IF (TST2 .EQ. TST1) GO TO 300
2447	260 CONTINUE
2448	C .......... FORM SHIFT ..........
2449	300 IF (L .EQ. EN) GO TO 660
2450	IF (ITN .EQ. 0) GO TO 1000
2451	IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320
2452	SR = HR(EN,EN)
2453	SI = HI(EN,EN)
2454	XR = HR(ENM1,EN) * HR(EN,ENM1) - HI(ENM1,EN) * HI(EN,ENM1)
2455	XI = HR(ENM1,EN) * HI(EN,ENM1) + HI(ENM1,EN) * HR(EN,ENM1)
2456	IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 340
2457	YR = (HR(ENM1,ENM1) - SR) / 2.0D0
2458	YI = (HI(ENM1,ENM1) - SI) / 2.0D0
2459	CALL CSROOT(YR2-YI2+XR,2.0D0YRYI+XI,ZZR,ZZI)
2460	IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GO TO 310
2461	ZZR = -ZZR
2462	ZZI = -ZZI
2463	310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
2464	SR = SR - XR
2465	SI = SI - XI
2466	GO TO 340
2467	C .......... FORM EXCEPTIONAL SHIFT ..........
2468	320 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
2469	SI = DABS(HI(EN,ENM1)) + DABS(HI(ENM1,EN-2))
2470	C
2471	340 DO 360 I = LOW, EN
2472	HR(I,I) = HR(I,I) - SR
2473	HI(I,I) = HI(I,I) - SI
2474	360 CONTINUE
2475	C
2476	TR = TR + SR
2477	TI = TI + SI
2478	ITS = ITS + 1
2479	ITN = ITN - 1
2480	C .......... LOOK FOR TWO CONSECUTIVE SMALL
2481	C SUB-DIAGONAL ELEMENTS ..........
2482	XR = DABS(HR(ENM1,ENM1)) + DABS(HI(ENM1,ENM1))
2483	YR = DABS(HR(EN,ENM1)) + DABS(HI(EN,ENM1))
2484	ZZR = DABS(HR(EN,EN)) + DABS(HI(EN,EN))
2485	C .......... FOR M=EN-1 STEP -1 UNTIL L DO -- ..........
2486	DO 380 MM = L, ENM1
2487	M = ENM1 + L - MM
2488	IF (M .EQ. L) GO TO 420
2489	YI = YR
2490	YR = DABS(HR(M,M-1)) + DABS(HI(M,M-1))
2491	XI = ZZR
2492	ZZR = XR
2493	XR = DABS(HR(M-1,M-1)) + DABS(HI(M-1,M-1))
2494	TST1 = ZZR / YI * (ZZR + XR + XI)
2495	TST2 = TST1 + YR
2496	IF (TST2 .EQ. TST1) GO TO 420
2497	380 CONTINUE
2498	C .......... TRIANGULAR DECOMPOSITION H=L*R ..........
2499	420 MP1 = M + 1
2500	C
2501	DO 520 I = MP1, EN
2502	IM1 = I - 1
2503	XR = HR(IM1,IM1)
2504	XI = HI(IM1,IM1)
2505	YR = HR(I,IM1)
2506	YI = HI(I,IM1)
2507	IF (DABS(XR) + DABS(XI) .GE. DABS(YR) + DABS(YI)) GO TO 460
2508	C .......... INTERCHANGE ROWS OF HR AND HI ..........
2509	DO 440 J = IM1, EN
2510	ZZR = HR(IM1,J)
2511	HR(IM1,J) = HR(I,J)
2512	HR(I,J) = ZZR
2513	ZZI = HI(IM1,J)
2514	HI(IM1,J) = HI(I,J)
2515	HI(I,J) = ZZI
2516	440 CONTINUE
2517	C
2518	CALL CDIV(XR,XI,YR,YI,ZZR,ZZI)
2519	WR(I) = 1.0D0
2520	GO TO 480
2521	460 CALL CDIV(YR,YI,XR,XI,ZZR,ZZI)
2522	WR(I) = -1.0D0
2523	480 HR(I,IM1) = ZZR
2524	HI(I,IM1) = ZZI
2525	C
2526	DO 500 J = I, EN
2527	HR(I,J) = HR(I,J) - ZZR * HR(IM1,J) + ZZI * HI(IM1,J)
2528	HI(I,J) = HI(I,J) - ZZR * HI(IM1,J) - ZZI * HR(IM1,J)
2529	500 CONTINUE
2530	C
2531	520 CONTINUE
2532	C .......... COMPOSITION R*L=H ..........
2533	DO 640 J = MP1, EN
2534	XR = HR(J,J-1)
2535	XI = HI(J,J-1)
2536	HR(J,J-1) = 0.0D0
2537	HI(J,J-1) = 0.0D0
2538	C .......... INTERCHANGE COLUMNS OF HR AND HI,
2539	C IF NECESSARY ..........
2540	IF (WR(J) .LE. 0.0D0) GO TO 580
2541	C
2542	DO 540 I = L, J
2543	ZZR = HR(I,J-1)
2544	HR(I,J-1) = HR(I,J)
2545	HR(I,J) = ZZR
2546	ZZI = HI(I,J-1)
2547	HI(I,J-1) = HI(I,J)
2548	HI(I,J) = ZZI
2549	540 CONTINUE
2550	C
2551	580 DO 600 I = L, J
2552	HR(I,J-1) = HR(I,J-1) + XR * HR(I,J) - XI * HI(I,J)
2553	HI(I,J-1) = HI(I,J-1) + XR * HI(I,J) + XI * HR(I,J)
2554	600 CONTINUE
2555	C
2556	640 CONTINUE
2557	C
2558	GO TO 240
2559	C .......... A ROOT FOUND ..........
2560	660 WR(EN) = HR(EN,EN) + TR
2561	WI(EN) = HI(EN,EN) + TI
2562	EN = ENM1
2563	GO TO 220
2564	C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
2565	C CONVERGED AFTER 30*N ITERATIONS ..........
2566	1000 IERR = EN
2567	1001 RETURN
2568	END
2569	SUBROUTINE COMLR2(NM,N,LOW,IGH,INT,HR,HI,WR,WI,ZR,ZI,IERR)
2570	C
2571	INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NM,NN,IGH,IM1,IP1,
2572	X ITN,ITS,LOW,MP1,ENM1,IEND,IERR
2573	DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N)
2574	DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2
2575	INTEGER INT(IGH)
2576	C
2577	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMLR2,
2578	C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON.
2579	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
2580	C
2581	C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
2582	C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE MODIFIED LR
2583	C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
2584	C CAN ALSO BE FOUND IF COMHES HAS BEEN USED TO REDUCE
2585	C THIS GENERAL MATRIX TO HESSENBERG FORM.
2586	C
2587	C ON INPUT
2588	C
2589	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
2590	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
2591	C DIMENSION STATEMENT.
2592	C
2593	C N IS THE ORDER OF THE MATRIX.
2594	C
2595	C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
2596	C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
2597	C SET LOW=1, IGH=N.
2598	C
2599	C INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS INTERCHANGED
2600	C IN THE REDUCTION BY COMHES, IF PERFORMED. ONLY ELEMENTS
2601	C LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS OF THE HESSEN-
2602	C BERG MATRIX ARE DESIRED, SET INT(J)=J FOR THESE ELEMENTS.
2603	C
2604	C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
2605	C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
2606	C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN THE
2607	C MULTIPLIERS WHICH WERE USED IN THE REDUCTION BY COMHES,
2608	C IF PERFORMED. IF THE EIGENVECTORS OF THE HESSENBERG
2609	C MATRIX ARE DESIRED, THESE ELEMENTS MUST BE SET TO ZERO.
2610	C
2611	C ON OUTPUT
2612	C
2613	C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
2614	C DESTROYED, BUT THE LOCATION HR(1,1) CONTAINS THE NORM
2615	C OF THE TRIANGULARIZED MATRIX.
2616	C
2617	C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
2618	C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
2619	C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
2620	C FOR INDICES IERR+1,...,N.
2621	C
2622	C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
2623	C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
2624	C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
2625	C THE EIGENVECTORS HAS BEEN FOUND.
2626	C
2627	C IERR IS SET TO
2628	C ZERO FOR NORMAL RETURN,
2629	C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
2630	C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
2631	C
2632	C
2633	C CALLS CDIV FOR COMPLEX DIVISION.
2634	C CALLS CSROOT FOR COMPLEX SQUARE ROOT.
2635	C
2636	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
2637	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
2638	C
2639	C THIS VERSION DATED AUGUST 1983.
2640	C
2641	C ------------------------------------------------------------------
2642	C
2643	IERR = 0
2644	C .......... INITIALIZE EIGENVECTOR MATRIX ..........
2645	DO 100 I = 1, N
2646	C
2647	DO 100 J = 1, N
2648	ZR(I,J) = 0.0D0
2649	ZI(I,J) = 0.0D0
2650	IF (I .EQ. J) ZR(I,J) = 1.0D0
2651	100 CONTINUE
2652	C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
2653	C FROM THE INFORMATION LEFT BY COMHES ..........
2654	IEND = IGH - LOW - 1
2655	IF (IEND .LE. 0) GO TO 180
2656	C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
2657	DO 160 II = 1, IEND
2658	I = IGH - II
2659	IP1 = I + 1
2660	C
2661	DO 120 K = IP1, IGH
2662	ZR(K,I) = HR(K,I-1)
2663	ZI(K,I) = HI(K,I-1)
2664	120 CONTINUE
2665	C
2666	J = INT(I)
2667	IF (I .EQ. J) GO TO 160
2668	C
2669	DO 140 K = I, IGH
2670	ZR(I,K) = ZR(J,K)
2671	ZI(I,K) = ZI(J,K)
2672	ZR(J,K) = 0.0D0
2673	ZI(J,K) = 0.0D0
2674	140 CONTINUE
2675	C
2676	ZR(J,I) = 1.0D0
2677	160 CONTINUE
2678	C .......... STORE ROOTS ISOLATED BY CBAL ..........
2679	180 DO 200 I = 1, N
2680	IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
2681	WR(I) = HR(I,I)
2682	WI(I) = HI(I,I)
2683	200 CONTINUE
2684	C
2685	EN = IGH
2686	TR = 0.0D0
2687	TI = 0.0D0
2688	ITN = 30*N
2689	C .......... SEARCH FOR NEXT EIGENVALUE ..........
2690	220 IF (EN .LT. LOW) GO TO 680
2691	ITS = 0
2692	ENM1 = EN - 1
2693	C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
2694	C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
2695	240 DO 260 LL = LOW, EN
2696	L = EN + LOW - LL
2697	IF (L .EQ. LOW) GO TO 300
2698	TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
2699	X + DABS(HR(L,L)) + DABS(HI(L,L))
2700	TST2 = TST1 + DABS(HR(L,L-1)) + DABS(HI(L,L-1))
2701	IF (TST2 .EQ. TST1) GO TO 300
2702	260 CONTINUE
2703	C .......... FORM SHIFT ..........
2704	300 IF (L .EQ. EN) GO TO 660
2705	IF (ITN .EQ. 0) GO TO 1000
2706	IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320
2707	SR = HR(EN,EN)
2708	SI = HI(EN,EN)
2709	XR = HR(ENM1,EN) * HR(EN,ENM1) - HI(ENM1,EN) * HI(EN,ENM1)
2710	XI = HR(ENM1,EN) * HI(EN,ENM1) + HI(ENM1,EN) * HR(EN,ENM1)
2711	IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 340
2712	YR = (HR(ENM1,ENM1) - SR) / 2.0D0
2713	YI = (HI(ENM1,ENM1) - SI) / 2.0D0
2714	CALL CSROOT(YR2-YI2+XR,2.0D0YRYI+XI,ZZR,ZZI)
2715	IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GO TO 310
2716	ZZR = -ZZR
2717	ZZI = -ZZI
2718	310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
2719	SR = SR - XR
2720	SI = SI - XI
2721	GO TO 340
2722	C .......... FORM EXCEPTIONAL SHIFT ..........
2723	320 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
2724	SI = DABS(HI(EN,ENM1)) + DABS(HI(ENM1,EN-2))
2725	C
2726	340 DO 360 I = LOW, EN
2727	HR(I,I) = HR(I,I) - SR
2728	HI(I,I) = HI(I,I) - SI
2729	360 CONTINUE
2730	C
2731	TR = TR + SR
2732	TI = TI + SI
2733	ITS = ITS + 1
2734	ITN = ITN - 1
2735	C .......... LOOK FOR TWO CONSECUTIVE SMALL
2736	C SUB-DIAGONAL ELEMENTS ..........
2737	XR = DABS(HR(ENM1,ENM1)) + DABS(HI(ENM1,ENM1))
2738	YR = DABS(HR(EN,ENM1)) + DABS(HI(EN,ENM1))
2739	ZZR = DABS(HR(EN,EN)) + DABS(HI(EN,EN))
2740	C .......... FOR M=EN-1 STEP -1 UNTIL L DO -- ..........
2741	DO 380 MM = L, ENM1
2742	M = ENM1 + L - MM
2743	IF (M .EQ. L) GO TO 420
2744	YI = YR
2745	YR = DABS(HR(M,M-1)) + DABS(HI(M,M-1))
2746	XI = ZZR
2747	ZZR = XR
2748	XR = DABS(HR(M-1,M-1)) + DABS(HI(M-1,M-1))
2749	TST1 = ZZR / YI * (ZZR + XR + XI)
2750	TST2 = TST1 + YR
2751	IF (TST2 .EQ. TST1) GO TO 420
2752	380 CONTINUE
2753	C .......... TRIANGULAR DECOMPOSITION H=L*R ..........
2754	420 MP1 = M + 1
2755	C
2756	DO 520 I = MP1, EN
2757	IM1 = I - 1
2758	XR = HR(IM1,IM1)
2759	XI = HI(IM1,IM1)
2760	YR = HR(I,IM1)
2761	YI = HI(I,IM1)
2762	IF (DABS(XR) + DABS(XI) .GE. DABS(YR) + DABS(YI)) GO TO 460
2763	C .......... INTERCHANGE ROWS OF HR AND HI ..........
2764	DO 440 J = IM1, N
2765	ZZR = HR(IM1,J)
2766	HR(IM1,J) = HR(I,J)
2767	HR(I,J) = ZZR
2768	ZZI = HI(IM1,J)
2769	HI(IM1,J) = HI(I,J)
2770	HI(I,J) = ZZI
2771	440 CONTINUE
2772	C
2773	CALL CDIV(XR,XI,YR,YI,ZZR,ZZI)
2774	WR(I) = 1.0D0
2775	GO TO 480
2776	460 CALL CDIV(YR,YI,XR,XI,ZZR,ZZI)
2777	WR(I) = -1.0D0
2778	480 HR(I,IM1) = ZZR
2779	HI(I,IM1) = ZZI
2780	C
2781	DO 500 J = I, N
2782	HR(I,J) = HR(I,J) - ZZR * HR(IM1,J) + ZZI * HI(IM1,J)
2783	HI(I,J) = HI(I,J) - ZZR * HI(IM1,J) - ZZI * HR(IM1,J)
2784	500 CONTINUE
2785	C
2786	520 CONTINUE
2787	C .......... COMPOSITION R*L=H ..........
2788	DO 640 J = MP1, EN
2789	XR = HR(J,J-1)
2790	XI = HI(J,J-1)
2791	HR(J,J-1) = 0.0D0
2792	HI(J,J-1) = 0.0D0
2793	C .......... INTERCHANGE COLUMNS OF HR, HI, ZR, AND ZI,
2794	C IF NECESSARY ..........
2795	IF (WR(J) .LE. 0.0D0) GO TO 580
2796	C
2797	DO 540 I = 1, J
2798	ZZR = HR(I,J-1)
2799	HR(I,J-1) = HR(I,J)
2800	HR(I,J) = ZZR
2801	ZZI = HI(I,J-1)
2802	HI(I,J-1) = HI(I,J)
2803	HI(I,J) = ZZI
2804	540 CONTINUE
2805	C
2806	DO 560 I = LOW, IGH
2807	ZZR = ZR(I,J-1)
2808	ZR(I,J-1) = ZR(I,J)
2809	ZR(I,J) = ZZR
2810	ZZI = ZI(I,J-1)
2811	ZI(I,J-1) = ZI(I,J)
2812	ZI(I,J) = ZZI
2813	560 CONTINUE
2814	C
2815	580 DO 600 I = 1, J
2816	HR(I,J-1) = HR(I,J-1) + XR * HR(I,J) - XI * HI(I,J)
2817	HI(I,J-1) = HI(I,J-1) + XR * HI(I,J) + XI * HR(I,J)
2818	600 CONTINUE
2819	C .......... ACCUMULATE TRANSFORMATIONS ..........
2820	DO 620 I = LOW, IGH
2821	ZR(I,J-1) = ZR(I,J-1) + XR * ZR(I,J) - XI * ZI(I,J)
2822	ZI(I,J-1) = ZI(I,J-1) + XR * ZI(I,J) + XI * ZR(I,J)
2823	620 CONTINUE
2824	C
2825	640 CONTINUE
2826	C
2827	GO TO 240
2828	C .......... A ROOT FOUND ..........
2829	660 HR(EN,EN) = HR(EN,EN) + TR
2830	WR(EN) = HR(EN,EN)
2831	HI(EN,EN) = HI(EN,EN) + TI
2832	WI(EN) = HI(EN,EN)
2833	EN = ENM1
2834	GO TO 220
2835	C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
2836	C VECTORS OF UPPER TRIANGULAR FORM ..........
2837	680 NORM = 0.0D0
2838	C
2839	DO 720 I = 1, N
2840	C
2841	DO 720 J = I, N
2842	TR = DABS(HR(I,J)) + DABS(HI(I,J))
2843	IF (TR .GT. NORM) NORM = TR
2844	720 CONTINUE
2845	C
2846	HR(1,1) = NORM
2847	IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GO TO 1001
2848	C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
2849	DO 800 NN = 2, N
2850	EN = N + 2 - NN
2851	XR = WR(EN)
2852	XI = WI(EN)
2853	HR(EN,EN) = 1.0D0
2854	HI(EN,EN) = 0.0D0
2855	ENM1 = EN - 1
2856	C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
2857	DO 780 II = 1, ENM1
2858	I = EN - II
2859	ZZR = 0.0D0
2860	ZZI = 0.0D0
2861	IP1 = I + 1
2862	C
2863	DO 740 J = IP1, EN
2864	ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
2865	ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
2866	740 CONTINUE
2867	C
2868	YR = XR - WR(I)
2869	YI = XI - WI(I)
2870	IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GO TO 765
2871	TST1 = NORM
2872	YR = TST1
2873	760 YR = 0.01D0 * YR
2874	TST2 = NORM + YR
2875	IF (TST2 .GT. TST1) GO TO 760
2876	765 CONTINUE
2877	CALL CDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
2878	C .......... OVERFLOW CONTROL ..........
2879	TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
2880	IF (TR .EQ. 0.0D0) GO TO 780
2881	TST1 = TR
2882	TST2 = TST1 + 1.0D0/TST1
2883	IF (TST2 .GT. TST1) GO TO 780
2884	DO 770 J = I, EN
2885	HR(J,EN) = HR(J,EN)/TR
2886	HI(J,EN) = HI(J,EN)/TR
2887	770 CONTINUE
2888	C
2889	780 CONTINUE
2890	C
2891	800 CONTINUE
2892	C .......... END BACKSUBSTITUTION ..........
2893	ENM1 = N - 1
2894	C .......... VECTORS OF ISOLATED ROOTS ..........
2895	DO 840 I = 1, ENM1
2896	IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840
2897	IP1 = I + 1
2898	C
2899	DO 820 J = IP1, N
2900	ZR(I,J) = HR(I,J)
2901	ZI(I,J) = HI(I,J)
2902	820 CONTINUE
2903	C
2904	840 CONTINUE
2905	C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
2906	C VECTORS OF ORIGINAL FULL MATRIX.
2907	C FOR J=N STEP -1 UNTIL LOW+1 DO -- ..........
2908	DO 880 JJ = LOW, ENM1
2909	J = N + LOW - JJ
2910	M = MIN0(J,IGH)
2911	C
2912	DO 880 I = LOW, IGH
2913	ZZR = 0.0D0
2914	ZZI = 0.0D0
2915	C
2916	DO 860 K = LOW, M
2917	ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
2918	ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
2919	860 CONTINUE
2920	C
2921	ZR(I,J) = ZZR
2922	ZI(I,J) = ZZI
2923	880 CONTINUE
2924	C
2925	GO TO 1001
2926	C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
2927	C CONVERGED AFTER 30*N ITERATIONS ..........
2928	1000 IERR = EN
2929	1001 RETURN
2930	END
2931	SUBROUTINE COMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
2932	C
2933	INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
2934	DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N)
2935	DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
2936	X PYTHAG
2937	C
2938	C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
2939	C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
2940	C AND WILKINSON.
2941	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
2942	C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
2943	C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
2944	C
2945	C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
2946	C UPPER HESSENBERG MATRIX BY THE QR METHOD.
2947	C
2948	C ON INPUT
2949	C
2950	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
2951	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
2952	C DIMENSION STATEMENT.
2953	C
2954	C N IS THE ORDER OF THE MATRIX.
2955	C
2956	C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
2957	C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
2958	C SET LOW=1, IGH=N.
2959	C
2960	C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
2961	C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
2962	C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
2963	C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
2964	C THE REDUCTION BY CORTH, IF PERFORMED.
2965	C
2966	C ON OUTPUT
2967	C
2968	C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
2969	C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
2970	C CALLING COMQR IF SUBSEQUENT CALCULATION OF
2971	C EIGENVECTORS IS TO BE PERFORMED.
2972	C
2973	C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
2974	C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
2975	C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
2976	C FOR INDICES IERR+1,...,N.
2977	C
2978	C IERR IS SET TO
2979	C ZERO FOR NORMAL RETURN,
2980	C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
2981	C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
2982	C
2983	C CALLS CDIV FOR COMPLEX DIVISION.
2984	C CALLS CSROOT FOR COMPLEX SQUARE ROOT.
2985	C CALLS PYTHAG FOR DSQRT(AA + BB) .
2986	C
2987	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
2988	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
2989	C
2990	C THIS VERSION DATED AUGUST 1983.
2991	C
2992	C ------------------------------------------------------------------
2993	C
2994	IERR = 0
2995	IF (LOW .EQ. IGH) GO TO 180
2996	C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
2997	L = LOW + 1
2998	C
2999	DO 170 I = L, IGH
3000	LL = MIN0(I+1,IGH)
3001	IF (HI(I,I-1) .EQ. 0.0D0) GO TO 170
3002	NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
3003	YR = HR(I,I-1) / NORM
3004	YI = HI(I,I-1) / NORM
3005	HR(I,I-1) = NORM
3006	HI(I,I-1) = 0.0D0
3007	C
3008	DO 155 J = I, IGH
3009	SI = YR * HI(I,J) - YI * HR(I,J)
3010	HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
3011	HI(I,J) = SI
3012	155 CONTINUE
3013	C
3014	DO 160 J = LOW, LL
3015	SI = YR * HI(J,I) + YI * HR(J,I)
3016	HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
3017	HI(J,I) = SI
3018	160 CONTINUE
3019	C
3020	170 CONTINUE
3021	C .......... STORE ROOTS ISOLATED BY CBAL ..........
3022	180 DO 200 I = 1, N
3023	IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
3024	WR(I) = HR(I,I)
3025	WI(I) = HI(I,I)
3026	200 CONTINUE
3027	C
3028	EN = IGH
3029	TR = 0.0D0
3030	TI = 0.0D0
3031	ITN = 30*N
3032	C .......... SEARCH FOR NEXT EIGENVALUE ..........
3033	220 IF (EN .LT. LOW) GO TO 1001
3034	ITS = 0
3035	ENM1 = EN - 1
3036	C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
3037	C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
3038	240 DO 260 LL = LOW, EN
3039	L = EN + LOW - LL
3040	IF (L .EQ. LOW) GO TO 300
3041	TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
3042	X + DABS(HR(L,L)) + DABS(HI(L,L))
3043	TST2 = TST1 + DABS(HR(L,L-1))
3044	IF (TST2 .EQ. TST1) GO TO 300
3045	260 CONTINUE
3046	C .......... FORM SHIFT ..........
3047	300 IF (L .EQ. EN) GO TO 660
3048	IF (ITN .EQ. 0) GO TO 1000
3049	IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320
3050	SR = HR(EN,EN)
3051	SI = HI(EN,EN)
3052	XR = HR(ENM1,EN) * HR(EN,ENM1)
3053	XI = HI(ENM1,EN) * HR(EN,ENM1)
3054	IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 340
3055	YR = (HR(ENM1,ENM1) - SR) / 2.0D0
3056	YI = (HI(ENM1,ENM1) - SI) / 2.0D0
3057	CALL CSROOT(YR2-YI2+XR,2.0D0YRYI+XI,ZZR,ZZI)
3058	IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GO TO 310
3059	ZZR = -ZZR
3060	ZZI = -ZZI
3061	310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
3062	SR = SR - XR
3063	SI = SI - XI
3064	GO TO 340
3065	C .......... FORM EXCEPTIONAL SHIFT ..........
3066	320 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
3067	SI = 0.0D0
3068	C
3069	340 DO 360 I = LOW, EN
3070	HR(I,I) = HR(I,I) - SR
3071	HI(I,I) = HI(I,I) - SI
3072	360 CONTINUE
3073	C
3074	TR = TR + SR
3075	TI = TI + SI
3076	ITS = ITS + 1
3077	ITN = ITN - 1
3078	C .......... REDUCE TO TRIANGLE (ROWS) ..........
3079	LP1 = L + 1
3080	C
3081	DO 500 I = LP1, EN
3082	SR = HR(I,I-1)
3083	HR(I,I-1) = 0.0D0
3084	NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
3085	XR = HR(I-1,I-1) / NORM
3086	WR(I-1) = XR
3087	XI = HI(I-1,I-1) / NORM
3088	WI(I-1) = XI
3089	HR(I-1,I-1) = NORM
3090	HI(I-1,I-1) = 0.0D0
3091	HI(I,I-1) = SR / NORM
3092	C
3093	DO 490 J = I, EN
3094	YR = HR(I-1,J)
3095	YI = HI(I-1,J)
3096	ZZR = HR(I,J)
3097	ZZI = HI(I,J)
3098	HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
3099	HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
3100	HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
3101	HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
3102	490 CONTINUE
3103	C
3104	500 CONTINUE
3105	C
3106	SI = HI(EN,EN)
3107	IF (SI .EQ. 0.0D0) GO TO 540
3108	NORM = PYTHAG(HR(EN,EN),SI)
3109	SR = HR(EN,EN) / NORM
3110	SI = SI / NORM
3111	HR(EN,EN) = NORM
3112	HI(EN,EN) = 0.0D0
3113	C .......... INVERSE OPERATION (COLUMNS) ..........
3114	540 DO 600 J = LP1, EN
3115	XR = WR(J-1)
3116	XI = WI(J-1)
3117	C
3118	DO 580 I = L, J
3119	YR = HR(I,J-1)
3120	YI = 0.0D0
3121	ZZR = HR(I,J)
3122	ZZI = HI(I,J)
3123	IF (I .EQ. J) GO TO 560
3124	YI = HI(I,J-1)
3125	HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
3126	560 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
3127	HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
3128	HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
3129	580 CONTINUE
3130	C
3131	600 CONTINUE
3132	C
3133	IF (SI .EQ. 0.0D0) GO TO 240
3134	C
3135	DO 630 I = L, EN
3136	YR = HR(I,EN)
3137	YI = HI(I,EN)
3138	HR(I,EN) = SR * YR - SI * YI
3139	HI(I,EN) = SR * YI + SI * YR
3140	630 CONTINUE
3141	C
3142	GO TO 240
3143	C .......... A ROOT FOUND ..........
3144	660 WR(EN) = HR(EN,EN) + TR
3145	WI(EN) = HI(EN,EN) + TI
3146	EN = ENM1
3147	GO TO 220
3148	C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
3149	C CONVERGED AFTER 30*N ITERATIONS ..........
3150	1000 IERR = EN
3151	1001 RETURN
3152	END
3153	SUBROUTINE COMQR2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
3154	C
3155	INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
3156	X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
3157	DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N),
3158	X ORTR(IGH),ORTI(IGH)
3159	DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
3160	X PYTHAG
3161	C
3162	C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
3163	C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
3164	C AND WILKINSON.
3165	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
3166	C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
3167	C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
3168	C
3169	C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
3170	C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
3171	C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
3172	C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
3173	C THIS GENERAL MATRIX TO HESSENBERG FORM.
3174	C
3175	C ON INPUT
3176	C
3177	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
3178	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
3179	C DIMENSION STATEMENT.
3180	C
3181	C N IS THE ORDER OF THE MATRIX.
3182	C
3183	C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
3184	C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
3185	C SET LOW=1, IGH=N.
3186	C
3187	C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
3188	C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
3189	C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
3190	C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
3191	C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
3192	C
3193	C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
3194	C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
3195	C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
3196	C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
3197	C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
3198	C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
3199	C ARBITRARY.
3200	C
3201	C ON OUTPUT
3202	C
3203	C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
3204	C HAVE BEEN DESTROYED.
3205	C
3206	C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
3207	C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
3208	C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
3209	C FOR INDICES IERR+1,...,N.
3210	C
3211	C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
3212	C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
3213	C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
3214	C THE EIGENVECTORS HAS BEEN FOUND.
3215	C
3216	C IERR IS SET TO
3217	C ZERO FOR NORMAL RETURN,
3218	C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
3219	C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
3220	C
3221	C CALLS CDIV FOR COMPLEX DIVISION.
3222	C CALLS CSROOT FOR COMPLEX SQUARE ROOT.
3223	C CALLS PYTHAG FOR DSQRT(AA + BB) .
3224	C
3225	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
3226	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
3227	C
3228	C THIS VERSION DATED AUGUST 1983.
3229	C
3230	C ------------------------------------------------------------------
3231	C
3232	IERR = 0
3233	C .......... INITIALIZE EIGENVECTOR MATRIX ..........
3234	DO 101 J = 1, N
3235	C
3236	DO 100 I = 1, N
3237	ZR(I,J) = 0.0D0
3238	ZI(I,J) = 0.0D0
3239	100 CONTINUE
3240	ZR(J,J) = 1.0D0
3241	101 CONTINUE
3242	C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
3243	C FROM THE INFORMATION LEFT BY CORTH ..........
3244	IEND = IGH - LOW - 1
3245	IF (IEND) 180, 150, 105
3246	C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
3247	105 DO 140 II = 1, IEND
3248	I = IGH - II
3249	IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GO TO 140
3250	IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GO TO 140
3251	C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
3252	NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
3253	IP1 = I + 1
3254	C
3255	DO 110 K = IP1, IGH
3256	ORTR(K) = HR(K,I-1)
3257	ORTI(K) = HI(K,I-1)
3258	110 CONTINUE
3259	C
3260	DO 130 J = I, IGH
3261	SR = 0.0D0
3262	SI = 0.0D0
3263	C
3264	DO 115 K = I, IGH
3265	SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
3266	SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
3267	115 CONTINUE
3268	C
3269	SR = SR / NORM
3270	SI = SI / NORM
3271	C
3272	DO 120 K = I, IGH
3273	ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
3274	ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
3275	120 CONTINUE
3276	C
3277	130 CONTINUE
3278	C
3279	140 CONTINUE
3280	C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
3281	150 L = LOW + 1
3282	C
3283	DO 170 I = L, IGH
3284	LL = MIN0(I+1,IGH)
3285	IF (HI(I,I-1) .EQ. 0.0D0) GO TO 170
3286	NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
3287	YR = HR(I,I-1) / NORM
3288	YI = HI(I,I-1) / NORM
3289	HR(I,I-1) = NORM
3290	HI(I,I-1) = 0.0D0
3291	C
3292	DO 155 J = I, N
3293	SI = YR * HI(I,J) - YI * HR(I,J)
3294	HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
3295	HI(I,J) = SI
3296	155 CONTINUE
3297	C
3298	DO 160 J = 1, LL
3299	SI = YR * HI(J,I) + YI * HR(J,I)
3300	HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
3301	HI(J,I) = SI
3302	160 CONTINUE
3303	C
3304	DO 165 J = LOW, IGH
3305	SI = YR * ZI(J,I) + YI * ZR(J,I)
3306	ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
3307	ZI(J,I) = SI
3308	165 CONTINUE
3309	C
3310	170 CONTINUE
3311	C .......... STORE ROOTS ISOLATED BY CBAL ..........
3312	180 DO 200 I = 1, N
3313	IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
3314	WR(I) = HR(I,I)
3315	WI(I) = HI(I,I)
3316	200 CONTINUE
3317	C
3318	EN = IGH
3319	TR = 0.0D0
3320	TI = 0.0D0
3321	ITN = 30*N
3322	C .......... SEARCH FOR NEXT EIGENVALUE ..........
3323	220 IF (EN .LT. LOW) GO TO 680
3324	ITS = 0
3325	ENM1 = EN - 1
3326	C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
3327	C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
3328	240 DO 260 LL = LOW, EN
3329	L = EN + LOW - LL
3330	IF (L .EQ. LOW) GO TO 300
3331	TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
3332	X + DABS(HR(L,L)) + DABS(HI(L,L))
3333	TST2 = TST1 + DABS(HR(L,L-1))
3334	IF (TST2 .EQ. TST1) GO TO 300
3335	260 CONTINUE
3336	C .......... FORM SHIFT ..........
3337	300 IF (L .EQ. EN) GO TO 660
3338	IF (ITN .EQ. 0) GO TO 1000
3339	IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320
3340	SR = HR(EN,EN)
3341	SI = HI(EN,EN)
3342	XR = HR(ENM1,EN) * HR(EN,ENM1)
3343	XI = HI(ENM1,EN) * HR(EN,ENM1)
3344	IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 340
3345	YR = (HR(ENM1,ENM1) - SR) / 2.0D0
3346	YI = (HI(ENM1,ENM1) - SI) / 2.0D0
3347	CALL CSROOT(YR2-YI2+XR,2.0D0YRYI+XI,ZZR,ZZI)
3348	IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GO TO 310
3349	ZZR = -ZZR
3350	ZZI = -ZZI
3351	310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
3352	SR = SR - XR
3353	SI = SI - XI
3354	GO TO 340
3355	C .......... FORM EXCEPTIONAL SHIFT ..........
3356	320 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
3357	SI = 0.0D0
3358	C
3359	340 DO 360 I = LOW, EN
3360	HR(I,I) = HR(I,I) - SR
3361	HI(I,I) = HI(I,I) - SI
3362	360 CONTINUE
3363	C
3364	TR = TR + SR
3365	TI = TI + SI
3366	ITS = ITS + 1
3367	ITN = ITN - 1
3368	C .......... REDUCE TO TRIANGLE (ROWS) ..........
3369	LP1 = L + 1
3370	C
3371	DO 500 I = LP1, EN
3372	SR = HR(I,I-1)
3373	HR(I,I-1) = 0.0D0
3374	NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
3375	XR = HR(I-1,I-1) / NORM
3376	WR(I-1) = XR
3377	XI = HI(I-1,I-1) / NORM
3378	WI(I-1) = XI
3379	HR(I-1,I-1) = NORM
3380	HI(I-1,I-1) = 0.0D0
3381	HI(I,I-1) = SR / NORM
3382	C
3383	DO 490 J = I, N
3384	YR = HR(I-1,J)
3385	YI = HI(I-1,J)
3386	ZZR = HR(I,J)
3387	ZZI = HI(I,J)
3388	HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
3389	HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
3390	HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
3391	HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
3392	490 CONTINUE
3393	C
3394	500 CONTINUE
3395	C
3396	SI = HI(EN,EN)
3397	IF (SI .EQ. 0.0D0) GO TO 540
3398	NORM = PYTHAG(HR(EN,EN),SI)
3399	SR = HR(EN,EN) / NORM
3400	SI = SI / NORM
3401	HR(EN,EN) = NORM
3402	HI(EN,EN) = 0.0D0
3403	IF (EN .EQ. N) GO TO 540
3404	IP1 = EN + 1
3405	C
3406	DO 520 J = IP1, N
3407	YR = HR(EN,J)
3408	YI = HI(EN,J)
3409	HR(EN,J) = SR * YR + SI * YI
3410	HI(EN,J) = SR * YI - SI * YR
3411	520 CONTINUE
3412	C .......... INVERSE OPERATION (COLUMNS) ..........
3413	540 DO 600 J = LP1, EN
3414	XR = WR(J-1)
3415	XI = WI(J-1)
3416	C
3417	DO 580 I = 1, J
3418	YR = HR(I,J-1)
3419	YI = 0.0D0
3420	ZZR = HR(I,J)
3421	ZZI = HI(I,J)
3422	IF (I .EQ. J) GO TO 560
3423	YI = HI(I,J-1)
3424	HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
3425	560 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
3426	HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
3427	HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
3428	580 CONTINUE
3429	C
3430	DO 590 I = LOW, IGH
3431	YR = ZR(I,J-1)
3432	YI = ZI(I,J-1)
3433	ZZR = ZR(I,J)
3434	ZZI = ZI(I,J)
3435	ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
3436	ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
3437	ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
3438	ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
3439	590 CONTINUE
3440	C
3441	600 CONTINUE
3442	C
3443	IF (SI .EQ. 0.0D0) GO TO 240
3444	C
3445	DO 630 I = 1, EN
3446	YR = HR(I,EN)
3447	YI = HI(I,EN)
3448	HR(I,EN) = SR * YR - SI * YI
3449	HI(I,EN) = SR * YI + SI * YR
3450	630 CONTINUE
3451	C
3452	DO 640 I = LOW, IGH
3453	YR = ZR(I,EN)
3454	YI = ZI(I,EN)
3455	ZR(I,EN) = SR * YR - SI * YI
3456	ZI(I,EN) = SR * YI + SI * YR
3457	640 CONTINUE
3458	C
3459	GO TO 240
3460	C .......... A ROOT FOUND ..........
3461	660 HR(EN,EN) = HR(EN,EN) + TR
3462	WR(EN) = HR(EN,EN)
3463	HI(EN,EN) = HI(EN,EN) + TI
3464	WI(EN) = HI(EN,EN)
3465	EN = ENM1
3466	GO TO 220
3467	C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
3468	C VECTORS OF UPPER TRIANGULAR FORM ..........
3469	680 NORM = 0.0D0
3470	C
3471	DO 720 I = 1, N
3472	C
3473	DO 720 J = I, N
3474	TR = DABS(HR(I,J)) + DABS(HI(I,J))
3475	IF (TR .GT. NORM) NORM = TR
3476	720 CONTINUE
3477	C
3478	IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GO TO 1001
3479	C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
3480	DO 800 NN = 2, N
3481	EN = N + 2 - NN
3482	XR = WR(EN)
3483	XI = WI(EN)
3484	HR(EN,EN) = 1.0D0
3485	HI(EN,EN) = 0.0D0
3486	ENM1 = EN - 1
3487	C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
3488	DO 780 II = 1, ENM1
3489	I = EN - II
3490	ZZR = 0.0D0
3491	ZZI = 0.0D0
3492	IP1 = I + 1
3493	C
3494	DO 740 J = IP1, EN
3495	ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
3496	ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
3497	740 CONTINUE
3498	C
3499	YR = XR - WR(I)
3500	YI = XI - WI(I)
3501	IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GO TO 765
3502	TST1 = NORM
3503	YR = TST1
3504	760 YR = 0.01D0 * YR
3505	TST2 = NORM + YR
3506	IF (TST2 .GT. TST1) GO TO 760
3507	765 CONTINUE
3508	CALL CDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
3509	C .......... OVERFLOW CONTROL ..........
3510	TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
3511	IF (TR .EQ. 0.0D0) GO TO 780
3512	TST1 = TR
3513	TST2 = TST1 + 1.0D0/TST1
3514	IF (TST2 .GT. TST1) GO TO 780
3515	DO 770 J = I, EN
3516	HR(J,EN) = HR(J,EN)/TR
3517	HI(J,EN) = HI(J,EN)/TR
3518	770 CONTINUE
3519	C
3520	780 CONTINUE
3521	C
3522	800 CONTINUE
3523	C .......... END BACKSUBSTITUTION ..........
3524	ENM1 = N - 1
3525	C .......... VECTORS OF ISOLATED ROOTS ..........
3526	DO 840 I = 1, ENM1
3527	IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840
3528	IP1 = I + 1
3529	C
3530	DO 820 J = IP1, N
3531	ZR(I,J) = HR(I,J)
3532	ZI(I,J) = HI(I,J)
3533	820 CONTINUE
3534	C
3535	840 CONTINUE
3536	C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
3537	C VECTORS OF ORIGINAL FULL MATRIX.
3538	C FOR J=N STEP -1 UNTIL LOW+1 DO -- ..........
3539	DO 880 JJ = LOW, ENM1
3540	J = N + LOW - JJ
3541	M = MIN0(J,IGH)
3542	C
3543	DO 880 I = LOW, IGH
3544	ZZR = 0.0D0
3545	ZZI = 0.0D0
3546	C
3547	DO 860 K = LOW, M
3548	ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
3549	ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
3550	860 CONTINUE
3551	C
3552	ZR(I,J) = ZZR
3553	ZI(I,J) = ZZI
3554	880 CONTINUE
3555	C
3556	GO TO 1001
3557	C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
3558	C CONVERGED AFTER 30*N ITERATIONS ..........
3559	1000 IERR = EN
3560	1001 RETURN
3561	END
3562	SUBROUTINE CORTB(NM,LOW,IGH,AR,AI,ORTR,ORTI,M,ZR,ZI)
3563	C
3564	INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1
3565	DOUBLE PRECISION AR(NM,IGH),AI(NM,IGH),ORTR(IGH),ORTI(IGH),
3566	X ZR(NM,M),ZI(NM,M)
3567	DOUBLE PRECISION H,GI,GR
3568	C
3569	C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
3570	C THE ALGOL PROCEDURE ORTBAK, NUM. MATH. 12, 349-368(1968)
3571	C BY MARTIN AND WILKINSON.
3572	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
3573	C
3574	C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
3575	C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
3576	C UPPER HESSENBERG MATRIX DETERMINED BY CORTH.
3577	C
3578	C ON INPUT
3579	C
3580	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
3581	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
3582	C DIMENSION STATEMENT.
3583	C
3584	C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
3585	C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
3586	C SET LOW=1 AND IGH EQUAL TO THE ORDER OF THE MATRIX.
3587	C
3588	C AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY
3589	C TRANSFORMATIONS USED IN THE REDUCTION BY CORTH
3590	C IN THEIR STRICT LOWER TRIANGLES.
3591	C
3592	C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
3593	C TRANSFORMATIONS USED IN THE REDUCTION BY CORTH.
3594	C ONLY ELEMENTS LOW THROUGH IGH ARE USED.
3595	C
3596	C M IS THE NUMBER OF COLUMNS OF ZR AND ZI TO BE BACK TRANSFORMED.
3597	C
3598	C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
3599	C RESPECTIVELY, OF THE EIGENVECTORS TO BE
3600	C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
3601	C
3602	C ON OUTPUT
3603	C
3604	C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
3605	C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
3606	C IN THEIR FIRST M COLUMNS.
3607	C
3608	C ORTR AND ORTI HAVE BEEN ALTERED.
3609	C
3610	C NOTE THAT CORTB PRESERVES VECTOR EUCLIDEAN NORMS.
3611	C
3612	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
3613	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
3614	C
3615	C THIS VERSION DATED AUGUST 1983.
3616	C
3617	C ------------------------------------------------------------------
3618	C
3619	IF (M .EQ. 0) GO TO 200
3620	LA = IGH - 1
3621	KP1 = LOW + 1
3622	IF (LA .LT. KP1) GO TO 200
3623	C .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
3624	DO 140 MM = KP1, LA
3625	MP = LOW + IGH - MM
3626	IF (AR(MP,MP-1) .EQ. 0.0D0 .AND. AI(MP,MP-1) .EQ. 0.0D0)
3627	X GO TO 140
3628	C .......... H BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
3629	H = AR(MP,MP-1) * ORTR(MP) + AI(MP,MP-1) * ORTI(MP)
3630	MP1 = MP + 1
3631	C
3632	DO 100 I = MP1, IGH
3633	ORTR(I) = AR(I,MP-1)
3634	ORTI(I) = AI(I,MP-1)
3635	100 CONTINUE
3636	C
3637	DO 130 J = 1, M
3638	GR = 0.0D0
3639	GI = 0.0D0
3640	C
3641	DO 110 I = MP, IGH
3642	GR = GR + ORTR(I) * ZR(I,J) + ORTI(I) * ZI(I,J)
3643	GI = GI + ORTR(I) * ZI(I,J) - ORTI(I) * ZR(I,J)
3644	110 CONTINUE
3645	C
3646	GR = GR / H
3647	GI = GI / H
3648	C
3649	DO 120 I = MP, IGH
3650	ZR(I,J) = ZR(I,J) + GR * ORTR(I) - GI * ORTI(I)
3651	ZI(I,J) = ZI(I,J) + GR * ORTI(I) + GI * ORTR(I)
3652	120 CONTINUE
3653	C
3654	130 CONTINUE
3655	C
3656	140 CONTINUE
3657	C
3658	200 RETURN
3659	END
3660	SUBROUTINE CORTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
3661	C
3662	INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
3663	DOUBLE PRECISION AR(NM,N),AI(NM,N),ORTR(IGH),ORTI(IGH)
3664	DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
3665	C
3666	C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
3667	C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
3668	C BY MARTIN AND WILKINSON.
3669	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
3670	C
3671	C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
3672	C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
3673	C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
3674	C UNITARY SIMILARITY TRANSFORMATIONS.
3675	C
3676	C ON INPUT
3677	C
3678	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
3679	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
3680	C DIMENSION STATEMENT.
3681	C
3682	C N IS THE ORDER OF THE MATRIX.
3683	C
3684	C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
3685	C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
3686	C SET LOW=1, IGH=N.
3687	C
3688	C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
3689	C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
3690	C
3691	C ON OUTPUT
3692	C
3693	C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
3694	C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
3695	C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
3696	C IS STORED IN THE REMAINING TRIANGLES UNDER THE
3697	C HESSENBERG MATRIX.
3698	C
3699	C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
3700	C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
3701	C
3702	C CALLS PYTHAG FOR DSQRT(AA + BB) .
3703	C
3704	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
3705	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
3706	C
3707	C THIS VERSION DATED AUGUST 1983.
3708	C
3709	C ------------------------------------------------------------------
3710	C
3711	LA = IGH - 1
3712	KP1 = LOW + 1
3713	IF (LA .LT. KP1) GO TO 200
3714	C
3715	DO 180 M = KP1, LA
3716	H = 0.0D0
3717	ORTR(M) = 0.0D0
3718	ORTI(M) = 0.0D0
3719	SCALE = 0.0D0
3720	C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
3721	DO 90 I = M, IGH
3722	90 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
3723	C
3724	IF (SCALE .EQ. 0.0D0) GO TO 180
3725	MP = M + IGH
3726	C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
3727	DO 100 II = M, IGH
3728	I = MP - II
3729	ORTR(I) = AR(I,M-1) / SCALE
3730	ORTI(I) = AI(I,M-1) / SCALE
3731	H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
3732	100 CONTINUE
3733	C
3734	G = DSQRT(H)
3735	F = PYTHAG(ORTR(M),ORTI(M))
3736	IF (F .EQ. 0.0D0) GO TO 103
3737	H = H + F * G
3738	G = G / F
3739	ORTR(M) = (1.0D0 + G) * ORTR(M)
3740	ORTI(M) = (1.0D0 + G) * ORTI(M)
3741	GO TO 105
3742	C
3743	103 ORTR(M) = G
3744	AR(M,M-1) = SCALE
3745	C .......... FORM (I-(UUT)/H) A ..........
3746	105 DO 130 J = M, N
3747	FR = 0.0D0
3748	FI = 0.0D0
3749	C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
3750	DO 110 II = M, IGH
3751	I = MP - II
3752	FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
3753	FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
3754	110 CONTINUE
3755	C
3756	FR = FR / H
3757	FI = FI / H
3758	C
3759	DO 120 I = M, IGH
3760	AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
3761	AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
3762	120 CONTINUE
3763	C
3764	130 CONTINUE
3765	C .......... FORM (I-(UUT)/H)A(I-(UUT)/H) ..........
3766	DO 160 I = 1, IGH
3767	FR = 0.0D0
3768	FI = 0.0D0
3769	C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
3770	DO 140 JJ = M, IGH
3771	J = MP - JJ
3772	FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
3773	FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
3774	140 CONTINUE
3775	C
3776	FR = FR / H
3777	FI = FI / H
3778	C
3779	DO 150 J = M, IGH
3780	AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
3781	AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
3782	150 CONTINUE
3783	C
3784	160 CONTINUE
3785	C
3786	ORTR(M) = SCALE * ORTR(M)
3787	ORTI(M) = SCALE * ORTI(M)
3788	AR(M,M-1) = -G * AR(M,M-1)
3789	AI(M,M-1) = -G * AI(M,M-1)
3790	180 CONTINUE
3791	C
3792	200 RETURN
3793	END
3794	SUBROUTINE ELMBAK(NM,LOW,IGH,A,INT,M,Z)
3795	C
3796	INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1
3797	DOUBLE PRECISION A(NM,IGH),Z(NM,M)
3798	DOUBLE PRECISION X
3799	INTEGER INT(IGH)
3800	C
3801	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMBAK,
3802	C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON.
3803	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
3804	C
3805	C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL GENERAL
3806	C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
3807	C UPPER HESSENBERG MATRIX DETERMINED BY ELMHES.
3808	C
3809	C ON INPUT
3810	C
3811	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
3812	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
3813	C DIMENSION STATEMENT.
3814	C
3815	C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
3816	C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED,
3817	C SET LOW=1 AND IGH EQUAL TO THE ORDER OF THE MATRIX.
3818	C
3819	C A CONTAINS THE MULTIPLIERS WHICH WERE USED IN THE
3820	C REDUCTION BY ELMHES IN ITS LOWER TRIANGLE
3821	C BELOW THE SUBDIAGONAL.
3822	C
3823	C INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS
3824	C INTERCHANGED IN THE REDUCTION BY ELMHES.
3825	C ONLY ELEMENTS LOW THROUGH IGH ARE USED.
3826	C
3827	C M IS THE NUMBER OF COLUMNS OF Z TO BE BACK TRANSFORMED.
3828	C
3829	C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGEN-
3830	C VECTORS TO BE BACK TRANSFORMED IN ITS FIRST M COLUMNS.
3831	C
3832	C ON OUTPUT
3833	C
3834	C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE
3835	C TRANSFORMED EIGENVECTORS IN ITS FIRST M COLUMNS.
3836	C
3837	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
3838	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
3839	C
3840	C THIS VERSION DATED AUGUST 1983.
3841	C
3842	C ------------------------------------------------------------------
3843	C
3844	IF (M .EQ. 0) GO TO 200
3845	LA = IGH - 1
3846	KP1 = LOW + 1
3847	IF (LA .LT. KP1) GO TO 200
3848	C .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
3849	DO 140 MM = KP1, LA
3850	MP = LOW + IGH - MM
3851	MP1 = MP + 1
3852	C
3853	DO 110 I = MP1, IGH
3854	X = A(I,MP-1)
3855	IF (X .EQ. 0.0D0) GO TO 110
3856	C
3857	DO 100 J = 1, M
3858	100 Z(I,J) = Z(I,J) + X * Z(MP,J)
3859	C
3860	110 CONTINUE
3861	C
3862	I = INT(MP)
3863	IF (I .EQ. MP) GO TO 140
3864	C
3865	DO 130 J = 1, M
3866	X = Z(I,J)
3867	Z(I,J) = Z(MP,J)
3868	Z(MP,J) = X
3869	130 CONTINUE
3870	C
3871	140 CONTINUE
3872	C
3873	200 RETURN
3874	END
3875	SUBROUTINE ELMHES(NM,N,LOW,IGH,A,INT)
3876	C
3877	INTEGER I,J,M,N,LA,NM,IGH,KP1,LOW,MM1,MP1
3878	DOUBLE PRECISION A(NM,N)
3879	DOUBLE PRECISION X,Y
3880	INTEGER INT(IGH)
3881	C
3882	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMHES,
3883	C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON.
3884	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
3885	C
3886	C GIVEN A REAL GENERAL MATRIX, THIS SUBROUTINE
3887	C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
3888	C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
3889	C STABILIZED ELEMENTARY SIMILARITY TRANSFORMATIONS.
3890	C
3891	C ON INPUT
3892	C
3893	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
3894	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
3895	C DIMENSION STATEMENT.
3896	C
3897	C N IS THE ORDER OF THE MATRIX.
3898	C
3899	C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
3900	C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED,
3901	C SET LOW=1, IGH=N.
3902	C
3903	C A CONTAINS THE INPUT MATRIX.
3904	C
3905	C ON OUTPUT
3906	C
3907	C A CONTAINS THE HESSENBERG MATRIX. THE MULTIPLIERS
3908	C WHICH WERE USED IN THE REDUCTION ARE STORED IN THE
3909	C REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX.
3910	C
3911	C INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS
3912	C INTERCHANGED IN THE REDUCTION.
3913	C ONLY ELEMENTS LOW THROUGH IGH ARE USED.
3914	C
3915	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
3916	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
3917	C
3918	C THIS VERSION DATED AUGUST 1983.
3919	C
3920	C ------------------------------------------------------------------
3921	C
3922	LA = IGH - 1
3923	KP1 = LOW + 1
3924	IF (LA .LT. KP1) GO TO 200
3925	C
3926	DO 180 M = KP1, LA
3927	MM1 = M - 1
3928	X = 0.0D0
3929	I = M
3930	C
3931	DO 100 J = M, IGH
3932	IF (DABS(A(J,MM1)) .LE. DABS(X)) GO TO 100
3933	X = A(J,MM1)
3934	I = J
3935	100 CONTINUE
3936	C
3937	INT(M) = I
3938	IF (I .EQ. M) GO TO 130
3939	C .......... INTERCHANGE ROWS AND COLUMNS OF A ..........
3940	DO 110 J = MM1, N
3941	Y = A(I,J)
3942	A(I,J) = A(M,J)
3943	A(M,J) = Y
3944	110 CONTINUE
3945	C
3946	DO 120 J = 1, IGH
3947	Y = A(J,I)
3948	A(J,I) = A(J,M)
3949	A(J,M) = Y
3950	120 CONTINUE
3951	C .......... END INTERCHANGE ..........
3952	130 IF (X .EQ. 0.0D0) GO TO 180
3953	MP1 = M + 1
3954	C
3955	DO 160 I = MP1, IGH
3956	Y = A(I,MM1)
3957	IF (Y .EQ. 0.0D0) GO TO 160
3958	Y = Y / X
3959	A(I,MM1) = Y
3960	C
3961	DO 140 J = M, N
3962	140 A(I,J) = A(I,J) - Y * A(M,J)
3963	C
3964	DO 150 J = 1, IGH
3965	150 A(J,M) = A(J,M) + Y * A(J,I)
3966	C
3967	160 CONTINUE
3968	C
3969	180 CONTINUE
3970	C
3971	200 RETURN
3972	END
3973	SUBROUTINE ELTRAN(NM,N,LOW,IGH,A,INT,Z)
3974	C
3975	INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1
3976	DOUBLE PRECISION A(NM,IGH),Z(NM,N)
3977	INTEGER INT(IGH)
3978	C
3979	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMTRANS,
3980	C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON.
3981	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
3982	C
3983	C THIS SUBROUTINE ACCUMULATES THE STABILIZED ELEMENTARY
3984	C SIMILARITY TRANSFORMATIONS USED IN THE REDUCTION OF A
3985	C REAL GENERAL MATRIX TO UPPER HESSENBERG FORM BY ELMHES.
3986	C
3987	C ON INPUT
3988	C
3989	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
3990	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
3991	C DIMENSION STATEMENT.
3992	C
3993	C N IS THE ORDER OF THE MATRIX.
3994	C
3995	C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
3996	C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED,
3997	C SET LOW=1, IGH=N.
3998	C
3999	C A CONTAINS THE MULTIPLIERS WHICH WERE USED IN THE
4000	C REDUCTION BY ELMHES IN ITS LOWER TRIANGLE
4001	C BELOW THE SUBDIAGONAL.
4002	C
4003	C INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS
4004	C INTERCHANGED IN THE REDUCTION BY ELMHES.
4005	C ONLY ELEMENTS LOW THROUGH IGH ARE USED.
4006	C
4007	C ON OUTPUT
4008	C
4009	C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
4010	C REDUCTION BY ELMHES.
4011	C
4012	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
4013	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
4014	C
4015	C THIS VERSION DATED AUGUST 1983.
4016	C
4017	C ------------------------------------------------------------------
4018	C
4019	C .......... INITIALIZE Z TO IDENTITY MATRIX ..........
4020	DO 80 J = 1, N
4021	C
4022	DO 60 I = 1, N
4023	60 Z(I,J) = 0.0D0
4024	C
4025	Z(J,J) = 1.0D0
4026	80 CONTINUE
4027	C
4028	KL = IGH - LOW - 1
4029	IF (KL .LT. 1) GO TO 200
4030	C .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
4031	DO 140 MM = 1, KL
4032	MP = IGH - MM
4033	MP1 = MP + 1
4034	C
4035	DO 100 I = MP1, IGH
4036	100 Z(I,MP) = A(I,MP-1)
4037	C
4038	I = INT(MP)
4039	IF (I .EQ. MP) GO TO 140
4040	C
4041	DO 130 J = MP, IGH
4042	Z(MP,J) = Z(I,J)
4043	Z(I,J) = 0.0D0
4044	130 CONTINUE
4045	C
4046	Z(I,MP) = 1.0D0
4047	140 CONTINUE
4048	C
4049	200 RETURN
4050	END
4051	SUBROUTINE FIGI(NM,N,T,D,E,E2,IERR)
4052	C
4053	INTEGER I,N,NM,IERR
4054	DOUBLE PRECISION T(NM,3),D(N),E(N),E2(N)
4055	C
4056	C GIVEN A NONSYMMETRIC TRIDIAGONAL MATRIX SUCH THAT THE PRODUCTS
4057	C OF CORRESPONDING PAIRS OF OFF-DIAGONAL ELEMENTS ARE ALL
4058	C NON-NEGATIVE, THIS SUBROUTINE REDUCES IT TO A SYMMETRIC
4059	C TRIDIAGONAL MATRIX WITH THE SAME EIGENVALUES. IF, FURTHER,
4060	C A ZERO PRODUCT ONLY OCCURS WHEN BOTH FACTORS ARE ZERO,
4061	C THE REDUCED MATRIX IS SIMILAR TO THE ORIGINAL MATRIX.
4062	C
4063	C ON INPUT
4064	C
4065	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
4066	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
4067	C DIMENSION STATEMENT.
4068	C
4069	C N IS THE ORDER OF THE MATRIX.
4070	C
4071	C T CONTAINS THE INPUT MATRIX. ITS SUBDIAGONAL IS
4072	C STORED IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN,
4073	C ITS DIAGONAL IN THE N POSITIONS OF THE SECOND COLUMN,
4074	C AND ITS SUPERDIAGONAL IN THE FIRST N-1 POSITIONS OF
4075	C THE THIRD COLUMN. T(1,1) AND T(N,3) ARE ARBITRARY.
4076	C
4077	C ON OUTPUT
4078	C
4079	C T IS UNALTERED.
4080	C
4081	C D CONTAINS THE DIAGONAL ELEMENTS OF THE SYMMETRIC MATRIX.
4082	C
4083	C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE SYMMETRIC
4084	C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS NOT SET.
4085	C
4086	C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
4087	C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
4088	C
4089	C IERR IS SET TO
4090	C ZERO FOR NORMAL RETURN,
4091	C N+I IF T(I,1)*T(I-1,3) IS NEGATIVE,
4092	C -(3N+I) IF T(I,1)T(I-1,3) IS ZERO WITH ONE FACTOR
4093	C NON-ZERO. IN THIS CASE, THE EIGENVECTORS OF
4094	C THE SYMMETRIC MATRIX ARE NOT SIMPLY RELATED
4095	C TO THOSE OF T AND SHOULD NOT BE SOUGHT.
4096	C
4097	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
4098	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
4099	C
4100	C THIS VERSION DATED AUGUST 1983.
4101	C
4102	C ------------------------------------------------------------------
4103	C
4104	IERR = 0
4105	C
4106	DO 100 I = 1, N
4107	IF (I .EQ. 1) GO TO 90
4108	E2(I) = T(I,1) * T(I-1,3)
4109	IF (E2(I)) 1000, 60, 80
4110	60 IF (T(I,1) .EQ. 0.0D0 .AND. T(I-1,3) .EQ. 0.0D0) GO TO 80
4111	C .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL
4112	C ELEMENTS IS ZERO WITH ONE MEMBER NON-ZERO ..........
4113	IERR = -(3 * N + I)
4114	80 E(I) = DSQRT(E2(I))
4115	90 D(I) = T(I,2)
4116	100 CONTINUE
4117	C
4118	GO TO 1001
4119	C .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL
4120	C ELEMENTS IS NEGATIVE ..........
4121	1000 IERR = N + I
4122	1001 RETURN
4123	END
4124	SUBROUTINE FIGI2(NM,N,T,D,E,Z,IERR)
4125	C
4126	INTEGER I,J,N,NM,IERR
4127	DOUBLE PRECISION T(NM,3),D(N),E(N),Z(NM,N)
4128	DOUBLE PRECISION H
4129	C
4130	C GIVEN A NONSYMMETRIC TRIDIAGONAL MATRIX SUCH THAT THE PRODUCTS
4131	C OF CORRESPONDING PAIRS OF OFF-DIAGONAL ELEMENTS ARE ALL
4132	C NON-NEGATIVE, AND ZERO ONLY WHEN BOTH FACTORS ARE ZERO, THIS
4133	C SUBROUTINE REDUCES IT TO A SYMMETRIC TRIDIAGONAL MATRIX
4134	C USING AND ACCUMULATING DIAGONAL SIMILARITY TRANSFORMATIONS.
4135	C
4136	C ON INPUT
4137	C
4138	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
4139	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
4140	C DIMENSION STATEMENT.
4141	C
4142	C N IS THE ORDER OF THE MATRIX.
4143	C
4144	C T CONTAINS THE INPUT MATRIX. ITS SUBDIAGONAL IS
4145	C STORED IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN,
4146	C ITS DIAGONAL IN THE N POSITIONS OF THE SECOND COLUMN,
4147	C AND ITS SUPERDIAGONAL IN THE FIRST N-1 POSITIONS OF
4148	C THE THIRD COLUMN. T(1,1) AND T(N,3) ARE ARBITRARY.
4149	C
4150	C ON OUTPUT
4151	C
4152	C T IS UNALTERED.
4153	C
4154	C D CONTAINS THE DIAGONAL ELEMENTS OF THE SYMMETRIC MATRIX.
4155	C
4156	C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE SYMMETRIC
4157	C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS NOT SET.
4158	C
4159	C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN
4160	C THE REDUCTION.
4161	C
4162	C IERR IS SET TO
4163	C ZERO FOR NORMAL RETURN,
4164	C N+I IF T(I,1)*T(I-1,3) IS NEGATIVE,
4165	C 2N+I IF T(I,1)T(I-1,3) IS ZERO WITH
4166	C ONE FACTOR NON-ZERO.
4167	C
4168	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
4169	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
4170	C
4171	C THIS VERSION DATED AUGUST 1983.
4172	C
4173	C ------------------------------------------------------------------
4174	C
4175	IERR = 0
4176	C
4177	DO 100 I = 1, N
4178	C
4179	DO 50 J = 1, N
4180	50 Z(I,J) = 0.0D0
4181	C
4182	IF (I .EQ. 1) GO TO 70
4183	H = T(I,1) * T(I-1,3)
4184	IF (H) 900, 60, 80
4185	60 IF (T(I,1) .NE. 0.0D0 .OR. T(I-1,3) .NE. 0.0D0) GO TO 1000
4186	E(I) = 0.0D0
4187	70 Z(I,I) = 1.0D0
4188	GO TO 90
4189	80 E(I) = DSQRT(H)
4190	Z(I,I) = Z(I-1,I-1) * E(I) / T(I-1,3)
4191	90 D(I) = T(I,2)
4192	100 CONTINUE
4193	C
4194	GO TO 1001
4195	C .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL
4196	C ELEMENTS IS NEGATIVE ..........
4197	900 IERR = N + I
4198	GO TO 1001
4199	C .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL
4200	C ELEMENTS IS ZERO WITH ONE MEMBER NON-ZERO ..........
4201	1000 IERR = 2 * N + I
4202	1001 RETURN
4203	END
4204	SUBROUTINE HQR(NM,N,LOW,IGH,H,WR,WI,IERR)
4205	C
4206	INTEGER I,J,K,L,M,N,EN,LL,MM,NA,NM,IGH,ITN,ITS,LOW,MP2,ENM2,IERR
4207	DOUBLE PRECISION H(NM,N),WR(N),WI(N)
4208	DOUBLE PRECISION P,Q,R,S,T,W,X,Y,ZZ,NORM,TST1,TST2
4209	LOGICAL NOTLAS
4210	C
4211	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR,
4212	C NUM. MATH. 14, 219-231(1970) BY MARTIN, PETERS, AND WILKINSON.
4213	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 359-371(1971).
4214	C
4215	C THIS SUBROUTINE FINDS THE EIGENVALUES OF A REAL
4216	C UPPER HESSENBERG MATRIX BY THE QR METHOD.
4217	C
4218	C ON INPUT
4219	C
4220	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
4221	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
4222	C DIMENSION STATEMENT.
4223	C
4224	C N IS THE ORDER OF THE MATRIX.
4225	C
4226	C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
4227	C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED,
4228	C SET LOW=1, IGH=N.
4229	C
4230	C H CONTAINS THE UPPER HESSENBERG MATRIX. INFORMATION ABOUT
4231	C THE TRANSFORMATIONS USED IN THE REDUCTION TO HESSENBERG
4232	C FORM BY ELMHES OR ORTHES, IF PERFORMED, IS STORED
4233	C IN THE REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX.
4234	C
4235	C ON OUTPUT
4236	C
4237	C H HAS BEEN DESTROYED. THEREFORE, IT MUST BE SAVED
4238	C BEFORE CALLING HQR IF SUBSEQUENT CALCULATION AND
4239	C BACK TRANSFORMATION OF EIGENVECTORS IS TO BE PERFORMED.
4240	C
4241	C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
4242	C RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES
4243	C ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS
4244	C OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE
4245	C HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN
4246	C ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
4247	C FOR INDICES IERR+1,...,N.
4248	C
4249	C IERR IS SET TO
4250	C ZERO FOR NORMAL RETURN,
4251	C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
4252	C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
4253	C
4254	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
4255	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
4256	C
4257	C THIS VERSION DATED AUGUST 1983.
4258	C
4259	C ------------------------------------------------------------------
4260	C
4261	IERR = 0
4262	NORM = 0.0D0
4263	K = 1
4264	C .......... STORE ROOTS ISOLATED BY BALANC
4265	C AND COMPUTE MATRIX NORM ..........
4266	DO 50 I = 1, N
4267	C
4268	DO 40 J = K, N
4269	40 NORM = NORM + DABS(H(I,J))
4270	C
4271	K = I
4272	IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50
4273	WR(I) = H(I,I)
4274	WI(I) = 0.0D0
4275	50 CONTINUE
4276	C
4277	EN = IGH
4278	T = 0.0D0
4279	ITN = 30*N
4280	C .......... SEARCH FOR NEXT EIGENVALUES ..........
4281	60 IF (EN .LT. LOW) GO TO 1001
4282	ITS = 0
4283	NA = EN - 1
4284	ENM2 = NA - 1
4285	C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
4286	C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
4287	70 DO 80 LL = LOW, EN
4288	L = EN + LOW - LL
4289	IF (L .EQ. LOW) GO TO 100
4290	S = DABS(H(L-1,L-1)) + DABS(H(L,L))
4291	IF (S .EQ. 0.0D0) S = NORM
4292	TST1 = S
4293	TST2 = TST1 + DABS(H(L,L-1))
4294	IF (TST2 .EQ. TST1) GO TO 100
4295	80 CONTINUE
4296	C .......... FORM SHIFT ..........
4297	100 X = H(EN,EN)
4298	IF (L .EQ. EN) GO TO 270
4299	Y = H(NA,NA)
4300	W = H(EN,NA) * H(NA,EN)
4301	IF (L .EQ. NA) GO TO 280
4302	IF (ITN .EQ. 0) GO TO 1000
4303	IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130
4304	C .......... FORM EXCEPTIONAL SHIFT ..........
4305	T = T + X
4306	C
4307	DO 120 I = LOW, EN
4308	120 H(I,I) = H(I,I) - X
4309	C
4310	S = DABS(H(EN,NA)) + DABS(H(NA,ENM2))
4311	X = 0.75D0 * S
4312	Y = X
4313	W = -0.4375D0 * S * S
4314	130 ITS = ITS + 1
4315	ITN = ITN - 1
4316	C .......... LOOK FOR TWO CONSECUTIVE SMALL
4317	C SUB-DIAGONAL ELEMENTS.
4318	C FOR M=EN-2 STEP -1 UNTIL L DO -- ..........
4319	DO 140 MM = L, ENM2
4320	M = ENM2 + L - MM
4321	ZZ = H(M,M)
4322	R = X - ZZ
4323	S = Y - ZZ
4324	P = (R * S - W) / H(M+1,M) + H(M,M+1)
4325	Q = H(M+1,M+1) - ZZ - R - S
4326	R = H(M+2,M+1)
4327	S = DABS(P) + DABS(Q) + DABS(R)
4328	P = P / S
4329	Q = Q / S
4330	R = R / S
4331	IF (M .EQ. L) GO TO 150
4332	TST1 = DABS(P)*(DABS(H(M-1,M-1)) + DABS(ZZ) + DABS(H(M+1,M+1)))
4333	TST2 = TST1 + DABS(H(M,M-1))*(DABS(Q) + DABS(R))
4334	IF (TST2 .EQ. TST1) GO TO 150
4335	140 CONTINUE
4336	C
4337	150 MP2 = M + 2
4338	C
4339	DO 160 I = MP2, EN
4340	H(I,I-2) = 0.0D0
4341	IF (I .EQ. MP2) GO TO 160
4342	H(I,I-3) = 0.0D0
4343	160 CONTINUE
4344	C .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND
4345	C COLUMNS M TO EN ..........
4346	DO 260 K = M, NA
4347	NOTLAS = K .NE. NA
4348	IF (K .EQ. M) GO TO 170
4349	P = H(K,K-1)
4350	Q = H(K+1,K-1)
4351	R = 0.0D0
4352	IF (NOTLAS) R = H(K+2,K-1)
4353	X = DABS(P) + DABS(Q) + DABS(R)
4354	IF (X .EQ. 0.0D0) GO TO 260
4355	P = P / X
4356	Q = Q / X
4357	R = R / X
4358	170 S = DSIGN(DSQRT(PP+QQ+R*R),P)
4359	IF (K .EQ. M) GO TO 180
4360	H(K,K-1) = -S * X
4361	GO TO 190
4362	180 IF (L .NE. M) H(K,K-1) = -H(K,K-1)
4363	190 P = P + S
4364	X = P / S
4365	Y = Q / S
4366	ZZ = R / S
4367	Q = Q / P
4368	R = R / P
4369	IF (NOTLAS) GO TO 225
4370	C .......... ROW MODIFICATION ..........
4371	DO 200 J = K, N
4372	P = H(K,J) + Q * H(K+1,J)
4373	H(K,J) = H(K,J) - P * X
4374	H(K+1,J) = H(K+1,J) - P * Y
4375	200 CONTINUE
4376	C
4377	J = MIN0(EN,K+3)
4378	C .......... COLUMN MODIFICATION ..........
4379	DO 210 I = 1, J
4380	P = X * H(I,K) + Y * H(I,K+1)
4381	H(I,K) = H(I,K) - P
4382	H(I,K+1) = H(I,K+1) - P * Q
4383	210 CONTINUE
4384	GO TO 255
4385	225 CONTINUE
4386	C .......... ROW MODIFICATION ..........
4387	DO 230 J = K, N
4388	P = H(K,J) + Q * H(K+1,J) + R * H(K+2,J)
4389	H(K,J) = H(K,J) - P * X
4390	H(K+1,J) = H(K+1,J) - P * Y
4391	H(K+2,J) = H(K+2,J) - P * ZZ
4392	230 CONTINUE
4393	C
4394	J = MIN0(EN,K+3)
4395	C .......... COLUMN MODIFICATION ..........
4396	DO 240 I = 1, J
4397	P = X * H(I,K) + Y * H(I,K+1) + ZZ * H(I,K+2)
4398	H(I,K) = H(I,K) - P
4399	H(I,K+1) = H(I,K+1) - P * Q
4400	H(I,K+2) = H(I,K+2) - P * R
4401	240 CONTINUE
4402	255 CONTINUE
4403	C
4404	260 CONTINUE
4405	C
4406	GO TO 70
4407	C .......... ONE ROOT FOUND ..........
4408	270 WR(EN) = X + T
4409	WI(EN) = 0.0D0
4410	EN = NA
4411	GO TO 60
4412	C .......... TWO ROOTS FOUND ..........
4413	280 P = (Y - X) / 2.0D0
4414	Q = P * P + W
4415	ZZ = DSQRT(DABS(Q))
4416	X = X + T
4417	IF (Q .LT. 0.0D0) GO TO 320
4418	C .......... REAL PAIR ..........
4419	ZZ = P + DSIGN(ZZ,P)
4420	WR(NA) = X + ZZ
4421	WR(EN) = WR(NA)
4422	IF (ZZ .NE. 0.0D0) WR(EN) = X - W / ZZ
4423	WI(NA) = 0.0D0
4424	WI(EN) = 0.0D0
4425	GO TO 330
4426	C .......... COMPLEX PAIR ..........
4427	320 WR(NA) = X + P
4428	WR(EN) = X + P
4429	WI(NA) = ZZ
4430	WI(EN) = -ZZ
4431	330 EN = ENM2
4432	GO TO 60
4433	C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
4434	C CONVERGED AFTER 30*N ITERATIONS ..........
4435	1000 IERR = EN
4436	1001 RETURN
4437	END
4438	SUBROUTINE HQR2(NM,N,LOW,IGH,H,WR,WI,Z,IERR)
4439	C
4440	INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NA,NM,NN,
4441	X IGH,ITN,ITS,LOW,MP2,ENM2,IERR
4442	DOUBLE PRECISION H(NM,N),WR(N),WI(N),Z(NM,N)
4443	DOUBLE PRECISION P,Q,R,S,T,W,X,Y,RA,SA,VI,VR,ZZ,NORM,TST1,TST2
4444	LOGICAL NOTLAS
4445	C
4446	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR2,
4447	C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON.
4448	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
4449	C
4450	C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
4451	C OF A REAL UPPER HESSENBERG MATRIX BY THE QR METHOD. THE
4452	C EIGENVECTORS OF A REAL GENERAL MATRIX CAN ALSO BE FOUND
4453	C IF ELMHES AND ELTRAN OR ORTHES AND ORTRAN HAVE
4454	C BEEN USED TO REDUCE THIS GENERAL MATRIX TO HESSENBERG FORM
4455	C AND TO ACCUMULATE THE SIMILARITY TRANSFORMATIONS.
4456	C
4457	C ON INPUT
4458	C
4459	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
4460	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
4461	C DIMENSION STATEMENT.
4462	C
4463	C N IS THE ORDER OF THE MATRIX.
4464	C
4465	C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
4466	C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED,
4467	C SET LOW=1, IGH=N.
4468	C
4469	C H CONTAINS THE UPPER HESSENBERG MATRIX.
4470	C
4471	C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED BY ELTRAN
4472	C AFTER THE REDUCTION BY ELMHES, OR BY ORTRAN AFTER THE
4473	C REDUCTION BY ORTHES, IF PERFORMED. IF THE EIGENVECTORS
4474	C OF THE HESSENBERG MATRIX ARE DESIRED, Z MUST CONTAIN THE
4475	C IDENTITY MATRIX.
4476	C
4477	C ON OUTPUT
4478	C
4479	C H HAS BEEN DESTROYED.
4480	C
4481	C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
4482	C RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES
4483	C ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS
4484	C OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE
4485	C HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN
4486	C ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
4487	C FOR INDICES IERR+1,...,N.
4488	C
4489	C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS.
4490	C IF THE I-TH EIGENVALUE IS REAL, THE I-TH COLUMN OF Z
4491	C CONTAINS ITS EIGENVECTOR. IF THE I-TH EIGENVALUE IS COMPLEX
4492	C WITH POSITIVE IMAGINARY PART, THE I-TH AND (I+1)-TH
4493	C COLUMNS OF Z CONTAIN THE REAL AND IMAGINARY PARTS OF ITS
4494	C EIGENVECTOR. THE EIGENVECTORS ARE UNNORMALIZED. IF AN
4495	C ERROR EXIT IS MADE, NONE OF THE EIGENVECTORS HAS BEEN FOUND.
4496	C
4497	C IERR IS SET TO
4498	C ZERO FOR NORMAL RETURN,
4499	C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
4500	C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
4501	C
4502	C CALLS CDIV FOR COMPLEX DIVISION.
4503	C
4504	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
4505	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
4506	C
4507	C THIS VERSION DATED AUGUST 1983.
4508	C
4509	C ------------------------------------------------------------------
4510	C
4511	IERR = 0
4512	NORM = 0.0D0
4513	K = 1
4514	C .......... STORE ROOTS ISOLATED BY BALANC
4515	C AND COMPUTE MATRIX NORM ..........
4516	DO 50 I = 1, N
4517	C
4518	DO 40 J = K, N
4519	40 NORM = NORM + DABS(H(I,J))
4520	C
4521	K = I
4522	IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50
4523	WR(I) = H(I,I)
4524	WI(I) = 0.0D0
4525	50 CONTINUE
4526	C
4527	EN = IGH
4528	T = 0.0D0
4529	ITN = 30*N
4530	C .......... SEARCH FOR NEXT EIGENVALUES ..........
4531	60 IF (EN .LT. LOW) GO TO 340
4532	ITS = 0
4533	NA = EN - 1
4534	ENM2 = NA - 1
4535	C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
4536	C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
4537	70 DO 80 LL = LOW, EN
4538	L = EN + LOW - LL
4539	IF (L .EQ. LOW) GO TO 100
4540	S = DABS(H(L-1,L-1)) + DABS(H(L,L))
4541	IF (S .EQ. 0.0D0) S = NORM
4542	TST1 = S
4543	TST2 = TST1 + DABS(H(L,L-1))
4544	IF (TST2 .EQ. TST1) GO TO 100
4545	80 CONTINUE
4546	C .......... FORM SHIFT ..........
4547	100 X = H(EN,EN)
4548	IF (L .EQ. EN) GO TO 270
4549	Y = H(NA,NA)
4550	W = H(EN,NA) * H(NA,EN)
4551	IF (L .EQ. NA) GO TO 280
4552	IF (ITN .EQ. 0) GO TO 1000
4553	IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130
4554	C .......... FORM EXCEPTIONAL SHIFT ..........
4555	T = T + X
4556	C
4557	DO 120 I = LOW, EN
4558	120 H(I,I) = H(I,I) - X
4559	C
4560	S = DABS(H(EN,NA)) + DABS(H(NA,ENM2))
4561	X = 0.75D0 * S
4562	Y = X
4563	W = -0.4375D0 * S * S
4564	130 ITS = ITS + 1
4565	ITN = ITN - 1
4566	C .......... LOOK FOR TWO CONSECUTIVE SMALL
4567	C SUB-DIAGONAL ELEMENTS.
4568	C FOR M=EN-2 STEP -1 UNTIL L DO -- ..........
4569	DO 140 MM = L, ENM2
4570	M = ENM2 + L - MM
4571	ZZ = H(M,M)
4572	R = X - ZZ
4573	S = Y - ZZ
4574	P = (R * S - W) / H(M+1,M) + H(M,M+1)
4575	Q = H(M+1,M+1) - ZZ - R - S
4576	R = H(M+2,M+1)
4577	S = DABS(P) + DABS(Q) + DABS(R)
4578	P = P / S
4579	Q = Q / S
4580	R = R / S
4581	IF (M .EQ. L) GO TO 150
4582	TST1 = DABS(P)*(DABS(H(M-1,M-1)) + DABS(ZZ) + DABS(H(M+1,M+1)))
4583	TST2 = TST1 + DABS(H(M,M-1))*(DABS(Q) + DABS(R))
4584	IF (TST2 .EQ. TST1) GO TO 150
4585	140 CONTINUE
4586	C
4587	150 MP2 = M + 2
4588	C
4589	DO 160 I = MP2, EN
4590	H(I,I-2) = 0.0D0
4591	IF (I .EQ. MP2) GO TO 160
4592	H(I,I-3) = 0.0D0
4593	160 CONTINUE
4594	C .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND
4595	C COLUMNS M TO EN ..........
4596	DO 260 K = M, NA
4597	NOTLAS = K .NE. NA
4598	IF (K .EQ. M) GO TO 170
4599	P = H(K,K-1)
4600	Q = H(K+1,K-1)
4601	R = 0.0D0
4602	IF (NOTLAS) R = H(K+2,K-1)
4603	X = DABS(P) + DABS(Q) + DABS(R)
4604	IF (X .EQ. 0.0D0) GO TO 260
4605	P = P / X
4606	Q = Q / X
4607	R = R / X
4608	170 S = DSIGN(DSQRT(PP+QQ+R*R),P)
4609	IF (K .EQ. M) GO TO 180
4610	H(K,K-1) = -S * X
4611	GO TO 190
4612	180 IF (L .NE. M) H(K,K-1) = -H(K,K-1)
4613	190 P = P + S
4614	X = P / S
4615	Y = Q / S
4616	ZZ = R / S
4617	Q = Q / P
4618	R = R / P
4619	IF (NOTLAS) GO TO 225
4620	C .......... ROW MODIFICATION ..........
4621	DO 200 J = K, N
4622	P = H(K,J) + Q * H(K+1,J)
4623	H(K,J) = H(K,J) - P * X
4624	H(K+1,J) = H(K+1,J) - P * Y
4625	200 CONTINUE
4626	C
4627	J = MIN0(EN,K+3)
4628	C .......... COLUMN MODIFICATION ..........
4629	DO 210 I = 1, J
4630	P = X * H(I,K) + Y * H(I,K+1)
4631	H(I,K) = H(I,K) - P
4632	H(I,K+1) = H(I,K+1) - P * Q
4633	210 CONTINUE
4634	C .......... ACCUMULATE TRANSFORMATIONS ..........
4635	DO 220 I = LOW, IGH
4636	P = X * Z(I,K) + Y * Z(I,K+1)
4637	Z(I,K) = Z(I,K) - P
4638	Z(I,K+1) = Z(I,K+1) - P * Q
4639	220 CONTINUE
4640	GO TO 255
4641	225 CONTINUE
4642	C .......... ROW MODIFICATION ..........
4643	DO 230 J = K, N
4644	P = H(K,J) + Q * H(K+1,J) + R * H(K+2,J)
4645	H(K,J) = H(K,J) - P * X
4646	H(K+1,J) = H(K+1,J) - P * Y
4647	H(K+2,J) = H(K+2,J) - P * ZZ
4648	230 CONTINUE
4649	C
4650	J = MIN0(EN,K+3)
4651	C .......... COLUMN MODIFICATION ..........
4652	DO 240 I = 1, J
4653	P = X * H(I,K) + Y * H(I,K+1) + ZZ * H(I,K+2)
4654	H(I,K) = H(I,K) - P
4655	H(I,K+1) = H(I,K+1) - P * Q
4656	H(I,K+2) = H(I,K+2) - P * R
4657	240 CONTINUE
4658	C .......... ACCUMULATE TRANSFORMATIONS ..........
4659	DO 250 I = LOW, IGH
4660	P = X * Z(I,K) + Y * Z(I,K+1) + ZZ * Z(I,K+2)
4661	Z(I,K) = Z(I,K) - P
4662	Z(I,K+1) = Z(I,K+1) - P * Q
4663	Z(I,K+2) = Z(I,K+2) - P * R
4664	250 CONTINUE
4665	255 CONTINUE
4666	C
4667	260 CONTINUE
4668	C
4669	GO TO 70
4670	C .......... ONE ROOT FOUND ..........
4671	270 H(EN,EN) = X + T
4672	WR(EN) = H(EN,EN)
4673	WI(EN) = 0.0D0
4674	EN = NA
4675	GO TO 60
4676	C .......... TWO ROOTS FOUND ..........
4677	280 P = (Y - X) / 2.0D0
4678	Q = P * P + W
4679	ZZ = DSQRT(DABS(Q))
4680	H(EN,EN) = X + T
4681	X = H(EN,EN)
4682	H(NA,NA) = Y + T
4683	IF (Q .LT. 0.0D0) GO TO 320
4684	C .......... REAL PAIR ..........
4685	ZZ = P + DSIGN(ZZ,P)
4686	WR(NA) = X + ZZ
4687	WR(EN) = WR(NA)
4688	IF (ZZ .NE. 0.0D0) WR(EN) = X - W / ZZ
4689	WI(NA) = 0.0D0
4690	WI(EN) = 0.0D0
4691	X = H(EN,NA)
4692	S = DABS(X) + DABS(ZZ)
4693	P = X / S
4694	Q = ZZ / S
4695	R = DSQRT(PP+QQ)
4696	P = P / R
4697	Q = Q / R
4698	C .......... ROW MODIFICATION ..........
4699	DO 290 J = NA, N
4700	ZZ = H(NA,J)
4701	H(NA,J) = Q * ZZ + P * H(EN,J)
4702	H(EN,J) = Q * H(EN,J) - P * ZZ
4703	290 CONTINUE
4704	C .......... COLUMN MODIFICATION ..........
4705	DO 300 I = 1, EN
4706	ZZ = H(I,NA)
4707	H(I,NA) = Q * ZZ + P * H(I,EN)
4708	H(I,EN) = Q * H(I,EN) - P * ZZ
4709	300 CONTINUE
4710	C .......... ACCUMULATE TRANSFORMATIONS ..........
4711	DO 310 I = LOW, IGH
4712	ZZ = Z(I,NA)
4713	Z(I,NA) = Q * ZZ + P * Z(I,EN)
4714	Z(I,EN) = Q * Z(I,EN) - P * ZZ
4715	310 CONTINUE
4716	C
4717	GO TO 330
4718	C .......... COMPLEX PAIR ..........
4719	320 WR(NA) = X + P
4720	WR(EN) = X + P
4721	WI(NA) = ZZ
4722	WI(EN) = -ZZ
4723	330 EN = ENM2
4724	GO TO 60
4725	C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
4726	C VECTORS OF UPPER TRIANGULAR FORM ..........
4727	340 IF (NORM .EQ. 0.0D0) GO TO 1001
4728	C .......... FOR EN=N STEP -1 UNTIL 1 DO -- ..........
4729	DO 800 NN = 1, N
4730	EN = N + 1 - NN
4731	P = WR(EN)
4732	Q = WI(EN)
4733	NA = EN - 1
4734	IF (Q) 710, 600, 800
4735	C .......... REAL VECTOR ..........
4736	600 M = EN
4737	H(EN,EN) = 1.0D0
4738	IF (NA .EQ. 0) GO TO 800
4739	C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
4740	DO 700 II = 1, NA
4741	I = EN - II
4742	W = H(I,I) - P
4743	R = 0.0D0
4744	C
4745	DO 610 J = M, EN
4746	610 R = R + H(I,J) * H(J,EN)
4747	C
4748	IF (WI(I) .GE. 0.0D0) GO TO 630
4749	ZZ = W
4750	S = R
4751	GO TO 700
4752	630 M = I
4753	IF (WI(I) .NE. 0.0D0) GO TO 640
4754	T = W
4755	IF (T .NE. 0.0D0) GO TO 635
4756	TST1 = NORM
4757	T = TST1
4758	632 T = 0.01D0 * T
4759	TST2 = NORM + T
4760	IF (TST2 .GT. TST1) GO TO 632
4761	635 H(I,EN) = -R / T
4762	GO TO 680
4763	C .......... SOLVE REAL EQUATIONS ..........
4764	640 X = H(I,I+1)
4765	Y = H(I+1,I)
4766	Q = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I)
4767	T = (X * S - ZZ * R) / Q
4768	H(I,EN) = T
4769	IF (DABS(X) .LE. DABS(ZZ)) GO TO 650
4770	H(I+1,EN) = (-R - W * T) / X
4771	GO TO 680
4772	650 H(I+1,EN) = (-S - Y * T) / ZZ
4773	C
4774	C .......... OVERFLOW CONTROL ..........
4775	680 T = DABS(H(I,EN))
4776	IF (T .EQ. 0.0D0) GO TO 700
4777	TST1 = T
4778	TST2 = TST1 + 1.0D0/TST1
4779	IF (TST2 .GT. TST1) GO TO 700
4780	DO 690 J = I, EN
4781	H(J,EN) = H(J,EN)/T
4782	690 CONTINUE
4783	C
4784	700 CONTINUE
4785	C .......... END REAL VECTOR ..........
4786	GO TO 800
4787	C .......... COMPLEX VECTOR ..........
4788	710 M = NA
4789	C .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT
4790	C EIGENVECTOR MATRIX IS TRIANGULAR ..........
4791	IF (DABS(H(EN,NA)) .LE. DABS(H(NA,EN))) GO TO 720
4792	H(NA,NA) = Q / H(EN,NA)
4793	H(NA,EN) = -(H(EN,EN) - P) / H(EN,NA)
4794	GO TO 730
4795	720 CALL CDIV(0.0D0,-H(NA,EN),H(NA,NA)-P,Q,H(NA,NA),H(NA,EN))
4796	730 H(EN,NA) = 0.0D0
4797	H(EN,EN) = 1.0D0
4798	ENM2 = NA - 1
4799	IF (ENM2 .EQ. 0) GO TO 800
4800	C .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- ..........
4801	DO 795 II = 1, ENM2
4802	I = NA - II
4803	W = H(I,I) - P
4804	RA = 0.0D0
4805	SA = 0.0D0
4806	C
4807	DO 760 J = M, EN
4808	RA = RA + H(I,J) * H(J,NA)
4809	SA = SA + H(I,J) * H(J,EN)
4810	760 CONTINUE
4811	C
4812	IF (WI(I) .GE. 0.0D0) GO TO 770
4813	ZZ = W
4814	R = RA
4815	S = SA
4816	GO TO 795
4817	770 M = I
4818	IF (WI(I) .NE. 0.0D0) GO TO 780
4819	CALL CDIV(-RA,-SA,W,Q,H(I,NA),H(I,EN))
4820	GO TO 790
4821	C .......... SOLVE COMPLEX EQUATIONS ..........
4822	780 X = H(I,I+1)
4823	Y = H(I+1,I)
4824	VR = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) - Q * Q
4825	VI = (WR(I) - P) * 2.0D0 * Q
4826	IF (VR .NE. 0.0D0 .OR. VI .NE. 0.0D0) GO TO 784
4827	TST1 = NORM * (DABS(W) + DABS(Q) + DABS(X)
4828	X + DABS(Y) + DABS(ZZ))
4829	VR = TST1
4830	783 VR = 0.01D0 * VR
4831	TST2 = TST1 + VR
4832	IF (TST2 .GT. TST1) GO TO 783
4833	784 CALL CDIV(XR-ZZRA+QSA,XS-ZZSA-QRA,VR,VI,
4834	X H(I,NA),H(I,EN))
4835	IF (DABS(X) .LE. DABS(ZZ) + DABS(Q)) GO TO 785
4836	H(I+1,NA) = (-RA - W * H(I,NA) + Q * H(I,EN)) / X
4837	H(I+1,EN) = (-SA - W * H(I,EN) - Q * H(I,NA)) / X
4838	GO TO 790
4839	785 CALL CDIV(-R-YH(I,NA),-S-YH(I,EN),ZZ,Q,
4840	X H(I+1,NA),H(I+1,EN))
4841	C
4842	C .......... OVERFLOW CONTROL ..........
4843	790 T = DMAX1(DABS(H(I,NA)), DABS(H(I,EN)))
4844	IF (T .EQ. 0.0D0) GO TO 795
4845	TST1 = T
4846	TST2 = TST1 + 1.0D0/TST1
4847	IF (TST2 .GT. TST1) GO TO 795
4848	DO 792 J = I, EN
4849	H(J,NA) = H(J,NA)/T
4850	H(J,EN) = H(J,EN)/T
4851	792 CONTINUE
4852	C
4853	795 CONTINUE
4854	C .......... END COMPLEX VECTOR ..........
4855	800 CONTINUE
4856	C .......... END BACK SUBSTITUTION.
4857	C VECTORS OF ISOLATED ROOTS ..........
4858	DO 840 I = 1, N
4859	IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840
4860	C
4861	DO 820 J = I, N
4862	820 Z(I,J) = H(I,J)
4863	C
4864	840 CONTINUE
4865	C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
4866	C VECTORS OF ORIGINAL FULL MATRIX.
4867	C FOR J=N STEP -1 UNTIL LOW DO -- ..........
4868	DO 880 JJ = LOW, N
4869	J = N + LOW - JJ
4870	M = MIN0(J,IGH)
4871	C
4872	DO 880 I = LOW, IGH
4873	ZZ = 0.0D0
4874	C
4875	DO 860 K = LOW, M
4876	860 ZZ = ZZ + Z(I,K) * H(K,J)
4877	C
4878	Z(I,J) = ZZ
4879	880 CONTINUE
4880	C
4881	GO TO 1001
4882	C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
4883	C CONVERGED AFTER 30*N ITERATIONS ..........
4884	1000 IERR = EN
4885	1001 RETURN
4886	END
4887	SUBROUTINE HTRIB3(NM,N,A,TAU,M,ZR,ZI)
4888	C
4889	INTEGER I,J,K,L,M,N,NM
4890	DOUBLE PRECISION A(NM,N),TAU(2,N),ZR(NM,M),ZI(NM,M)
4891	DOUBLE PRECISION H,S,SI
4892	C
4893	C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
4894	C THE ALGOL PROCEDURE TRBAK3, NUM. MATH. 11, 181-195(1968)
4895	C BY MARTIN, REINSCH, AND WILKINSON.
4896	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
4897	C
4898	C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX HERMITIAN
4899	C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
4900	C REAL SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY HTRID3.
4901	C
4902	C ON INPUT
4903	C
4904	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
4905	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
4906	C DIMENSION STATEMENT.
4907	C
4908	C N IS THE ORDER OF THE MATRIX.
4909	C
4910	C A CONTAINS INFORMATION ABOUT THE UNITARY TRANSFORMATIONS
4911	C USED IN THE REDUCTION BY HTRID3.
4912	C
4913	C TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS.
4914	C
4915	C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
4916	C
4917	C ZR CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED
4918	C IN ITS FIRST M COLUMNS.
4919	C
4920	C ON OUTPUT
4921	C
4922	C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
4923	C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
4924	C IN THEIR FIRST M COLUMNS.
4925	C
4926	C NOTE THAT THE LAST COMPONENT OF EACH RETURNED VECTOR
4927	C IS REAL AND THAT VECTOR EUCLIDEAN NORMS ARE PRESERVED.
4928	C
4929	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
4930	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
4931	C
4932	C THIS VERSION DATED AUGUST 1983.
4933	C
4934	C ------------------------------------------------------------------
4935	C
4936	IF (M .EQ. 0) GO TO 200
4937	C .......... TRANSFORM THE EIGENVECTORS OF THE REAL SYMMETRIC
4938	C TRIDIAGONAL MATRIX TO THOSE OF THE HERMITIAN
4939	C TRIDIAGONAL MATRIX. ..........
4940	DO 50 K = 1, N
4941	C
4942	DO 50 J = 1, M
4943	ZI(K,J) = -ZR(K,J) * TAU(2,K)
4944	ZR(K,J) = ZR(K,J) * TAU(1,K)
4945	50 CONTINUE
4946	C
4947	IF (N .EQ. 1) GO TO 200
4948	C .......... RECOVER AND APPLY THE HOUSEHOLDER MATRICES ..........
4949	DO 140 I = 2, N
4950	L = I - 1
4951	H = A(I,I)
4952	IF (H .EQ. 0.0D0) GO TO 140
4953	C
4954	DO 130 J = 1, M
4955	S = 0.0D0
4956	SI = 0.0D0
4957	C
4958	DO 110 K = 1, L
4959	S = S + A(I,K) * ZR(K,J) - A(K,I) * ZI(K,J)
4960	SI = SI + A(I,K) * ZI(K,J) + A(K,I) * ZR(K,J)
4961	110 CONTINUE
4962	C .......... DOUBLE DIVISIONS AVOID POSSIBLE UNDERFLOW ..........
4963	S = (S / H) / H
4964	SI = (SI / H) / H
4965	C
4966	DO 120 K = 1, L
4967	ZR(K,J) = ZR(K,J) - S * A(I,K) - SI * A(K,I)
4968	ZI(K,J) = ZI(K,J) - SI * A(I,K) + S * A(K,I)
4969	120 CONTINUE
4970	C
4971	130 CONTINUE
4972	C
4973	140 CONTINUE
4974	C
4975	200 RETURN
4976	END
4977	SUBROUTINE HTRIBK(NM,N,AR,AI,TAU,M,ZR,ZI)
4978	C
4979	INTEGER I,J,K,L,M,N,NM
4980	DOUBLE PRECISION AR(NM,N),AI(NM,N),TAU(2,N),ZR(NM,M),ZI(NM,M)
4981	DOUBLE PRECISION H,S,SI
4982	C
4983	C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
4984	C THE ALGOL PROCEDURE TRBAK1, NUM. MATH. 11, 181-195(1968)
4985	C BY MARTIN, REINSCH, AND WILKINSON.
4986	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
4987	C
4988	C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX HERMITIAN
4989	C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
4990	C REAL SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY HTRIDI.
4991	C
4992	C ON INPUT
4993	C
4994	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
4995	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
4996	C DIMENSION STATEMENT.
4997	C
4998	C N IS THE ORDER OF THE MATRIX.
4999	C
5000	C AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
5001	C FORMATIONS USED IN THE REDUCTION BY HTRIDI IN THEIR
5002	C FULL LOWER TRIANGLES EXCEPT FOR THE DIAGONAL OF AR.
5003	C
5004	C TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS.
5005	C
5006	C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
5007	C
5008	C ZR CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED
5009	C IN ITS FIRST M COLUMNS.
5010	C
5011	C ON OUTPUT
5012	C
5013	C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
5014	C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
5015	C IN THEIR FIRST M COLUMNS.
5016	C
5017	C NOTE THAT THE LAST COMPONENT OF EACH RETURNED VECTOR
5018	C IS REAL AND THAT VECTOR EUCLIDEAN NORMS ARE PRESERVED.
5019	C
5020	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
5021	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
5022	C
5023	C THIS VERSION DATED AUGUST 1983.
5024	C
5025	C ------------------------------------------------------------------
5026	C
5027	IF (M .EQ. 0) GO TO 200
5028	C .......... TRANSFORM THE EIGENVECTORS OF THE REAL SYMMETRIC
5029	C TRIDIAGONAL MATRIX TO THOSE OF THE HERMITIAN
5030	C TRIDIAGONAL MATRIX. ..........
5031	DO 50 K = 1, N
5032	C
5033	DO 50 J = 1, M
5034	ZI(K,J) = -ZR(K,J) * TAU(2,K)
5035	ZR(K,J) = ZR(K,J) * TAU(1,K)
5036	50 CONTINUE
5037	C
5038	IF (N .EQ. 1) GO TO 200
5039	C .......... RECOVER AND APPLY THE HOUSEHOLDER MATRICES ..........
5040	DO 140 I = 2, N
5041	L = I - 1
5042	H = AI(I,I)
5043	IF (H .EQ. 0.0D0) GO TO 140
5044	C
5045	DO 130 J = 1, M
5046	S = 0.0D0
5047	SI = 0.0D0
5048	C
5049	DO 110 K = 1, L
5050	S = S + AR(I,K) * ZR(K,J) - AI(I,K) * ZI(K,J)
5051	SI = SI + AR(I,K) * ZI(K,J) + AI(I,K) * ZR(K,J)
5052	110 CONTINUE
5053	C .......... DOUBLE DIVISIONS AVOID POSSIBLE UNDERFLOW ..........
5054	S = (S / H) / H
5055	SI = (SI / H) / H
5056	C
5057	DO 120 K = 1, L
5058	ZR(K,J) = ZR(K,J) - S * AR(I,K) - SI * AI(I,K)
5059	ZI(K,J) = ZI(K,J) - SI * AR(I,K) + S * AI(I,K)
5060	120 CONTINUE
5061	C
5062	130 CONTINUE
5063	C
5064	140 CONTINUE
5065	C
5066	200 RETURN
5067	END
5068	SUBROUTINE HTRID3(NM,N,A,D,E,E2,TAU)
5069	C
5070	INTEGER I,J,K,L,N,II,NM,JM1,JP1
5071	DOUBLE PRECISION A(NM,N),D(N),E(N),E2(N),TAU(2,N)
5072	DOUBLE PRECISION F,G,H,FI,GI,HH,SI,SCALE,PYTHAG
5073	C
5074	C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
5075	C THE ALGOL PROCEDURE TRED3, NUM. MATH. 11, 181-195(1968)
5076	C BY MARTIN, REINSCH, AND WILKINSON.
5077	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
5078	C
5079	C THIS SUBROUTINE REDUCES A COMPLEX HERMITIAN MATRIX, STORED AS
5080	C A SINGLE SQUARE ARRAY, TO A REAL SYMMETRIC TRIDIAGONAL MATRIX
5081	C USING UNITARY SIMILARITY TRANSFORMATIONS.
5082	C
5083	C ON INPUT
5084	C
5085	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
5086	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
5087	C DIMENSION STATEMENT.
5088	C
5089	C N IS THE ORDER OF THE MATRIX.
5090	C
5091	C A CONTAINS THE LOWER TRIANGLE OF THE COMPLEX HERMITIAN INPUT
5092	C MATRIX. THE REAL PARTS OF THE MATRIX ELEMENTS ARE STORED
5093	C IN THE FULL LOWER TRIANGLE OF A, AND THE IMAGINARY PARTS
5094	C ARE STORED IN THE TRANSPOSED POSITIONS OF THE STRICT UPPER
5095	C TRIANGLE OF A. NO STORAGE IS REQUIRED FOR THE ZERO
5096	C IMAGINARY PARTS OF THE DIAGONAL ELEMENTS.
5097	C
5098	C ON OUTPUT
5099	C
5100	C A CONTAINS INFORMATION ABOUT THE UNITARY TRANSFORMATIONS
5101	C USED IN THE REDUCTION.
5102	C
5103	C D CONTAINS THE DIAGONAL ELEMENTS OF THE THE TRIDIAGONAL MATRIX.
5104	C
5105	C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
5106	C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO.
5107	C
5108	C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
5109	C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
5110	C
5111	C TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS.
5112	C
5113	C CALLS PYTHAG FOR DSQRT(AA + BB) .
5114	C
5115	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
5116	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
5117	C
5118	C THIS VERSION DATED AUGUST 1983.
5119	C
5120	C ------------------------------------------------------------------
5121	C
5122	TAU(1,N) = 1.0D0
5123	TAU(2,N) = 0.0D0
5124	C .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
5125	DO 300 II = 1, N
5126	I = N + 1 - II
5127	L = I - 1
5128	H = 0.0D0
5129	SCALE = 0.0D0
5130	IF (L .LT. 1) GO TO 130
5131	C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) ..........
5132	DO 120 K = 1, L
5133	120 SCALE = SCALE + DABS(A(I,K)) + DABS(A(K,I))
5134	C
5135	IF (SCALE .NE. 0.0D0) GO TO 140
5136	TAU(1,L) = 1.0D0
5137	TAU(2,L) = 0.0D0
5138	130 E(I) = 0.0D0
5139	E2(I) = 0.0D0
5140	GO TO 290
5141	C
5142	140 DO 150 K = 1, L
5143	A(I,K) = A(I,K) / SCALE
5144	A(K,I) = A(K,I) / SCALE
5145	H = H + A(I,K) * A(I,K) + A(K,I) * A(K,I)
5146	150 CONTINUE
5147	C
5148	E2(I) = SCALE * SCALE * H
5149	G = DSQRT(H)
5150	E(I) = SCALE * G
5151	F = PYTHAG(A(I,L),A(L,I))
5152	C .......... FORM NEXT DIAGONAL ELEMENT OF MATRIX T ..........
5153	IF (F .EQ. 0.0D0) GO TO 160
5154	TAU(1,L) = (A(L,I) * TAU(2,I) - A(I,L) * TAU(1,I)) / F
5155	SI = (A(I,L) * TAU(2,I) + A(L,I) * TAU(1,I)) / F
5156	H = H + F * G
5157	G = 1.0D0 + G / F
5158	A(I,L) = G * A(I,L)
5159	A(L,I) = G * A(L,I)
5160	IF (L .EQ. 1) GO TO 270
5161	GO TO 170
5162	160 TAU(1,L) = -TAU(1,I)
5163	SI = TAU(2,I)
5164	A(I,L) = G
5165	170 F = 0.0D0
5166	C
5167	DO 240 J = 1, L
5168	G = 0.0D0
5169	GI = 0.0D0
5170	IF (J .EQ. 1) GO TO 190
5171	JM1 = J - 1
5172	C .......... FORM ELEMENT OF A*U ..........
5173	DO 180 K = 1, JM1
5174	G = G + A(J,K) * A(I,K) + A(K,J) * A(K,I)
5175	GI = GI - A(J,K) * A(K,I) + A(K,J) * A(I,K)
5176	180 CONTINUE
5177	C
5178	190 G = G + A(J,J) * A(I,J)
5179	GI = GI - A(J,J) * A(J,I)
5180	JP1 = J + 1
5181	IF (L .LT. JP1) GO TO 220
5182	C
5183	DO 200 K = JP1, L
5184	G = G + A(K,J) * A(I,K) - A(J,K) * A(K,I)
5185	GI = GI - A(K,J) * A(K,I) - A(J,K) * A(I,K)
5186	200 CONTINUE
5187	C .......... FORM ELEMENT OF P ..........
5188	220 E(J) = G / H
5189	TAU(2,J) = GI / H
5190	F = F + E(J) * A(I,J) - TAU(2,J) * A(J,I)
5191	240 CONTINUE
5192	C
5193	HH = F / (H + H)
5194	C .......... FORM REDUCED A ..........
5195	DO 260 J = 1, L
5196	F = A(I,J)
5197	G = E(J) - HH * F
5198	E(J) = G
5199	FI = -A(J,I)
5200	GI = TAU(2,J) - HH * FI
5201	TAU(2,J) = -GI
5202	A(J,J) = A(J,J) - 2.0D0 * (F * G + FI * GI)
5203	IF (J .EQ. 1) GO TO 260
5204	JM1 = J - 1
5205	C
5206	DO 250 K = 1, JM1
5207	A(J,K) = A(J,K) - F * E(K) - G * A(I,K)
5208	X + FI * TAU(2,K) + GI * A(K,I)
5209	A(K,J) = A(K,J) - F * TAU(2,K) - G * A(K,I)
5210	X - FI * E(K) - GI * A(I,K)
5211	250 CONTINUE
5212	C
5213	260 CONTINUE
5214	C
5215	270 DO 280 K = 1, L
5216	A(I,K) = SCALE * A(I,K)
5217	A(K,I) = SCALE * A(K,I)
5218	280 CONTINUE
5219	C
5220	TAU(2,L) = -SI
5221	290 D(I) = A(I,I)
5222	A(I,I) = SCALE * DSQRT(H)
5223	300 CONTINUE
5224	C
5225	RETURN
5226	END
5227	SUBROUTINE HTRIDI(NM,N,AR,AI,D,E,E2,TAU)
5228	C
5229	INTEGER I,J,K,L,N,II,NM,JP1
5230	DOUBLE PRECISION AR(NM,N),AI(NM,N),D(N),E(N),E2(N),TAU(2,N)
5231	DOUBLE PRECISION F,G,H,FI,GI,HH,SI,SCALE,PYTHAG
5232	C
5233	C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
5234	C THE ALGOL PROCEDURE TRED1, NUM. MATH. 11, 181-195(1968)
5235	C BY MARTIN, REINSCH, AND WILKINSON.
5236	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
5237	C
5238	C THIS SUBROUTINE REDUCES A COMPLEX HERMITIAN MATRIX
5239	C TO A REAL SYMMETRIC TRIDIAGONAL MATRIX USING
5240	C UNITARY SIMILARITY TRANSFORMATIONS.
5241	C
5242	C ON INPUT
5243	C
5244	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
5245	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
5246	C DIMENSION STATEMENT.
5247	C
5248	C N IS THE ORDER OF THE MATRIX.
5249	C
5250	C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
5251	C RESPECTIVELY, OF THE COMPLEX HERMITIAN INPUT MATRIX.
5252	C ONLY THE LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED.
5253	C
5254	C ON OUTPUT
5255	C
5256	C AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
5257	C FORMATIONS USED IN THE REDUCTION IN THEIR FULL LOWER
5258	C TRIANGLES. THEIR STRICT UPPER TRIANGLES AND THE
5259	C DIAGONAL OF AR ARE UNALTERED.
5260	C
5261	C D CONTAINS THE DIAGONAL ELEMENTS OF THE THE TRIDIAGONAL MATRIX.
5262	C
5263	C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
5264	C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO.
5265	C
5266	C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
5267	C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
5268	C
5269	C TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS.
5270	C
5271	C CALLS PYTHAG FOR DSQRT(AA + BB) .
5272	C
5273	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
5274	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
5275	C
5276	C THIS VERSION DATED AUGUST 1983.
5277	C
5278	C ------------------------------------------------------------------
5279	C
5280	TAU(1,N) = 1.0D0
5281	TAU(2,N) = 0.0D0
5282	C
5283	DO 100 I = 1, N
5284	100 D(I) = AR(I,I)
5285	C .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
5286	DO 300 II = 1, N
5287	I = N + 1 - II
5288	L = I - 1
5289	H = 0.0D0
5290	SCALE = 0.0D0
5291	IF (L .LT. 1) GO TO 130
5292	C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) ..........
5293	DO 120 K = 1, L
5294	120 SCALE = SCALE + DABS(AR(I,K)) + DABS(AI(I,K))
5295	C
5296	IF (SCALE .NE. 0.0D0) GO TO 140
5297	TAU(1,L) = 1.0D0
5298	TAU(2,L) = 0.0D0
5299	130 E(I) = 0.0D0
5300	E2(I) = 0.0D0
5301	GO TO 290
5302	C
5303	140 DO 150 K = 1, L
5304	AR(I,K) = AR(I,K) / SCALE
5305	AI(I,K) = AI(I,K) / SCALE
5306	H = H + AR(I,K) * AR(I,K) + AI(I,K) * AI(I,K)
5307	150 CONTINUE
5308	C
5309	E2(I) = SCALE * SCALE * H
5310	G = DSQRT(H)
5311	E(I) = SCALE * G
5312	F = PYTHAG(AR(I,L),AI(I,L))
5313	C .......... FORM NEXT DIAGONAL ELEMENT OF MATRIX T ..........
5314	IF (F .EQ. 0.0D0) GO TO 160
5315	TAU(1,L) = (AI(I,L) * TAU(2,I) - AR(I,L) * TAU(1,I)) / F
5316	SI = (AR(I,L) * TAU(2,I) + AI(I,L) * TAU(1,I)) / F
5317	H = H + F * G
5318	G = 1.0D0 + G / F
5319	AR(I,L) = G * AR(I,L)
5320	AI(I,L) = G * AI(I,L)
5321	IF (L .EQ. 1) GO TO 270
5322	GO TO 170
5323	160 TAU(1,L) = -TAU(1,I)
5324	SI = TAU(2,I)
5325	AR(I,L) = G
5326	170 F = 0.0D0
5327	C
5328	DO 240 J = 1, L
5329	G = 0.0D0
5330	GI = 0.0D0
5331	C .......... FORM ELEMENT OF A*U ..........
5332	DO 180 K = 1, J
5333	G = G + AR(J,K) * AR(I,K) + AI(J,K) * AI(I,K)
5334	GI = GI - AR(J,K) * AI(I,K) + AI(J,K) * AR(I,K)
5335	180 CONTINUE
5336	C
5337	JP1 = J + 1
5338	IF (L .LT. JP1) GO TO 220
5339	C
5340	DO 200 K = JP1, L
5341	G = G + AR(K,J) * AR(I,K) - AI(K,J) * AI(I,K)
5342	GI = GI - AR(K,J) * AI(I,K) - AI(K,J) * AR(I,K)
5343	200 CONTINUE
5344	C .......... FORM ELEMENT OF P ..........
5345	220 E(J) = G / H
5346	TAU(2,J) = GI / H
5347	F = F + E(J) * AR(I,J) - TAU(2,J) * AI(I,J)
5348	240 CONTINUE
5349	C
5350	HH = F / (H + H)
5351	C .......... FORM REDUCED A ..........
5352	DO 260 J = 1, L
5353	F = AR(I,J)
5354	G = E(J) - HH * F
5355	E(J) = G
5356	FI = -AI(I,J)
5357	GI = TAU(2,J) - HH * FI
5358	TAU(2,J) = -GI
5359	C
5360	DO 260 K = 1, J
5361	AR(J,K) = AR(J,K) - F * E(K) - G * AR(I,K)
5362	X + FI * TAU(2,K) + GI * AI(I,K)
5363	AI(J,K) = AI(J,K) - F * TAU(2,K) - G * AI(I,K)
5364	X - FI * E(K) - GI * AR(I,K)
5365	260 CONTINUE
5366	C
5367	270 DO 280 K = 1, L
5368	AR(I,K) = SCALE * AR(I,K)
5369	AI(I,K) = SCALE * AI(I,K)
5370	280 CONTINUE
5371	C
5372	TAU(2,L) = -SI
5373	290 HH = D(I)
5374	D(I) = AR(I,I)
5375	AR(I,I) = HH
5376	AI(I,I) = SCALE * DSQRT(H)
5377	300 CONTINUE
5378	C
5379	RETURN
5380	END
5381	SUBROUTINE IMTQL1(N,D,E,IERR)
5382	C
5383	INTEGER I,J,L,M,N,II,MML,IERR
5384	DOUBLE PRECISION D(N),E(N)
5385	DOUBLE PRECISION B,C,F,G,P,R,S,TST1,TST2,PYTHAG
5386	C
5387	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE IMTQL1,
5388	C NUM. MATH. 12, 377-383(1968) BY MARTIN AND WILKINSON,
5389	C AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE.
5390	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971).
5391	C
5392	C THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC
5393	C TRIDIAGONAL MATRIX BY THE IMPLICIT QL METHOD.
5394	C
5395	C ON INPUT
5396	C
5397	C N IS THE ORDER OF THE MATRIX.
5398	C
5399	C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
5400	C
5401	C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
5402	C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY.
5403	C
5404	C ON OUTPUT
5405	C
5406	C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN
5407	C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND
5408	C ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE
5409	C THE SMALLEST EIGENVALUES.
5410	C
5411	C E HAS BEEN DESTROYED.
5412	C
5413	C IERR IS SET TO
5414	C ZERO FOR NORMAL RETURN,
5415	C J IF THE J-TH EIGENVALUE HAS NOT BEEN
5416	C DETERMINED AFTER 30 ITERATIONS.
5417	C
5418	C CALLS PYTHAG FOR DSQRT(AA + BB) .
5419	C
5420	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
5421	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
5422	C
5423	C THIS VERSION DATED AUGUST 1983.
5424	C
5425	C ------------------------------------------------------------------
5426	C
5427	IERR = 0
5428	IF (N .EQ. 1) GO TO 1001
5429	C
5430	DO 100 I = 2, N
5431	100 E(I-1) = E(I)
5432	C
5433	E(N) = 0.0D0
5434	C
5435	DO 290 L = 1, N
5436	J = 0
5437	C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT ..........
5438	105 DO 110 M = L, N
5439	IF (M .EQ. N) GO TO 120
5440	TST1 = DABS(D(M)) + DABS(D(M+1))
5441	TST2 = TST1 + DABS(E(M))
5442	IF (TST2 .EQ. TST1) GO TO 120
5443	110 CONTINUE
5444	C
5445	120 P = D(L)
5446	IF (M .EQ. L) GO TO 215
5447	IF (J .EQ. 30) GO TO 1000
5448	J = J + 1
5449	C .......... FORM SHIFT ..........
5450	G = (D(L+1) - P) / (2.0D0 * E(L))
5451	R = PYTHAG(G,1.0D0)
5452	G = D(M) - P + E(L) / (G + DSIGN(R,G))
5453	S = 1.0D0
5454	C = 1.0D0
5455	P = 0.0D0
5456	MML = M - L
5457	C .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
5458	DO 200 II = 1, MML
5459	I = M - II
5460	F = S * E(I)
5461	B = C * E(I)
5462	R = PYTHAG(F,G)
5463	E(I+1) = R
5464	IF (R .EQ. 0.0D0) GO TO 210
5465	S = F / R
5466	C = G / R
5467	G = D(I+1) - P
5468	R = (D(I) - G) * S + 2.0D0 * C * B
5469	P = S * R
5470	D(I+1) = G + P
5471	G = C * R - B
5472	200 CONTINUE
5473	C
5474	D(L) = D(L) - P
5475	E(L) = G
5476	E(M) = 0.0D0
5477	GO TO 105
5478	C .......... RECOVER FROM UNDERFLOW ..........
5479	210 D(I+1) = D(I+1) - P
5480	E(M) = 0.0D0
5481	GO TO 105
5482	C .......... ORDER EIGENVALUES ..........
5483	215 IF (L .EQ. 1) GO TO 250
5484	C .......... FOR I=L STEP -1 UNTIL 2 DO -- ..........
5485	DO 230 II = 2, L
5486	I = L + 2 - II
5487	IF (P .GE. D(I-1)) GO TO 270
5488	D(I) = D(I-1)
5489	230 CONTINUE
5490	C
5491	250 I = 1
5492	270 D(I) = P
5493	290 CONTINUE
5494	C
5495	GO TO 1001
5496	C .......... SET ERROR -- NO CONVERGENCE TO AN
5497	C EIGENVALUE AFTER 30 ITERATIONS ..........
5498	1000 IERR = L
5499	1001 RETURN
5500	END
5501	SUBROUTINE IMTQL2(NM,N,D,E,Z,IERR)
5502	C
5503	INTEGER I,J,K,L,M,N,II,NM,MML,IERR
5504	DOUBLE PRECISION D(N),E(N),Z(NM,N)
5505	DOUBLE PRECISION B,C,F,G,P,R,S,TST1,TST2,PYTHAG
5506	C
5507	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE IMTQL2,
5508	C NUM. MATH. 12, 377-383(1968) BY MARTIN AND WILKINSON,
5509	C AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE.
5510	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971).
5511	C
5512	C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
5513	C OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE IMPLICIT QL METHOD.
5514	C THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO
5515	C BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS
5516	C FULL MATRIX TO TRIDIAGONAL FORM.
5517	C
5518	C ON INPUT
5519	C
5520	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
5521	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
5522	C DIMENSION STATEMENT.
5523	C
5524	C N IS THE ORDER OF THE MATRIX.
5525	C
5526	C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
5527	C
5528	C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
5529	C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY.
5530	C
5531	C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
5532	C REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS
5533	C OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN
5534	C THE IDENTITY MATRIX.
5535	C
5536	C ON OUTPUT
5537	C
5538	C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN
5539	C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT
5540	C UNORDERED FOR INDICES 1,2,...,IERR-1.
5541	C
5542	C E HAS BEEN DESTROYED.
5543	C
5544	C Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC
5545	C TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE,
5546	C Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED
5547	C EIGENVALUES.
5548	C
5549	C IERR IS SET TO
5550	C ZERO FOR NORMAL RETURN,
5551	C J IF THE J-TH EIGENVALUE HAS NOT BEEN
5552	C DETERMINED AFTER 30 ITERATIONS.
5553	C
5554	C CALLS PYTHAG FOR DSQRT(AA + BB) .
5555	C
5556	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
5557	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
5558	C
5559	C THIS VERSION DATED AUGUST 1983.
5560	C
5561	C ------------------------------------------------------------------
5562	C
5563	IERR = 0
5564	IF (N .EQ. 1) GO TO 1001
5565	C
5566	DO 100 I = 2, N
5567	100 E(I-1) = E(I)
5568	C
5569	E(N) = 0.0D0
5570	C
5571	DO 240 L = 1, N
5572	J = 0
5573	C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT ..........
5574	105 DO 110 M = L, N
5575	IF (M .EQ. N) GO TO 120
5576	TST1 = DABS(D(M)) + DABS(D(M+1))
5577	TST2 = TST1 + DABS(E(M))
5578	IF (TST2 .EQ. TST1) GO TO 120
5579	110 CONTINUE
5580	C
5581	120 P = D(L)
5582	IF (M .EQ. L) GO TO 240
5583	IF (J .EQ. 30) GO TO 1000
5584	J = J + 1
5585	C .......... FORM SHIFT ..........
5586	G = (D(L+1) - P) / (2.0D0 * E(L))
5587	R = PYTHAG(G,1.0D0)
5588	G = D(M) - P + E(L) / (G + DSIGN(R,G))
5589	S = 1.0D0
5590	C = 1.0D0
5591	P = 0.0D0
5592	MML = M - L
5593	C .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
5594	DO 200 II = 1, MML
5595	I = M - II
5596	F = S * E(I)
5597	B = C * E(I)
5598	R = PYTHAG(F,G)
5599	E(I+1) = R
5600	IF (R .EQ. 0.0D0) GO TO 210
5601	S = F / R
5602	C = G / R
5603	G = D(I+1) - P
5604	R = (D(I) - G) * S + 2.0D0 * C * B
5605	P = S * R
5606	D(I+1) = G + P
5607	G = C * R - B
5608	C .......... FORM VECTOR ..........
5609	DO 180 K = 1, N
5610	F = Z(K,I+1)
5611	Z(K,I+1) = S * Z(K,I) + C * F
5612	Z(K,I) = C * Z(K,I) - S * F
5613	180 CONTINUE
5614	C
5615	200 CONTINUE
5616	C
5617	D(L) = D(L) - P
5618	E(L) = G
5619	E(M) = 0.0D0
5620	GO TO 105
5621	C .......... RECOVER FROM UNDERFLOW ..........
5622	210 D(I+1) = D(I+1) - P
5623	E(M) = 0.0D0
5624	GO TO 105
5625	240 CONTINUE
5626	C .......... ORDER EIGENVALUES AND EIGENVECTORS ..........
5627	DO 300 II = 2, N
5628	I = II - 1
5629	K = I
5630	P = D(I)
5631	C
5632	DO 260 J = II, N
5633	IF (D(J) .GE. P) GO TO 260
5634	K = J
5635	P = D(J)
5636	260 CONTINUE
5637	C
5638	IF (K .EQ. I) GO TO 300
5639	D(K) = D(I)
5640	D(I) = P
5641	C
5642	DO 280 J = 1, N
5643	P = Z(J,I)
5644	Z(J,I) = Z(J,K)
5645	Z(J,K) = P
5646	280 CONTINUE
5647	C
5648	300 CONTINUE
5649	C
5650	GO TO 1001
5651	C .......... SET ERROR -- NO CONVERGENCE TO AN
5652	C EIGENVALUE AFTER 30 ITERATIONS ..........
5653	1000 IERR = L
5654	1001 RETURN
5655	END
5656	SUBROUTINE IMTQLV(N,D,E,E2,W,IND,IERR,RV1)
5657	C
5658	INTEGER I,J,K,L,M,N,II,MML,TAG,IERR
5659	DOUBLE PRECISION D(N),E(N),E2(N),W(N),RV1(N)
5660	DOUBLE PRECISION B,C,F,G,P,R,S,TST1,TST2,PYTHAG
5661	INTEGER IND(N)
5662	C
5663	C THIS SUBROUTINE IS A VARIANT OF IMTQL1 WHICH IS A TRANSLATION OF
5664	C ALGOL PROCEDURE IMTQL1, NUM. MATH. 12, 377-383(1968) BY MARTIN AND
5665	C WILKINSON, AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE.
5666	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971).
5667	C
5668	C THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC TRIDIAGONAL
5669	C MATRIX BY THE IMPLICIT QL METHOD AND ASSOCIATES WITH THEM
5670	C THEIR CORRESPONDING SUBMATRIX INDICES.
5671	C
5672	C ON INPUT
5673	C
5674	C N IS THE ORDER OF THE MATRIX.
5675	C
5676	C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
5677	C
5678	C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
5679	C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY.
5680	C
5681	C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
5682	C E2(1) IS ARBITRARY.
5683	C
5684	C ON OUTPUT
5685	C
5686	C D AND E ARE UNALTERED.
5687	C
5688	C ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED
5689	C AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE
5690	C MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES.
5691	C E2(1) IS ALSO SET TO ZERO.
5692	C
5693	C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN
5694	C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND
5695	C ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE
5696	C THE SMALLEST EIGENVALUES.
5697	C
5698	C IND CONTAINS THE SUBMATRIX INDICES ASSOCIATED WITH THE
5699	C CORRESPONDING EIGENVALUES IN W -- 1 FOR EIGENVALUES
5700	C BELONGING TO THE FIRST SUBMATRIX FROM THE TOP,
5701	C 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC..
5702	C
5703	C IERR IS SET TO
5704	C ZERO FOR NORMAL RETURN,
5705	C J IF THE J-TH EIGENVALUE HAS NOT BEEN
5706	C DETERMINED AFTER 30 ITERATIONS.
5707	C
5708	C RV1 IS A TEMPORARY STORAGE ARRAY.
5709	C
5710	C CALLS PYTHAG FOR DSQRT(AA + BB) .
5711	C
5712	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
5713	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
5714	C
5715	C THIS VERSION DATED AUGUST 1983.
5716	C
5717	C ------------------------------------------------------------------
5718	C
5719	IERR = 0
5720	K = 0
5721	TAG = 0
5722	C
5723	DO 100 I = 1, N
5724	W(I) = D(I)
5725	IF (I .NE. 1) RV1(I-1) = E(I)
5726	100 CONTINUE
5727	C
5728	E2(1) = 0.0D0
5729	RV1(N) = 0.0D0
5730	C
5731	DO 290 L = 1, N
5732	J = 0
5733	C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT ..........
5734	105 DO 110 M = L, N
5735	IF (M .EQ. N) GO TO 120
5736	TST1 = DABS(W(M)) + DABS(W(M+1))
5737	TST2 = TST1 + DABS(RV1(M))
5738	IF (TST2 .EQ. TST1) GO TO 120
5739	C .......... GUARD AGAINST UNDERFLOWED ELEMENT OF E2 ..........
5740	IF (E2(M+1) .EQ. 0.0D0) GO TO 125
5741	110 CONTINUE
5742	C
5743	120 IF (M .LE. K) GO TO 130
5744	IF (M .NE. N) E2(M+1) = 0.0D0
5745	125 K = M
5746	TAG = TAG + 1
5747	130 P = W(L)
5748	IF (M .EQ. L) GO TO 215
5749	IF (J .EQ. 30) GO TO 1000
5750	J = J + 1
5751	C .......... FORM SHIFT ..........
5752	G = (W(L+1) - P) / (2.0D0 * RV1(L))
5753	R = PYTHAG(G,1.0D0)
5754	G = W(M) - P + RV1(L) / (G + DSIGN(R,G))
5755	S = 1.0D0
5756	C = 1.0D0
5757	P = 0.0D0
5758	MML = M - L
5759	C .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
5760	DO 200 II = 1, MML
5761	I = M - II
5762	F = S * RV1(I)
5763	B = C * RV1(I)
5764	R = PYTHAG(F,G)
5765	RV1(I+1) = R
5766	IF (R .EQ. 0.0D0) GO TO 210
5767	S = F / R
5768	C = G / R
5769	G = W(I+1) - P
5770	R = (W(I) - G) * S + 2.0D0 * C * B
5771	P = S * R
5772	W(I+1) = G + P
5773	G = C * R - B
5774	200 CONTINUE
5775	C
5776	W(L) = W(L) - P
5777	RV1(L) = G
5778	RV1(M) = 0.0D0
5779	GO TO 105
5780	C .......... RECOVER FROM UNDERFLOW ..........
5781	210 W(I+1) = W(I+1) - P
5782	RV1(M) = 0.0D0
5783	GO TO 105
5784	C .......... ORDER EIGENVALUES ..........
5785	215 IF (L .EQ. 1) GO TO 250
5786	C .......... FOR I=L STEP -1 UNTIL 2 DO -- ..........
5787	DO 230 II = 2, L
5788	I = L + 2 - II
5789	IF (P .GE. W(I-1)) GO TO 270
5790	W(I) = W(I-1)
5791	IND(I) = IND(I-1)
5792	230 CONTINUE
5793	C
5794	250 I = 1
5795	270 W(I) = P
5796	IND(I) = TAG
5797	290 CONTINUE
5798	C
5799	GO TO 1001
5800	C .......... SET ERROR -- NO CONVERGENCE TO AN
5801	C EIGENVALUE AFTER 30 ITERATIONS ..........
5802	1000 IERR = L
5803	1001 RETURN
5804	END
5805	SUBROUTINE INVIT(NM,N,A,WR,WI,SELECT,MM,M,Z,IERR,RM1,RV1,RV2)
5806	C
5807	INTEGER I,J,K,L,M,N,S,II,IP,MM,MP,NM,NS,N1,UK,IP1,ITS,KM1,IERR
5808	DOUBLE PRECISION A(NM,N),WR(N),WI(N),Z(NM,MM),RM1(N,N),
5809	X RV1(N),RV2(N)
5810	DOUBLE PRECISION T,W,X,Y,EPS3,NORM,NORMV,EPSLON,GROWTO,ILAMBD,
5811	X PYTHAG,RLAMBD,UKROOT
5812	LOGICAL SELECT(N)
5813	C
5814	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE INVIT
5815	C BY PETERS AND WILKINSON.
5816	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971).
5817	C
5818	C THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A REAL UPPER
5819	C HESSENBERG MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES,
5820	C USING INVERSE ITERATION.
5821	C
5822	C ON INPUT
5823	C
5824	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
5825	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
5826	C DIMENSION STATEMENT.
5827	C
5828	C N IS THE ORDER OF THE MATRIX.
5829	C
5830	C A CONTAINS THE HESSENBERG MATRIX.
5831	C
5832	C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, RESPECTIVELY,
5833	C OF THE EIGENVALUES OF THE MATRIX. THE EIGENVALUES MUST BE
5834	C STORED IN A MANNER IDENTICAL TO THAT OF SUBROUTINE HQR,
5835	C WHICH RECOGNIZES POSSIBLE SPLITTING OF THE MATRIX.
5836	C
5837	C SELECT SPECIFIES THE EIGENVECTORS TO BE FOUND. THE
5838	C EIGENVECTOR CORRESPONDING TO THE J-TH EIGENVALUE IS
5839	C SPECIFIED BY SETTING SELECT(J) TO .TRUE..
5840	C
5841	C MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF
5842	C COLUMNS REQUIRED TO STORE THE EIGENVECTORS TO BE FOUND.
5843	C NOTE THAT TWO COLUMNS ARE REQUIRED TO STORE THE
5844	C EIGENVECTOR CORRESPONDING TO A COMPLEX EIGENVALUE.
5845	C
5846	C ON OUTPUT
5847	C
5848	C A AND WI ARE UNALTERED.
5849	C
5850	C WR MAY HAVE BEEN ALTERED SINCE CLOSE EIGENVALUES ARE PERTURBED
5851	C SLIGHTLY IN SEARCHING FOR INDEPENDENT EIGENVECTORS.
5852	C
5853	C SELECT MAY HAVE BEEN ALTERED. IF THE ELEMENTS CORRESPONDING
5854	C TO A PAIR OF CONJUGATE COMPLEX EIGENVALUES WERE EACH
5855	C INITIALLY SET TO .TRUE., THE PROGRAM RESETS THE SECOND OF
5856	C THE TWO ELEMENTS TO .FALSE..
5857	C
5858	C M IS THE NUMBER OF COLUMNS ACTUALLY USED TO STORE
5859	C THE EIGENVECTORS.
5860	C
5861	C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS.
5862	C IF THE NEXT SELECTED EIGENVALUE IS REAL, THE NEXT COLUMN
5863	C OF Z CONTAINS ITS EIGENVECTOR. IF THE EIGENVALUE IS
5864	C COMPLEX, THE NEXT TWO COLUMNS OF Z CONTAIN THE REAL AND
5865	C IMAGINARY PARTS OF ITS EIGENVECTOR. THE EIGENVECTORS ARE
5866	C NORMALIZED SO THAT THE COMPONENT OF LARGEST MAGNITUDE IS 1.
5867	C ANY VECTOR WHICH FAILS THE ACCEPTANCE TEST IS SET TO ZERO.
5868	C
5869	C IERR IS SET TO
5870	C ZERO FOR NORMAL RETURN,
5871	C -(2*N+1) IF MORE THAN MM COLUMNS OF Z ARE NECESSARY
5872	C TO STORE THE EIGENVECTORS CORRESPONDING TO
5873	C THE SPECIFIED EIGENVALUES.
5874	C -K IF THE ITERATION CORRESPONDING TO THE K-TH
5875	C VALUE FAILS,
5876	C -(N+K) IF BOTH ERROR SITUATIONS OCCUR.
5877	C
5878	C RM1, RV1, AND RV2 ARE TEMPORARY STORAGE ARRAYS. NOTE THAT RM1
5879	C IS SQUARE OF DIMENSION N BY N AND, AUGMENTED BY TWO COLUMNS
5880	C OF Z, IS THE TRANSPOSE OF THE CORRESPONDING ALGOL B ARRAY.
5881	C
5882	C THE ALGOL PROCEDURE GUESSVEC APPEARS IN INVIT IN LINE.
5883	C
5884	C CALLS CDIV FOR COMPLEX DIVISION.
5885	C CALLS PYTHAG FOR DSQRT(AA + BB) .
5886	C
5887	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
5888	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
5889	C
5890	C THIS VERSION DATED AUGUST 1983.
5891	C
5892	C ------------------------------------------------------------------
5893	C
5894	IERR = 0
5895	UK = 0
5896	S = 1
5897	C .......... IP = 0, REAL EIGENVALUE
5898	C 1, FIRST OF CONJUGATE COMPLEX PAIR
5899	C -1, SECOND OF CONJUGATE COMPLEX PAIR ..........
5900	IP = 0
5901	N1 = N - 1
5902	C
5903	DO 980 K = 1, N
5904	IF (WI(K) .EQ. 0.0D0 .OR. IP .LT. 0) GO TO 100
5905	IP = 1
5906	IF (SELECT(K) .AND. SELECT(K+1)) SELECT(K+1) = .FALSE.
5907	100 IF (.NOT. SELECT(K)) GO TO 960
5908	IF (WI(K) .NE. 0.0D0) S = S + 1
5909	IF (S .GT. MM) GO TO 1000
5910	IF (UK .GE. K) GO TO 200
5911	C .......... CHECK FOR POSSIBLE SPLITTING ..........
5912	DO 120 UK = K, N
5913	IF (UK .EQ. N) GO TO 140
5914	IF (A(UK+1,UK) .EQ. 0.0D0) GO TO 140
5915	120 CONTINUE
5916	C .......... COMPUTE INFINITY NORM OF LEADING UK BY UK
5917	C (HESSENBERG) MATRIX ..........
5918	140 NORM = 0.0D0
5919	MP = 1
5920	C
5921	DO 180 I = 1, UK
5922	X = 0.0D0
5923	C
5924	DO 160 J = MP, UK
5925	160 X = X + DABS(A(I,J))
5926	C
5927	IF (X .GT. NORM) NORM = X
5928	MP = I
5929	180 CONTINUE
5930	C .......... EPS3 REPLACES ZERO PIVOT IN DECOMPOSITION
5931	C AND CLOSE ROOTS ARE MODIFIED BY EPS3 ..........
5932	IF (NORM .EQ. 0.0D0) NORM = 1.0D0
5933	EPS3 = EPSLON(NORM)
5934	C .......... GROWTO IS THE CRITERION FOR THE GROWTH ..........
5935	UKROOT = UK
5936	UKROOT = DSQRT(UKROOT)
5937	GROWTO = 0.1D0 / UKROOT
5938	200 RLAMBD = WR(K)
5939	ILAMBD = WI(K)
5940	IF (K .EQ. 1) GO TO 280
5941	KM1 = K - 1
5942	GO TO 240
5943	C .......... PERTURB EIGENVALUE IF IT IS CLOSE
5944	C TO ANY PREVIOUS EIGENVALUE ..........
5945	220 RLAMBD = RLAMBD + EPS3
5946	C .......... FOR I=K-1 STEP -1 UNTIL 1 DO -- ..........
5947	240 DO 260 II = 1, KM1
5948	I = K - II
5949	IF (SELECT(I) .AND. DABS(WR(I)-RLAMBD) .LT. EPS3 .AND.
5950	X DABS(WI(I)-ILAMBD) .LT. EPS3) GO TO 220
5951	260 CONTINUE
5952	C
5953	WR(K) = RLAMBD
5954	C .......... PERTURB CONJUGATE EIGENVALUE TO MATCH ..........
5955	IP1 = K + IP
5956	WR(IP1) = RLAMBD
5957	C .......... FORM UPPER HESSENBERG A-RLAMBD*I (TRANSPOSED)
5958	C AND INITIAL REAL VECTOR ..........
5959	280 MP = 1
5960	C
5961	DO 320 I = 1, UK
5962	C
5963	DO 300 J = MP, UK
5964	300 RM1(J,I) = A(I,J)
5965	C
5966	RM1(I,I) = RM1(I,I) - RLAMBD
5967	MP = I
5968	RV1(I) = EPS3
5969	320 CONTINUE
5970	C
5971	ITS = 0
5972	IF (ILAMBD .NE. 0.0D0) GO TO 520
5973	C .......... REAL EIGENVALUE.
5974	C TRIANGULAR DECOMPOSITION WITH INTERCHANGES,
5975	C REPLACING ZERO PIVOTS BY EPS3 ..........
5976	IF (UK .EQ. 1) GO TO 420
5977	C
5978	DO 400 I = 2, UK
5979	MP = I - 1
5980	IF (DABS(RM1(MP,I)) .LE. DABS(RM1(MP,MP))) GO TO 360
5981	C
5982	DO 340 J = MP, UK
5983	Y = RM1(J,I)
5984	RM1(J,I) = RM1(J,MP)
5985	RM1(J,MP) = Y
5986	340 CONTINUE
5987	C
5988	360 IF (RM1(MP,MP) .EQ. 0.0D0) RM1(MP,MP) = EPS3
5989	X = RM1(MP,I) / RM1(MP,MP)
5990	IF (X .EQ. 0.0D0) GO TO 400
5991	C
5992	DO 380 J = I, UK
5993	380 RM1(J,I) = RM1(J,I) - X * RM1(J,MP)
5994	C
5995	400 CONTINUE
5996	C
5997	420 IF (RM1(UK,UK) .EQ. 0.0D0) RM1(UK,UK) = EPS3
5998	C .......... BACK SUBSTITUTION FOR REAL VECTOR
5999	C FOR I=UK STEP -1 UNTIL 1 DO -- ..........
6000	440 DO 500 II = 1, UK
6001	I = UK + 1 - II
6002	Y = RV1(I)
6003	IF (I .EQ. UK) GO TO 480
6004	IP1 = I + 1
6005	C
6006	DO 460 J = IP1, UK
6007	460 Y = Y - RM1(J,I) * RV1(J)
6008	C
6009	480 RV1(I) = Y / RM1(I,I)
6010	500 CONTINUE
6011	C
6012	GO TO 740
6013	C .......... COMPLEX EIGENVALUE.
6014	C TRIANGULAR DECOMPOSITION WITH INTERCHANGES,
6015	C REPLACING ZERO PIVOTS BY EPS3. STORE IMAGINARY
6016	C PARTS IN UPPER TRIANGLE STARTING AT (1,3) ..........
6017	520 NS = N - S
6018	Z(1,S-1) = -ILAMBD
6019	Z(1,S) = 0.0D0
6020	IF (N .EQ. 2) GO TO 550
6021	RM1(1,3) = -ILAMBD
6022	Z(1,S-1) = 0.0D0
6023	IF (N .EQ. 3) GO TO 550
6024	C
6025	DO 540 I = 4, N
6026	540 RM1(1,I) = 0.0D0
6027	C
6028	550 DO 640 I = 2, UK
6029	MP = I - 1
6030	W = RM1(MP,I)
6031	IF (I .LT. N) T = RM1(MP,I+1)
6032	IF (I .EQ. N) T = Z(MP,S-1)
6033	X = RM1(MP,MP) * RM1(MP,MP) + T * T
6034	IF (W * W .LE. X) GO TO 580
6035	X = RM1(MP,MP) / W
6036	Y = T / W
6037	RM1(MP,MP) = W
6038	IF (I .LT. N) RM1(MP,I+1) = 0.0D0
6039	IF (I .EQ. N) Z(MP,S-1) = 0.0D0
6040	C
6041	DO 560 J = I, UK
6042	W = RM1(J,I)
6043	RM1(J,I) = RM1(J,MP) - X * W
6044	RM1(J,MP) = W
6045	IF (J .LT. N1) GO TO 555
6046	L = J - NS
6047	Z(I,L) = Z(MP,L) - Y * W
6048	Z(MP,L) = 0.0D0
6049	GO TO 560
6050	555 RM1(I,J+2) = RM1(MP,J+2) - Y * W
6051	RM1(MP,J+2) = 0.0D0
6052	560 CONTINUE
6053	C
6054	RM1(I,I) = RM1(I,I) - Y * ILAMBD
6055	IF (I .LT. N1) GO TO 570
6056	L = I - NS
6057	Z(MP,L) = -ILAMBD
6058	Z(I,L) = Z(I,L) + X * ILAMBD
6059	GO TO 640
6060	570 RM1(MP,I+2) = -ILAMBD
6061	RM1(I,I+2) = RM1(I,I+2) + X * ILAMBD
6062	GO TO 640
6063	580 IF (X .NE. 0.0D0) GO TO 600
6064	RM1(MP,MP) = EPS3
6065	IF (I .LT. N) RM1(MP,I+1) = 0.0D0
6066	IF (I .EQ. N) Z(MP,S-1) = 0.0D0
6067	T = 0.0D0
6068	X = EPS3 * EPS3
6069	600 W = W / X
6070	X = RM1(MP,MP) * W
6071	Y = -T * W
6072	C
6073	DO 620 J = I, UK
6074	IF (J .LT. N1) GO TO 610
6075	L = J - NS
6076	T = Z(MP,L)
6077	Z(I,L) = -X * T - Y * RM1(J,MP)
6078	GO TO 615
6079	610 T = RM1(MP,J+2)
6080	RM1(I,J+2) = -X * T - Y * RM1(J,MP)
6081	615 RM1(J,I) = RM1(J,I) - X * RM1(J,MP) + Y * T
6082	620 CONTINUE
6083	C
6084	IF (I .LT. N1) GO TO 630
6085	L = I - NS
6086	Z(I,L) = Z(I,L) - ILAMBD
6087	GO TO 640
6088	630 RM1(I,I+2) = RM1(I,I+2) - ILAMBD
6089	640 CONTINUE
6090	C
6091	IF (UK .LT. N1) GO TO 650
6092	L = UK - NS
6093	T = Z(UK,L)
6094	GO TO 655
6095	650 T = RM1(UK,UK+2)
6096	655 IF (RM1(UK,UK) .EQ. 0.0D0 .AND. T .EQ. 0.0D0) RM1(UK,UK) = EPS3
6097	C .......... BACK SUBSTITUTION FOR COMPLEX VECTOR
6098	C FOR I=UK STEP -1 UNTIL 1 DO -- ..........
6099	660 DO 720 II = 1, UK
6100	I = UK + 1 - II
6101	X = RV1(I)
6102	Y = 0.0D0
6103	IF (I .EQ. UK) GO TO 700
6104	IP1 = I + 1
6105	C
6106	DO 680 J = IP1, UK
6107	IF (J .LT. N1) GO TO 670
6108	L = J - NS
6109	T = Z(I,L)
6110	GO TO 675
6111	670 T = RM1(I,J+2)
6112	675 X = X - RM1(J,I) * RV1(J) + T * RV2(J)
6113	Y = Y - RM1(J,I) * RV2(J) - T * RV1(J)
6114	680 CONTINUE
6115	C
6116	700 IF (I .LT. N1) GO TO 710
6117	L = I - NS
6118	T = Z(I,L)
6119	GO TO 715
6120	710 T = RM1(I,I+2)
6121	715 CALL CDIV(X,Y,RM1(I,I),T,RV1(I),RV2(I))
6122	720 CONTINUE
6123	C .......... ACCEPTANCE TEST FOR REAL OR COMPLEX
6124	C EIGENVECTOR AND NORMALIZATION ..........
6125	740 ITS = ITS + 1
6126	NORM = 0.0D0
6127	NORMV = 0.0D0
6128	C
6129	DO 780 I = 1, UK
6130	IF (ILAMBD .EQ. 0.0D0) X = DABS(RV1(I))
6131	IF (ILAMBD .NE. 0.0D0) X = PYTHAG(RV1(I),RV2(I))
6132	IF (NORMV .GE. X) GO TO 760
6133	NORMV = X
6134	J = I
6135	760 NORM = NORM + X
6136	780 CONTINUE
6137	C
6138	IF (NORM .LT. GROWTO) GO TO 840
6139	C .......... ACCEPT VECTOR ..........
6140	X = RV1(J)
6141	IF (ILAMBD .EQ. 0.0D0) X = 1.0D0 / X
6142	IF (ILAMBD .NE. 0.0D0) Y = RV2(J)
6143	C
6144	DO 820 I = 1, UK
6145	IF (ILAMBD .NE. 0.0D0) GO TO 800
6146	Z(I,S) = RV1(I) * X
6147	GO TO 820
6148	800 CALL CDIV(RV1(I),RV2(I),X,Y,Z(I,S-1),Z(I,S))
6149	820 CONTINUE
6150	C
6151	IF (UK .EQ. N) GO TO 940
6152	J = UK + 1
6153	GO TO 900
6154	C .......... IN-LINE PROCEDURE FOR CHOOSING
6155	C A NEW STARTING VECTOR ..........
6156	840 IF (ITS .GE. UK) GO TO 880
6157	X = UKROOT
6158	Y = EPS3 / (X + 1.0D0)
6159	RV1(1) = EPS3
6160	C
6161	DO 860 I = 2, UK
6162	860 RV1(I) = Y
6163	C
6164	J = UK - ITS + 1
6165	RV1(J) = RV1(J) - EPS3 * X
6166	IF (ILAMBD .EQ. 0.0D0) GO TO 440
6167	GO TO 660
6168	C .......... SET ERROR -- UNACCEPTED EIGENVECTOR ..........
6169	880 J = 1
6170	IERR = -K
6171	C .......... SET REMAINING VECTOR COMPONENTS TO ZERO ..........
6172	900 DO 920 I = J, N
6173	Z(I,S) = 0.0D0
6174	IF (ILAMBD .NE. 0.0D0) Z(I,S-1) = 0.0D0
6175	920 CONTINUE
6176	C
6177	940 S = S + 1
6178	960 IF (IP .EQ. (-1)) IP = 0
6179	IF (IP .EQ. 1) IP = -1
6180	980 CONTINUE
6181	C
6182	GO TO 1001
6183	C .......... SET ERROR -- UNDERESTIMATE OF EIGENVECTOR
6184	C SPACE REQUIRED ..........
6185	1000 IF (IERR .NE. 0) IERR = IERR - N
6186	IF (IERR .EQ. 0) IERR = -(2 * N + 1)
6187	1001 M = S - 1 - IABS(IP)
6188	RETURN
6189	END
6190	SUBROUTINE MINFIT(NM,M,N,A,W,IP,B,IERR,RV1)
6191	C
6192	INTEGER I,J,K,L,M,N,II,IP,I1,KK,K1,LL,L1,M1,NM,ITS,IERR
6193	DOUBLE PRECISION A(NM,N),W(N),B(NM,IP),RV1(N)
6194	DOUBLE PRECISION C,F,G,H,S,X,Y,Z,TST1,TST2,SCALE,PYTHAG
6195	C
6196	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE MINFIT,
6197	C NUM. MATH. 14, 403-420(1970) BY GOLUB AND REINSCH.
6198	C HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 134-151(1971).
6199	C
6200	C THIS SUBROUTINE DETERMINES, TOWARDS THE SOLUTION OF THE LINEAR
6201	C T
6202	C SYSTEM AX=B, THE SINGULAR VALUE DECOMPOSITION A=USV OF A REAL
6203	C T
6204	C M BY N RECTANGULAR MATRIX, FORMING U B RATHER THAN U. HOUSEHOLDER
6205	C BIDIAGONALIZATION AND A VARIANT OF THE QR ALGORITHM ARE USED.
6206	C
6207	C ON INPUT
6208	C
6209	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
6210	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
6211	C DIMENSION STATEMENT. NOTE THAT NM MUST BE AT LEAST
6212	C AS LARGE AS THE MAXIMUM OF M AND N.
6213	C
6214	C M IS THE NUMBER OF ROWS OF A AND B.
6215	C
6216	C N IS THE NUMBER OF COLUMNS OF A AND THE ORDER OF V.
6217	C
6218	C A CONTAINS THE RECTANGULAR COEFFICIENT MATRIX OF THE SYSTEM.
6219	C
6220	C IP IS THE NUMBER OF COLUMNS OF B. IP CAN BE ZERO.
6221	C
6222	C B CONTAINS THE CONSTANT COLUMN MATRIX OF THE SYSTEM
6223	C IF IP IS NOT ZERO. OTHERWISE B IS NOT REFERENCED.
6224	C
6225	C ON OUTPUT
6226	C
6227	C A HAS BEEN OVERWRITTEN BY THE MATRIX V (ORTHOGONAL) OF THE
6228	C DECOMPOSITION IN ITS FIRST N ROWS AND COLUMNS. IF AN
6229	C ERROR EXIT IS MADE, THE COLUMNS OF V CORRESPONDING TO
6230	C INDICES OF CORRECT SINGULAR VALUES SHOULD BE CORRECT.
6231	C
6232	C W CONTAINS THE N (NON-NEGATIVE) SINGULAR VALUES OF A (THE
6233	C DIAGONAL ELEMENTS OF S). THEY ARE UNORDERED. IF AN
6234	C ERROR EXIT IS MADE, THE SINGULAR VALUES SHOULD BE CORRECT
6235	C FOR INDICES IERR+1,IERR+2,...,N.
6236	C
6237	C T
6238	C B HAS BEEN OVERWRITTEN BY U B. IF AN ERROR EXIT IS MADE,
6239	C T
6240	C THE ROWS OF U B CORRESPONDING TO INDICES OF CORRECT
6241	C SINGULAR VALUES SHOULD BE CORRECT.
6242	C
6243	C IERR IS SET TO
6244	C ZERO FOR NORMAL RETURN,
6245	C K IF THE K-TH SINGULAR VALUE HAS NOT BEEN
6246	C DETERMINED AFTER 30 ITERATIONS.
6247	C
6248	C RV1 IS A TEMPORARY STORAGE ARRAY.
6249	C
6250	C CALLS PYTHAG FOR DSQRT(AA + BB) .
6251	C
6252	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
6253	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
6254	C
6255	C THIS VERSION DATED AUGUST 1983.
6256	C
6257	C ------------------------------------------------------------------
6258	C
6259	IERR = 0
6260	C .......... HOUSEHOLDER REDUCTION TO BIDIAGONAL FORM ..........
6261	G = 0.0D0
6262	SCALE = 0.0D0
6263	X = 0.0D0
6264	C
6265	DO 300 I = 1, N
6266	L = I + 1
6267	RV1(I) = SCALE * G
6268	G = 0.0D0
6269	S = 0.0D0
6270	SCALE = 0.0D0
6271	IF (I .GT. M) GO TO 210
6272	C
6273	DO 120 K = I, M
6274	120 SCALE = SCALE + DABS(A(K,I))
6275	C
6276	IF (SCALE .EQ. 0.0D0) GO TO 210
6277	C
6278	DO 130 K = I, M
6279	A(K,I) = A(K,I) / SCALE
6280	S = S + A(K,I)**2
6281	130 CONTINUE
6282	C
6283	F = A(I,I)
6284	G = -DSIGN(DSQRT(S),F)
6285	H = F * G - S
6286	A(I,I) = F - G
6287	IF (I .EQ. N) GO TO 160
6288	C
6289	DO 150 J = L, N
6290	S = 0.0D0
6291	C
6292	DO 140 K = I, M
6293	140 S = S + A(K,I) * A(K,J)
6294	C
6295	F = S / H
6296	C
6297	DO 150 K = I, M
6298	A(K,J) = A(K,J) + F * A(K,I)
6299	150 CONTINUE
6300	C
6301	160 IF (IP .EQ. 0) GO TO 190
6302	C
6303	DO 180 J = 1, IP
6304	S = 0.0D0
6305	C
6306	DO 170 K = I, M
6307	170 S = S + A(K,I) * B(K,J)
6308	C
6309	F = S / H
6310	C
6311	DO 180 K = I, M
6312	B(K,J) = B(K,J) + F * A(K,I)
6313	180 CONTINUE
6314	C
6315	190 DO 200 K = I, M
6316	200 A(K,I) = SCALE * A(K,I)
6317	C
6318	210 W(I) = SCALE * G
6319	G = 0.0D0
6320	S = 0.0D0
6321	SCALE = 0.0D0
6322	IF (I .GT. M .OR. I .EQ. N) GO TO 290
6323	C
6324	DO 220 K = L, N
6325	220 SCALE = SCALE + DABS(A(I,K))
6326	C
6327	IF (SCALE .EQ. 0.0D0) GO TO 290
6328	C
6329	DO 230 K = L, N
6330	A(I,K) = A(I,K) / SCALE
6331	S = S + A(I,K)**2
6332	230 CONTINUE
6333	C
6334	F = A(I,L)
6335	G = -DSIGN(DSQRT(S),F)
6336	H = F * G - S
6337	A(I,L) = F - G
6338	C
6339	DO 240 K = L, N
6340	240 RV1(K) = A(I,K) / H
6341	C
6342	IF (I .EQ. M) GO TO 270
6343	C
6344	DO 260 J = L, M
6345	S = 0.0D0
6346	C
6347	DO 250 K = L, N
6348	250 S = S + A(J,K) * A(I,K)
6349	C
6350	DO 260 K = L, N
6351	A(J,K) = A(J,K) + S * RV1(K)
6352	260 CONTINUE
6353	C
6354	270 DO 280 K = L, N
6355	280 A(I,K) = SCALE * A(I,K)
6356	C
6357	290 X = DMAX1(X,DABS(W(I))+DABS(RV1(I)))
6358	300 CONTINUE
6359	C .......... ACCUMULATION OF RIGHT-HAND TRANSFORMATIONS.
6360	C FOR I=N STEP -1 UNTIL 1 DO -- ..........
6361	DO 400 II = 1, N
6362	I = N + 1 - II
6363	IF (I .EQ. N) GO TO 390
6364	IF (G .EQ. 0.0D0) GO TO 360
6365	C
6366	DO 320 J = L, N
6367	C .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ..........
6368	320 A(J,I) = (A(I,J) / A(I,L)) / G
6369	C
6370	DO 350 J = L, N
6371	S = 0.0D0
6372	C
6373	DO 340 K = L, N
6374	340 S = S + A(I,K) * A(K,J)
6375	C
6376	DO 350 K = L, N
6377	A(K,J) = A(K,J) + S * A(K,I)
6378	350 CONTINUE
6379	C
6380	360 DO 380 J = L, N
6381	A(I,J) = 0.0D0
6382	A(J,I) = 0.0D0
6383	380 CONTINUE
6384	C
6385	390 A(I,I) = 1.0D0
6386	G = RV1(I)
6387	L = I
6388	400 CONTINUE
6389	C
6390	IF (M .GE. N .OR. IP .EQ. 0) GO TO 510
6391	M1 = M + 1
6392	C
6393	DO 500 I = M1, N
6394	C
6395	DO 500 J = 1, IP
6396	B(I,J) = 0.0D0
6397	500 CONTINUE
6398	C .......... DIAGONALIZATION OF THE BIDIAGONAL FORM ..........
6399	510 TST1 = X
6400	C .......... FOR K=N STEP -1 UNTIL 1 DO -- ..........
6401	DO 700 KK = 1, N
6402	K1 = N - KK
6403	K = K1 + 1
6404	ITS = 0
6405	C .......... TEST FOR SPLITTING.
6406	C FOR L=K STEP -1 UNTIL 1 DO -- ..........
6407	520 DO 530 LL = 1, K
6408	L1 = K - LL
6409	L = L1 + 1
6410	TST2 = TST1 + DABS(RV1(L))
6411	IF (TST2 .EQ. TST1) GO TO 565
6412	C .......... RV1(1) IS ALWAYS ZERO, SO THERE IS NO EXIT
6413	C THROUGH THE BOTTOM OF THE LOOP ..........
6414	TST2 = TST1 + DABS(W(L1))
6415	IF (TST2 .EQ. TST1) GO TO 540
6416	530 CONTINUE
6417	C .......... CANCELLATION OF RV1(L) IF L GREATER THAN 1 ..........
6418	540 C = 0.0D0
6419	S = 1.0D0
6420	C
6421	DO 560 I = L, K
6422	F = S * RV1(I)
6423	RV1(I) = C * RV1(I)
6424	TST2 = TST1 + DABS(F)
6425	IF (TST2 .EQ. TST1) GO TO 565
6426	G = W(I)
6427	H = PYTHAG(F,G)
6428	W(I) = H
6429	C = G / H
6430	S = -F / H
6431	IF (IP .EQ. 0) GO TO 560
6432	C
6433	DO 550 J = 1, IP
6434	Y = B(L1,J)
6435	Z = B(I,J)
6436	B(L1,J) = Y * C + Z * S
6437	B(I,J) = -Y * S + Z * C
6438	550 CONTINUE
6439	C
6440	560 CONTINUE
6441	C .......... TEST FOR CONVERGENCE ..........
6442	565 Z = W(K)
6443	IF (L .EQ. K) GO TO 650
6444	C .......... SHIFT FROM BOTTOM 2 BY 2 MINOR ..........
6445	IF (ITS .EQ. 30) GO TO 1000
6446	ITS = ITS + 1
6447	X = W(L)
6448	Y = W(K1)
6449	G = RV1(K1)
6450	H = RV1(K)
6451	F = 0.5D0 * (((G + Z) / H) * ((G - Z) / Y) + Y / H - H / Y)
6452	G = PYTHAG(F,1.0D0)
6453	F = X - (Z / X) * Z + (H / X) * (Y / (F + DSIGN(G,F)) - H)
6454	C .......... NEXT QR TRANSFORMATION ..........
6455	C = 1.0D0
6456	S = 1.0D0
6457	C
6458	DO 600 I1 = L, K1
6459	I = I1 + 1
6460	G = RV1(I)
6461	Y = W(I)
6462	H = S * G
6463	G = C * G
6464	Z = PYTHAG(F,H)
6465	RV1(I1) = Z
6466	C = F / Z
6467	S = H / Z
6468	F = X * C + G * S
6469	G = -X * S + G * C
6470	H = Y * S
6471	Y = Y * C
6472	C
6473	DO 570 J = 1, N
6474	X = A(J,I1)
6475	Z = A(J,I)
6476	A(J,I1) = X * C + Z * S
6477	A(J,I) = -X * S + Z * C
6478	570 CONTINUE
6479	C
6480	Z = PYTHAG(F,H)
6481	W(I1) = Z
6482	C .......... ROTATION CAN BE ARBITRARY IF Z IS ZERO ..........
6483	IF (Z .EQ. 0.0D0) GO TO 580
6484	C = F / Z
6485	S = H / Z
6486	580 F = C * G + S * Y
6487	X = -S * G + C * Y
6488	IF (IP .EQ. 0) GO TO 600
6489	C
6490	DO 590 J = 1, IP
6491	Y = B(I1,J)
6492	Z = B(I,J)
6493	B(I1,J) = Y * C + Z * S
6494	B(I,J) = -Y * S + Z * C
6495	590 CONTINUE
6496	C
6497	600 CONTINUE
6498	C
6499	RV1(L) = 0.0D0
6500	RV1(K) = F
6501	W(K) = X
6502	GO TO 520
6503	C .......... CONVERGENCE ..........
6504	650 IF (Z .GE. 0.0D0) GO TO 700
6505	C .......... W(K) IS MADE NON-NEGATIVE ..........
6506	W(K) = -Z
6507	C
6508	DO 690 J = 1, N
6509	690 A(J,K) = -A(J,K)
6510	C
6511	700 CONTINUE
6512	C
6513	GO TO 1001
6514	C .......... SET ERROR -- NO CONVERGENCE TO A
6515	C SINGULAR VALUE AFTER 30 ITERATIONS ..........
6516	1000 IERR = K
6517	1001 RETURN
6518	END
6519	SUBROUTINE ORTBAK(NM,LOW,IGH,A,ORT,M,Z)
6520	C
6521	INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1
6522	DOUBLE PRECISION A(NM,IGH),ORT(IGH),Z(NM,M)
6523	DOUBLE PRECISION G
6524	C
6525	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTBAK,
6526	C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON.
6527	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
6528	C
6529	C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL GENERAL
6530	C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
6531	C UPPER HESSENBERG MATRIX DETERMINED BY ORTHES.
6532	C
6533	C ON INPUT
6534	C
6535	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
6536	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
6537	C DIMENSION STATEMENT.
6538	C
6539	C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
6540	C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED,
6541	C SET LOW=1 AND IGH EQUAL TO THE ORDER OF THE MATRIX.
6542	C
6543	C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS-
6544	C FORMATIONS USED IN THE REDUCTION BY ORTHES
6545	C IN ITS STRICT LOWER TRIANGLE.
6546	C
6547	C ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANS-
6548	C FORMATIONS USED IN THE REDUCTION BY ORTHES.
6549	C ONLY ELEMENTS LOW THROUGH IGH ARE USED.
6550	C
6551	C M IS THE NUMBER OF COLUMNS OF Z TO BE BACK TRANSFORMED.
6552	C
6553	C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGEN-
6554	C VECTORS TO BE BACK TRANSFORMED IN ITS FIRST M COLUMNS.
6555	C
6556	C ON OUTPUT
6557	C
6558	C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE
6559	C TRANSFORMED EIGENVECTORS IN ITS FIRST M COLUMNS.
6560	C
6561	C ORT HAS BEEN ALTERED.
6562	C
6563	C NOTE THAT ORTBAK PRESERVES VECTOR EUCLIDEAN NORMS.
6564	C
6565	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
6566	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
6567	C
6568	C THIS VERSION DATED AUGUST 1983.
6569	C
6570	C ------------------------------------------------------------------
6571	C
6572	IF (M .EQ. 0) GO TO 200
6573	LA = IGH - 1
6574	KP1 = LOW + 1
6575	IF (LA .LT. KP1) GO TO 200
6576	C .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
6577	DO 140 MM = KP1, LA
6578	MP = LOW + IGH - MM
6579	IF (A(MP,MP-1) .EQ. 0.0D0) GO TO 140
6580	MP1 = MP + 1
6581	C
6582	DO 100 I = MP1, IGH
6583	100 ORT(I) = A(I,MP-1)
6584	C
6585	DO 130 J = 1, M
6586	G = 0.0D0
6587	C
6588	DO 110 I = MP, IGH
6589	110 G = G + ORT(I) * Z(I,J)
6590	C .......... DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHES.
6591	C DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ..........
6592	G = (G / ORT(MP)) / A(MP,MP-1)
6593	C
6594	DO 120 I = MP, IGH
6595	120 Z(I,J) = Z(I,J) + G * ORT(I)
6596	C
6597	130 CONTINUE
6598	C
6599	140 CONTINUE
6600	C
6601	200 RETURN
6602	END
6603	SUBROUTINE ORTHES(NM,N,LOW,IGH,A,ORT)
6604	C
6605	INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
6606	DOUBLE PRECISION A(NM,N),ORT(IGH)
6607	DOUBLE PRECISION F,G,H,SCALE
6608	C
6609	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTHES,
6610	C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON.
6611	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
6612	C
6613	C GIVEN A REAL GENERAL MATRIX, THIS SUBROUTINE
6614	C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
6615	C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
6616	C ORTHOGONAL SIMILARITY TRANSFORMATIONS.
6617	C
6618	C ON INPUT
6619	C
6620	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
6621	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
6622	C DIMENSION STATEMENT.
6623	C
6624	C N IS THE ORDER OF THE MATRIX.
6625	C
6626	C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
6627	C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED,
6628	C SET LOW=1, IGH=N.
6629	C
6630	C A CONTAINS THE INPUT MATRIX.
6631	C
6632	C ON OUTPUT
6633	C
6634	C A CONTAINS THE HESSENBERG MATRIX. INFORMATION ABOUT
6635	C THE ORTHOGONAL TRANSFORMATIONS USED IN THE REDUCTION
6636	C IS STORED IN THE REMAINING TRIANGLE UNDER THE
6637	C HESSENBERG MATRIX.
6638	C
6639	C ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS.
6640	C ONLY ELEMENTS LOW THROUGH IGH ARE USED.
6641	C
6642	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
6643	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
6644	C
6645	C THIS VERSION DATED AUGUST 1983.
6646	C
6647	C ------------------------------------------------------------------
6648	C
6649	LA = IGH - 1
6650	KP1 = LOW + 1
6651	IF (LA .LT. KP1) GO TO 200
6652	C
6653	DO 180 M = KP1, LA
6654	H = 0.0D0
6655	ORT(M) = 0.0D0
6656	SCALE = 0.0D0
6657	C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
6658	DO 90 I = M, IGH
6659	90 SCALE = SCALE + DABS(A(I,M-1))
6660	C
6661	IF (SCALE .EQ. 0.0D0) GO TO 180
6662	MP = M + IGH
6663	C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
6664	DO 100 II = M, IGH
6665	I = MP - II
6666	ORT(I) = A(I,M-1) / SCALE
6667	H = H + ORT(I) * ORT(I)
6668	100 CONTINUE
6669	C
6670	G = -DSIGN(DSQRT(H),ORT(M))
6671	H = H - ORT(M) * G
6672	ORT(M) = ORT(M) - G
6673	C .......... FORM (I-(UUT)/H) A ..........
6674	DO 130 J = M, N
6675	F = 0.0D0
6676	C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
6677	DO 110 II = M, IGH
6678	I = MP - II
6679	F = F + ORT(I) * A(I,J)
6680	110 CONTINUE
6681	C
6682	F = F / H
6683	C
6684	DO 120 I = M, IGH
6685	120 A(I,J) = A(I,J) - F * ORT(I)
6686	C
6687	130 CONTINUE
6688	C .......... FORM (I-(UUT)/H)A(I-(UUT)/H) ..........
6689	DO 160 I = 1, IGH
6690	F = 0.0D0
6691	C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
6692	DO 140 JJ = M, IGH
6693	J = MP - JJ
6694	F = F + ORT(J) * A(I,J)
6695	140 CONTINUE
6696	C
6697	F = F / H
6698	C
6699	DO 150 J = M, IGH
6700	150 A(I,J) = A(I,J) - F * ORT(J)
6701	C
6702	160 CONTINUE
6703	C
6704	ORT(M) = SCALE * ORT(M)
6705	A(M,M-1) = SCALE * G
6706	180 CONTINUE
6707	C
6708	200 RETURN
6709	END
6710	SUBROUTINE ORTRAN(NM,N,LOW,IGH,A,ORT,Z)
6711	C
6712	INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1
6713	DOUBLE PRECISION A(NM,IGH),ORT(IGH),Z(NM,N)
6714	DOUBLE PRECISION G
6715	C
6716	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTRANS,
6717	C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON.
6718	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
6719	C
6720	C THIS SUBROUTINE ACCUMULATES THE ORTHOGONAL SIMILARITY
6721	C TRANSFORMATIONS USED IN THE REDUCTION OF A REAL GENERAL
6722	C MATRIX TO UPPER HESSENBERG FORM BY ORTHES.
6723	C
6724	C ON INPUT
6725	C
6726	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
6727	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
6728	C DIMENSION STATEMENT.
6729	C
6730	C N IS THE ORDER OF THE MATRIX.
6731	C
6732	C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
6733	C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED,
6734	C SET LOW=1, IGH=N.
6735	C
6736	C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS-
6737	C FORMATIONS USED IN THE REDUCTION BY ORTHES
6738	C IN ITS STRICT LOWER TRIANGLE.
6739	C
6740	C ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANS-
6741	C FORMATIONS USED IN THE REDUCTION BY ORTHES.
6742	C ONLY ELEMENTS LOW THROUGH IGH ARE USED.
6743	C
6744	C ON OUTPUT
6745	C
6746	C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
6747	C REDUCTION BY ORTHES.
6748	C
6749	C ORT HAS BEEN ALTERED.
6750	C
6751	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
6752	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
6753	C
6754	C THIS VERSION DATED AUGUST 1983.
6755	C
6756	C ------------------------------------------------------------------
6757	C
6758	C .......... INITIALIZE Z TO IDENTITY MATRIX ..........
6759	DO 80 J = 1, N
6760	C
6761	DO 60 I = 1, N
6762	60 Z(I,J) = 0.0D0
6763	C
6764	Z(J,J) = 1.0D0
6765	80 CONTINUE
6766	C
6767	KL = IGH - LOW - 1
6768	IF (KL .LT. 1) GO TO 200
6769	C .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
6770	DO 140 MM = 1, KL
6771	MP = IGH - MM
6772	IF (A(MP,MP-1) .EQ. 0.0D0) GO TO 140
6773	MP1 = MP + 1
6774	C
6775	DO 100 I = MP1, IGH
6776	100 ORT(I) = A(I,MP-1)
6777	C
6778	DO 130 J = MP, IGH
6779	G = 0.0D0
6780	C
6781	DO 110 I = MP, IGH
6782	110 G = G + ORT(I) * Z(I,J)
6783	C .......... DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHES.
6784	C DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ..........
6785	G = (G / ORT(MP)) / A(MP,MP-1)
6786	C
6787	DO 120 I = MP, IGH
6788	120 Z(I,J) = Z(I,J) + G * ORT(I)
6789	C
6790	130 CONTINUE
6791	C
6792	140 CONTINUE
6793	C
6794	200 RETURN
6795	END
6796	SUBROUTINE QZHES(NM,N,A,B,MATZ,Z)
6797	C
6798	INTEGER I,J,K,L,N,LB,L1,NM,NK1,NM1,NM2
6799	DOUBLE PRECISION A(NM,N),B(NM,N),Z(NM,N)
6800	DOUBLE PRECISION R,S,T,U1,U2,V1,V2,RHO
6801	LOGICAL MATZ
6802	C
6803	C THIS SUBROUTINE IS THE FIRST STEP OF THE QZ ALGORITHM
6804	C FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS,
6805	C SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART.
6806	C
6807	C THIS SUBROUTINE ACCEPTS A PAIR OF REAL GENERAL MATRICES AND
6808	C REDUCES ONE OF THEM TO UPPER HESSENBERG FORM AND THE OTHER
6809	C TO UPPER TRIANGULAR FORM USING ORTHOGONAL TRANSFORMATIONS.
6810	C IT IS USUALLY FOLLOWED BY QZIT, QZVAL AND, POSSIBLY, QZVEC.
6811	C
6812	C ON INPUT
6813	C
6814	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
6815	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
6816	C DIMENSION STATEMENT.
6817	C
6818	C N IS THE ORDER OF THE MATRICES.
6819	C
6820	C A CONTAINS A REAL GENERAL MATRIX.
6821	C
6822	C B CONTAINS A REAL GENERAL MATRIX.
6823	C
6824	C MATZ SHOULD BE SET TO .TRUE. IF THE RIGHT HAND TRANSFORMATIONS
6825	C ARE TO BE ACCUMULATED FOR LATER USE IN COMPUTING
6826	C EIGENVECTORS, AND TO .FALSE. OTHERWISE.
6827	C
6828	C ON OUTPUT
6829	C
6830	C A HAS BEEN REDUCED TO UPPER HESSENBERG FORM. THE ELEMENTS
6831	C BELOW THE FIRST SUBDIAGONAL HAVE BEEN SET TO ZERO.
6832	C
6833	C B HAS BEEN REDUCED TO UPPER TRIANGULAR FORM. THE ELEMENTS
6834	C BELOW THE MAIN DIAGONAL HAVE BEEN SET TO ZERO.
6835	C
6836	C Z CONTAINS THE PRODUCT OF THE RIGHT HAND TRANSFORMATIONS IF
6837	C MATZ HAS BEEN SET TO .TRUE. OTHERWISE, Z IS NOT REFERENCED.
6838	C
6839	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
6840	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
6841	C
6842	C THIS VERSION DATED AUGUST 1983.
6843	C
6844	C ------------------------------------------------------------------
6845	C
6846	C .......... INITIALIZE Z ..........
6847	IF (.NOT. MATZ) GO TO 10
6848	C
6849	DO 3 J = 1, N
6850	C
6851	DO 2 I = 1, N
6852	Z(I,J) = 0.0D0
6853	2 CONTINUE
6854	C
6855	Z(J,J) = 1.0D0
6856	3 CONTINUE
6857	C .......... REDUCE B TO UPPER TRIANGULAR FORM ..........
6858	10 IF (N .LE. 1) GO TO 170
6859	NM1 = N - 1
6860	C
6861	DO 100 L = 1, NM1
6862	L1 = L + 1
6863	S = 0.0D0
6864	C
6865	DO 20 I = L1, N
6866	S = S + DABS(B(I,L))
6867	20 CONTINUE
6868	C
6869	IF (S .EQ. 0.0D0) GO TO 100
6870	S = S + DABS(B(L,L))
6871	R = 0.0D0
6872	C
6873	DO 25 I = L, N
6874	B(I,L) = B(I,L) / S
6875	R = R + B(I,L)**2
6876	25 CONTINUE
6877	C
6878	R = DSIGN(DSQRT(R),B(L,L))
6879	B(L,L) = B(L,L) + R
6880	RHO = R * B(L,L)
6881	C
6882	DO 50 J = L1, N
6883	T = 0.0D0
6884	C
6885	DO 30 I = L, N
6886	T = T + B(I,L) * B(I,J)
6887	30 CONTINUE
6888	C
6889	T = -T / RHO
6890	C
6891	DO 40 I = L, N
6892	B(I,J) = B(I,J) + T * B(I,L)
6893	40 CONTINUE
6894	C
6895	50 CONTINUE
6896	C
6897	DO 80 J = 1, N
6898	T = 0.0D0
6899	C
6900	DO 60 I = L, N
6901	T = T + B(I,L) * A(I,J)
6902	60 CONTINUE
6903	C
6904	T = -T / RHO
6905	C
6906	DO 70 I = L, N
6907	A(I,J) = A(I,J) + T * B(I,L)
6908	70 CONTINUE
6909	C
6910	80 CONTINUE
6911	C
6912	B(L,L) = -S * R
6913	C
6914	DO 90 I = L1, N
6915	B(I,L) = 0.0D0
6916	90 CONTINUE
6917	C
6918	100 CONTINUE
6919	C .......... REDUCE A TO UPPER HESSENBERG FORM, WHILE
6920	C KEEPING B TRIANGULAR ..........
6921	IF (N .EQ. 2) GO TO 170
6922	NM2 = N - 2
6923	C
6924	DO 160 K = 1, NM2
6925	NK1 = NM1 - K
6926	C .......... FOR L=N-1 STEP -1 UNTIL K+1 DO -- ..........
6927	DO 150 LB = 1, NK1
6928	L = N - LB
6929	L1 = L + 1
6930	C .......... ZERO A(L+1,K) ..........
6931	S = DABS(A(L,K)) + DABS(A(L1,K))
6932	IF (S .EQ. 0.0D0) GO TO 150
6933	U1 = A(L,K) / S
6934	U2 = A(L1,K) / S
6935	R = DSIGN(DSQRT(U1U1+U2U2),U1)
6936	V1 = -(U1 + R) / R
6937	V2 = -U2 / R
6938	U2 = V2 / V1
6939	C
6940	DO 110 J = K, N
6941	T = A(L,J) + U2 * A(L1,J)
6942	A(L,J) = A(L,J) + T * V1
6943	A(L1,J) = A(L1,J) + T * V2
6944	110 CONTINUE
6945	C
6946	A(L1,K) = 0.0D0
6947	C
6948	DO 120 J = L, N
6949	T = B(L,J) + U2 * B(L1,J)
6950	B(L,J) = B(L,J) + T * V1
6951	B(L1,J) = B(L1,J) + T * V2
6952	120 CONTINUE
6953	C .......... ZERO B(L+1,L) ..........
6954	S = DABS(B(L1,L1)) + DABS(B(L1,L))
6955	IF (S .EQ. 0.0D0) GO TO 150
6956	U1 = B(L1,L1) / S
6957	U2 = B(L1,L) / S
6958	R = DSIGN(DSQRT(U1U1+U2U2),U1)
6959	V1 = -(U1 + R) / R
6960	V2 = -U2 / R
6961	U2 = V2 / V1
6962	C
6963	DO 130 I = 1, L1
6964	T = B(I,L1) + U2 * B(I,L)
6965	B(I,L1) = B(I,L1) + T * V1
6966	B(I,L) = B(I,L) + T * V2
6967	130 CONTINUE
6968	C
6969	B(L1,L) = 0.0D0
6970	C
6971	DO 140 I = 1, N
6972	T = A(I,L1) + U2 * A(I,L)
6973	A(I,L1) = A(I,L1) + T * V1
6974	A(I,L) = A(I,L) + T * V2
6975	140 CONTINUE
6976	C
6977	IF (.NOT. MATZ) GO TO 150
6978	C
6979	DO 145 I = 1, N
6980	T = Z(I,L1) + U2 * Z(I,L)
6981	Z(I,L1) = Z(I,L1) + T * V1
6982	Z(I,L) = Z(I,L) + T * V2
6983	145 CONTINUE
6984	C
6985	150 CONTINUE
6986	C
6987	160 CONTINUE
6988	C
6989	170 RETURN
6990	END
6991	SUBROUTINE QZIT(NM,N,A,B,EPS1,MATZ,Z,IERR)
6992	C
6993	INTEGER I,J,K,L,N,EN,K1,K2,LD,LL,L1,NA,NM,ISH,ITN,ITS,KM1,LM1,
6994	X ENM2,IERR,LOR1,ENORN
6995	DOUBLE PRECISION A(NM,N),B(NM,N),Z(NM,N)
6996	DOUBLE PRECISION R,S,T,A1,A2,A3,EP,SH,U1,U2,U3,V1,V2,V3,ANI,A11,
6997	X A12,A21,A22,A33,A34,A43,A44,BNI,B11,B12,B22,B33,B34,
6998	X B44,EPSA,EPSB,EPS1,ANORM,BNORM,EPSLON
6999	LOGICAL MATZ,NOTLAS
7000	C
7001	C THIS SUBROUTINE IS THE SECOND STEP OF THE QZ ALGORITHM
7002	C FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS,
7003	C SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART,
7004	C AS MODIFIED IN TECHNICAL NOTE NASA TN D-7305(1973) BY WARD.
7005	C
7006	C THIS SUBROUTINE ACCEPTS A PAIR OF REAL MATRICES, ONE OF THEM
7007	C IN UPPER HESSENBERG FORM AND THE OTHER IN UPPER TRIANGULAR FORM.
7008	C IT REDUCES THE HESSENBERG MATRIX TO QUASI-TRIANGULAR FORM USING
7009	C ORTHOGONAL TRANSFORMATIONS WHILE MAINTAINING THE TRIANGULAR FORM
7010	C OF THE OTHER MATRIX. IT IS USUALLY PRECEDED BY QZHES AND
7011	C FOLLOWED BY QZVAL AND, POSSIBLY, QZVEC.
7012	C
7013	C ON INPUT
7014	C
7015	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
7016	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
7017	C DIMENSION STATEMENT.
7018	C
7019	C N IS THE ORDER OF THE MATRICES.
7020	C
7021	C A CONTAINS A REAL UPPER HESSENBERG MATRIX.
7022	C
7023	C B CONTAINS A REAL UPPER TRIANGULAR MATRIX.
7024	C
7025	C EPS1 IS A TOLERANCE USED TO DETERMINE NEGLIGIBLE ELEMENTS.
7026	C EPS1 = 0.0 (OR NEGATIVE) MAY BE INPUT, IN WHICH CASE AN
7027	C ELEMENT WILL BE NEGLECTED ONLY IF IT IS LESS THAN ROUNDOFF
7028	C ERROR TIMES THE NORM OF ITS MATRIX. IF THE INPUT EPS1 IS
7029	C POSITIVE, THEN AN ELEMENT WILL BE CONSIDERED NEGLIGIBLE
7030	C IF IT IS LESS THAN EPS1 TIMES THE NORM OF ITS MATRIX. A
7031	C POSITIVE VALUE OF EPS1 MAY RESULT IN FASTER EXECUTION,
7032	C BUT LESS ACCURATE RESULTS.
7033	C
7034	C MATZ SHOULD BE SET TO .TRUE. IF THE RIGHT HAND TRANSFORMATIONS
7035	C ARE TO BE ACCUMULATED FOR LATER USE IN COMPUTING
7036	C EIGENVECTORS, AND TO .FALSE. OTHERWISE.
7037	C
7038	C Z CONTAINS, IF MATZ HAS BEEN SET TO .TRUE., THE
7039	C TRANSFORMATION MATRIX PRODUCED IN THE REDUCTION
7040	C BY QZHES, IF PERFORMED, OR ELSE THE IDENTITY MATRIX.
7041	C IF MATZ HAS BEEN SET TO .FALSE., Z IS NOT REFERENCED.
7042	C
7043	C ON OUTPUT
7044	C
7045	C A HAS BEEN REDUCED TO QUASI-TRIANGULAR FORM. THE ELEMENTS
7046	C BELOW THE FIRST SUBDIAGONAL ARE STILL ZERO AND NO TWO
7047	C CONSECUTIVE SUBDIAGONAL ELEMENTS ARE NONZERO.
7048	C
7049	C B IS STILL IN UPPER TRIANGULAR FORM, ALTHOUGH ITS ELEMENTS
7050	C HAVE BEEN ALTERED. THE LOCATION B(N,1) IS USED TO STORE
7051	C EPS1 TIMES THE NORM OF B FOR LATER USE BY QZVAL AND QZVEC.
7052	C
7053	C Z CONTAINS THE PRODUCT OF THE RIGHT HAND TRANSFORMATIONS
7054	C (FOR BOTH STEPS) IF MATZ HAS BEEN SET TO .TRUE..
7055	C
7056	C IERR IS SET TO
7057	C ZERO FOR NORMAL RETURN,
7058	C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
7059	C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
7060	C
7061	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
7062	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
7063	C
7064	C THIS VERSION DATED AUGUST 1983.
7065	C
7066	C ------------------------------------------------------------------
7067	C
7068	IERR = 0
7069	C .......... COMPUTE EPSA,EPSB ..........
7070	ANORM = 0.0D0
7071	BNORM = 0.0D0
7072	C
7073	DO 30 I = 1, N
7074	ANI = 0.0D0
7075	IF (I .NE. 1) ANI = DABS(A(I,I-1))
7076	BNI = 0.0D0
7077	C
7078	DO 20 J = I, N
7079	ANI = ANI + DABS(A(I,J))
7080	BNI = BNI + DABS(B(I,J))
7081	20 CONTINUE
7082	C
7083	IF (ANI .GT. ANORM) ANORM = ANI
7084	IF (BNI .GT. BNORM) BNORM = BNI
7085	30 CONTINUE
7086	C
7087	IF (ANORM .EQ. 0.0D0) ANORM = 1.0D0
7088	IF (BNORM .EQ. 0.0D0) BNORM = 1.0D0
7089	EP = EPS1
7090	IF (EP .GT. 0.0D0) GO TO 50
7091	C .......... USE ROUNDOFF LEVEL IF EPS1 IS ZERO ..........
7092	EP = EPSLON(1.0D0)
7093	50 EPSA = EP * ANORM
7094	EPSB = EP * BNORM
7095	C .......... REDUCE A TO QUASI-TRIANGULAR FORM, WHILE
7096	C KEEPING B TRIANGULAR ..........
7097	LOR1 = 1
7098	ENORN = N
7099	EN = N
7100	ITN = 30*N
7101	C .......... BEGIN QZ STEP ..........
7102	60 IF (EN .LE. 2) GO TO 1001
7103	IF (.NOT. MATZ) ENORN = EN
7104	ITS = 0
7105	NA = EN - 1
7106	ENM2 = NA - 1
7107	70 ISH = 2
7108	C .......... CHECK FOR CONVERGENCE OR REDUCIBILITY.
7109	C FOR L=EN STEP -1 UNTIL 1 DO -- ..........
7110	DO 80 LL = 1, EN
7111	LM1 = EN - LL
7112	L = LM1 + 1
7113	IF (L .EQ. 1) GO TO 95
7114	IF (DABS(A(L,LM1)) .LE. EPSA) GO TO 90
7115	80 CONTINUE
7116	C
7117	90 A(L,LM1) = 0.0D0
7118	IF (L .LT. NA) GO TO 95
7119	C .......... 1-BY-1 OR 2-BY-2 BLOCK ISOLATED ..........
7120	EN = LM1
7121	GO TO 60
7122	C .......... CHECK FOR SMALL TOP OF B ..........
7123	95 LD = L
7124	100 L1 = L + 1
7125	B11 = B(L,L)
7126	IF (DABS(B11) .GT. EPSB) GO TO 120
7127	B(L,L) = 0.0D0
7128	S = DABS(A(L,L)) + DABS(A(L1,L))
7129	U1 = A(L,L) / S
7130	U2 = A(L1,L) / S
7131	R = DSIGN(DSQRT(U1U1+U2U2),U1)
7132	V1 = -(U1 + R) / R
7133	V2 = -U2 / R
7134	U2 = V2 / V1
7135	C
7136	DO 110 J = L, ENORN
7137	T = A(L,J) + U2 * A(L1,J)
7138	A(L,J) = A(L,J) + T * V1
7139	A(L1,J) = A(L1,J) + T * V2
7140	T = B(L,J) + U2 * B(L1,J)
7141	B(L,J) = B(L,J) + T * V1
7142	B(L1,J) = B(L1,J) + T * V2
7143	110 CONTINUE
7144	C
7145	IF (L .NE. 1) A(L,LM1) = -A(L,LM1)
7146	LM1 = L
7147	L = L1
7148	GO TO 90
7149	120 A11 = A(L,L) / B11
7150	A21 = A(L1,L) / B11
7151	IF (ISH .EQ. 1) GO TO 140
7152	C .......... ITERATION STRATEGY ..........
7153	IF (ITN .EQ. 0) GO TO 1000
7154	IF (ITS .EQ. 10) GO TO 155
7155	C .......... DETERMINE TYPE OF SHIFT ..........
7156	B22 = B(L1,L1)
7157	IF (DABS(B22) .LT. EPSB) B22 = EPSB
7158	B33 = B(NA,NA)
7159	IF (DABS(B33) .LT. EPSB) B33 = EPSB
7160	B44 = B(EN,EN)
7161	IF (DABS(B44) .LT. EPSB) B44 = EPSB
7162	A33 = A(NA,NA) / B33
7163	A34 = A(NA,EN) / B44
7164	A43 = A(EN,NA) / B33
7165	A44 = A(EN,EN) / B44
7166	B34 = B(NA,EN) / B44
7167	T = 0.5D0 * (A43 * B34 - A33 - A44)
7168	R = T * T + A34 * A43 - A33 * A44
7169	IF (R .LT. 0.0D0) GO TO 150
7170	C .......... DETERMINE SINGLE SHIFT ZEROTH COLUMN OF A ..........
7171	ISH = 1
7172	R = DSQRT(R)
7173	SH = -T + R
7174	S = -T - R
7175	IF (DABS(S-A44) .LT. DABS(SH-A44)) SH = S
7176	C .......... LOOK FOR TWO CONSECUTIVE SMALL
7177	C SUB-DIAGONAL ELEMENTS OF A.
7178	C FOR L=EN-2 STEP -1 UNTIL LD DO -- ..........
7179	DO 130 LL = LD, ENM2
7180	L = ENM2 + LD - LL
7181	IF (L .EQ. LD) GO TO 140
7182	LM1 = L - 1
7183	L1 = L + 1
7184	T = A(L,L)
7185	IF (DABS(B(L,L)) .GT. EPSB) T = T - SH * B(L,L)
7186	IF (DABS(A(L,LM1)) .LE. DABS(T/A(L1,L)) * EPSA) GO TO 100
7187	130 CONTINUE
7188	C
7189	140 A1 = A11 - SH
7190	A2 = A21
7191	IF (L .NE. LD) A(L,LM1) = -A(L,LM1)
7192	GO TO 160
7193	C .......... DETERMINE DOUBLE SHIFT ZEROTH COLUMN OF A ..........
7194	150 A12 = A(L,L1) / B22
7195	A22 = A(L1,L1) / B22
7196	B12 = B(L,L1) / B22
7197	A1 = ((A33 - A11) * (A44 - A11) - A34 * A43 + A43 * B34 * A11)
7198	X / A21 + A12 - A11 * B12
7199	A2 = (A22 - A11) - A21 * B12 - (A33 - A11) - (A44 - A11)
7200	X + A43 * B34
7201	A3 = A(L1+1,L1) / B22
7202	GO TO 160
7203	C .......... AD HOC SHIFT ..........
7204	155 A1 = 0.0D0
7205	A2 = 1.0D0
7206	A3 = 1.1605D0
7207	160 ITS = ITS + 1
7208	ITN = ITN - 1
7209	IF (.NOT. MATZ) LOR1 = LD
7210	C .......... MAIN LOOP ..........
7211	DO 260 K = L, NA
7212	NOTLAS = K .NE. NA .AND. ISH .EQ. 2
7213	K1 = K + 1
7214	K2 = K + 2
7215	KM1 = MAX0(K-1,L)
7216	LL = MIN0(EN,K1+ISH)
7217	IF (NOTLAS) GO TO 190
7218	C .......... ZERO A(K+1,K-1) ..........
7219	IF (K .EQ. L) GO TO 170
7220	A1 = A(K,KM1)
7221	A2 = A(K1,KM1)
7222	170 S = DABS(A1) + DABS(A2)
7223	IF (S .EQ. 0.0D0) GO TO 70
7224	U1 = A1 / S
7225	U2 = A2 / S
7226	R = DSIGN(DSQRT(U1U1+U2U2),U1)
7227	V1 = -(U1 + R) / R
7228	V2 = -U2 / R
7229	U2 = V2 / V1
7230	C
7231	DO 180 J = KM1, ENORN
7232	T = A(K,J) + U2 * A(K1,J)
7233	A(K,J) = A(K,J) + T * V1
7234	A(K1,J) = A(K1,J) + T * V2
7235	T = B(K,J) + U2 * B(K1,J)
7236	B(K,J) = B(K,J) + T * V1
7237	B(K1,J) = B(K1,J) + T * V2
7238	180 CONTINUE
7239	C
7240	IF (K .NE. L) A(K1,KM1) = 0.0D0
7241	GO TO 240
7242	C .......... ZERO A(K+1,K-1) AND A(K+2,K-1) ..........
7243	190 IF (K .EQ. L) GO TO 200
7244	A1 = A(K,KM1)
7245	A2 = A(K1,KM1)
7246	A3 = A(K2,KM1)
7247	200 S = DABS(A1) + DABS(A2) + DABS(A3)
7248	IF (S .EQ. 0.0D0) GO TO 260
7249	U1 = A1 / S
7250	U2 = A2 / S
7251	U3 = A3 / S
7252	R = DSIGN(DSQRT(U1U1+U2U2+U3*U3),U1)
7253	V1 = -(U1 + R) / R
7254	V2 = -U2 / R
7255	V3 = -U3 / R
7256	U2 = V2 / V1
7257	U3 = V3 / V1
7258	C
7259	DO 210 J = KM1, ENORN
7260	T = A(K,J) + U2 * A(K1,J) + U3 * A(K2,J)
7261	A(K,J) = A(K,J) + T * V1
7262	A(K1,J) = A(K1,J) + T * V2
7263	A(K2,J) = A(K2,J) + T * V3
7264	T = B(K,J) + U2 * B(K1,J) + U3 * B(K2,J)
7265	B(K,J) = B(K,J) + T * V1
7266	B(K1,J) = B(K1,J) + T * V2
7267	B(K2,J) = B(K2,J) + T * V3
7268	210 CONTINUE
7269	C
7270	IF (K .EQ. L) GO TO 220
7271	A(K1,KM1) = 0.0D0
7272	A(K2,KM1) = 0.0D0
7273	C .......... ZERO B(K+2,K+1) AND B(K+2,K) ..........
7274	220 S = DABS(B(K2,K2)) + DABS(B(K2,K1)) + DABS(B(K2,K))
7275	IF (S .EQ. 0.0D0) GO TO 240
7276	U1 = B(K2,K2) / S
7277	U2 = B(K2,K1) / S
7278	U3 = B(K2,K) / S
7279	R = DSIGN(DSQRT(U1U1+U2U2+U3*U3),U1)
7280	V1 = -(U1 + R) / R
7281	V2 = -U2 / R
7282	V3 = -U3 / R
7283	U2 = V2 / V1
7284	U3 = V3 / V1
7285	C
7286	DO 230 I = LOR1, LL
7287	T = A(I,K2) + U2 * A(I,K1) + U3 * A(I,K)
7288	A(I,K2) = A(I,K2) + T * V1
7289	A(I,K1) = A(I,K1) + T * V2
7290	A(I,K) = A(I,K) + T * V3
7291	T = B(I,K2) + U2 * B(I,K1) + U3 * B(I,K)
7292	B(I,K2) = B(I,K2) + T * V1
7293	B(I,K1) = B(I,K1) + T * V2
7294	B(I,K) = B(I,K) + T * V3
7295	230 CONTINUE
7296	C
7297	B(K2,K) = 0.0D0
7298	B(K2,K1) = 0.0D0
7299	IF (.NOT. MATZ) GO TO 240
7300	C
7301	DO 235 I = 1, N
7302	T = Z(I,K2) + U2 * Z(I,K1) + U3 * Z(I,K)
7303	Z(I,K2) = Z(I,K2) + T * V1
7304	Z(I,K1) = Z(I,K1) + T * V2
7305	Z(I,K) = Z(I,K) + T * V3
7306	235 CONTINUE
7307	C .......... ZERO B(K+1,K) ..........
7308	240 S = DABS(B(K1,K1)) + DABS(B(K1,K))
7309	IF (S .EQ. 0.0D0) GO TO 260
7310	U1 = B(K1,K1) / S
7311	U2 = B(K1,K) / S
7312	R = DSIGN(DSQRT(U1U1+U2U2),U1)
7313	V1 = -(U1 + R) / R
7314	V2 = -U2 / R
7315	U2 = V2 / V1
7316	C
7317	DO 250 I = LOR1, LL
7318	T = A(I,K1) + U2 * A(I,K)
7319	A(I,K1) = A(I,K1) + T * V1
7320	A(I,K) = A(I,K) + T * V2
7321	T = B(I,K1) + U2 * B(I,K)
7322	B(I,K1) = B(I,K1) + T * V1
7323	B(I,K) = B(I,K) + T * V2
7324	250 CONTINUE
7325	C
7326	B(K1,K) = 0.0D0
7327	IF (.NOT. MATZ) GO TO 260
7328	C
7329	DO 255 I = 1, N
7330	T = Z(I,K1) + U2 * Z(I,K)
7331	Z(I,K1) = Z(I,K1) + T * V1
7332	Z(I,K) = Z(I,K) + T * V2
7333	255 CONTINUE
7334	C
7335	260 CONTINUE
7336	C .......... END QZ STEP ..........
7337	GO TO 70
7338	C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
7339	C CONVERGED AFTER 30*N ITERATIONS ..........
7340	1000 IERR = EN
7341	C .......... SAVE EPSB FOR USE BY QZVAL AND QZVEC ..........
7342	1001 IF (N .GT. 1) B(N,1) = EPSB
7343	RETURN
7344	END
7345	SUBROUTINE QZVAL(NM,N,A,B,ALFR,ALFI,BETA,MATZ,Z)
7346	C
7347	INTEGER I,J,N,EN,NA,NM,NN,ISW
7348	DOUBLE PRECISION A(NM,N),B(NM,N),ALFR(N),ALFI(N),BETA(N),Z(NM,N)
7349	DOUBLE PRECISION C,D,E,R,S,T,AN,A1,A2,BN,CQ,CZ,DI,DR,EI,TI,TR,U1,
7350	X U2,V1,V2,A1I,A11,A12,A2I,A21,A22,B11,B12,B22,SQI,SQR,
7351	X SSI,SSR,SZI,SZR,A11I,A11R,A12I,A12R,A22I,A22R,EPSB
7352	LOGICAL MATZ
7353	C
7354	C THIS SUBROUTINE IS THE THIRD STEP OF THE QZ ALGORITHM
7355	C FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS,
7356	C SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART.
7357	C
7358	C THIS SUBROUTINE ACCEPTS A PAIR OF REAL MATRICES, ONE OF THEM
7359	C IN QUASI-TRIANGULAR FORM AND THE OTHER IN UPPER TRIANGULAR FORM.
7360	C IT REDUCES THE QUASI-TRIANGULAR MATRIX FURTHER, SO THAT ANY
7361	C REMAINING 2-BY-2 BLOCKS CORRESPOND TO PAIRS OF COMPLEX
7362	C EIGENVALUES, AND RETURNS QUANTITIES WHOSE RATIOS GIVE THE
7363	C GENERALIZED EIGENVALUES. IT IS USUALLY PRECEDED BY QZHES
7364	C AND QZIT AND MAY BE FOLLOWED BY QZVEC.
7365	C
7366	C ON INPUT
7367	C
7368	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
7369	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
7370	C DIMENSION STATEMENT.
7371	C
7372	C N IS THE ORDER OF THE MATRICES.
7373	C
7374	C A CONTAINS A REAL UPPER QUASI-TRIANGULAR MATRIX.
7375	C
7376	C B CONTAINS A REAL UPPER TRIANGULAR MATRIX. IN ADDITION,
7377	C LOCATION B(N,1) CONTAINS THE TOLERANCE QUANTITY (EPSB)
7378	C COMPUTED AND SAVED IN QZIT.
7379	C
7380	C MATZ SHOULD BE SET TO .TRUE. IF THE RIGHT HAND TRANSFORMATIONS
7381	C ARE TO BE ACCUMULATED FOR LATER USE IN COMPUTING
7382	C EIGENVECTORS, AND TO .FALSE. OTHERWISE.
7383	C
7384	C Z CONTAINS, IF MATZ HAS BEEN SET TO .TRUE., THE
7385	C TRANSFORMATION MATRIX PRODUCED IN THE REDUCTIONS BY QZHES
7386	C AND QZIT, IF PERFORMED, OR ELSE THE IDENTITY MATRIX.
7387	C IF MATZ HAS BEEN SET TO .FALSE., Z IS NOT REFERENCED.
7388	C
7389	C ON OUTPUT
7390	C
7391	C A HAS BEEN REDUCED FURTHER TO A QUASI-TRIANGULAR MATRIX
7392	C IN WHICH ALL NONZERO SUBDIAGONAL ELEMENTS CORRESPOND TO
7393	C PAIRS OF COMPLEX EIGENVALUES.
7394	C
7395	C B IS STILL IN UPPER TRIANGULAR FORM, ALTHOUGH ITS ELEMENTS
7396	C HAVE BEEN ALTERED. B(N,1) IS UNALTERED.
7397	C
7398	C ALFR AND ALFI CONTAIN THE REAL AND IMAGINARY PARTS OF THE
7399	C DIAGONAL ELEMENTS OF THE TRIANGULAR MATRIX THAT WOULD BE
7400	C OBTAINED IF A WERE REDUCED COMPLETELY TO TRIANGULAR FORM
7401	C BY UNITARY TRANSFORMATIONS. NON-ZERO VALUES OF ALFI OCCUR
7402	C IN PAIRS, THE FIRST MEMBER POSITIVE AND THE SECOND NEGATIVE.
7403	C
7404	C BETA CONTAINS THE DIAGONAL ELEMENTS OF THE CORRESPONDING B,
7405	C NORMALIZED TO BE REAL AND NON-NEGATIVE. THE GENERALIZED
7406	C EIGENVALUES ARE THEN THE RATIOS ((ALFR+I*ALFI)/BETA).
7407	C
7408	C Z CONTAINS THE PRODUCT OF THE RIGHT HAND TRANSFORMATIONS
7409	C (FOR ALL THREE STEPS) IF MATZ HAS BEEN SET TO .TRUE.
7410	C
7411	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
7412	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
7413	C
7414	C THIS VERSION DATED AUGUST 1983.
7415	C
7416	C ------------------------------------------------------------------
7417	C
7418	EPSB = B(N,1)
7419	ISW = 1
7420	C .......... FIND EIGENVALUES OF QUASI-TRIANGULAR MATRICES.
7421	C FOR EN=N STEP -1 UNTIL 1 DO -- ..........
7422	DO 510 NN = 1, N
7423	EN = N + 1 - NN
7424	NA = EN - 1
7425	IF (ISW .EQ. 2) GO TO 505
7426	IF (EN .EQ. 1) GO TO 410
7427	IF (A(EN,NA) .NE. 0.0D0) GO TO 420
7428	C .......... 1-BY-1 BLOCK, ONE REAL ROOT ..........
7429	410 ALFR(EN) = A(EN,EN)
7430	IF (B(EN,EN) .LT. 0.0D0) ALFR(EN) = -ALFR(EN)
7431	BETA(EN) = DABS(B(EN,EN))
7432	ALFI(EN) = 0.0D0
7433	GO TO 510
7434	C .......... 2-BY-2 BLOCK ..........
7435	420 IF (DABS(B(NA,NA)) .LE. EPSB) GO TO 455
7436	IF (DABS(B(EN,EN)) .GT. EPSB) GO TO 430
7437	A1 = A(EN,EN)
7438	A2 = A(EN,NA)
7439	BN = 0.0D0
7440	GO TO 435
7441	430 AN = DABS(A(NA,NA)) + DABS(A(NA,EN)) + DABS(A(EN,NA))
7442	X + DABS(A(EN,EN))
7443	BN = DABS(B(NA,NA)) + DABS(B(NA,EN)) + DABS(B(EN,EN))
7444	A11 = A(NA,NA) / AN
7445	A12 = A(NA,EN) / AN
7446	A21 = A(EN,NA) / AN
7447	A22 = A(EN,EN) / AN
7448	B11 = B(NA,NA) / BN
7449	B12 = B(NA,EN) / BN
7450	B22 = B(EN,EN) / BN
7451	E = A11 / B11
7452	EI = A22 / B22
7453	S = A21 / (B11 * B22)
7454	T = (A22 - E * B22) / B22
7455	IF (DABS(E) .LE. DABS(EI)) GO TO 431
7456	E = EI
7457	T = (A11 - E * B11) / B11
7458	431 C = 0.5D0 * (T - S * B12)
7459	D = C * C + S * (A12 - E * B12)
7460	IF (D .LT. 0.0D0) GO TO 480
7461	C .......... TWO REAL ROOTS.
7462	C ZERO BOTH A(EN,NA) AND B(EN,NA) ..........
7463	E = E + (C + DSIGN(DSQRT(D),C))
7464	A11 = A11 - E * B11
7465	A12 = A12 - E * B12
7466	A22 = A22 - E * B22
7467	IF (DABS(A11) + DABS(A12) .LT.
7468	X DABS(A21) + DABS(A22)) GO TO 432
7469	A1 = A12
7470	A2 = A11
7471	GO TO 435
7472	432 A1 = A22
7473	A2 = A21
7474	C .......... CHOOSE AND APPLY REAL Z ..........
7475	435 S = DABS(A1) + DABS(A2)
7476	U1 = A1 / S
7477	U2 = A2 / S
7478	R = DSIGN(DSQRT(U1U1+U2U2),U1)
7479	V1 = -(U1 + R) / R
7480	V2 = -U2 / R
7481	U2 = V2 / V1
7482	C
7483	DO 440 I = 1, EN
7484	T = A(I,EN) + U2 * A(I,NA)
7485	A(I,EN) = A(I,EN) + T * V1
7486	A(I,NA) = A(I,NA) + T * V2
7487	T = B(I,EN) + U2 * B(I,NA)
7488	B(I,EN) = B(I,EN) + T * V1
7489	B(I,NA) = B(I,NA) + T * V2
7490	440 CONTINUE
7491	C
7492	IF (.NOT. MATZ) GO TO 450
7493	C
7494	DO 445 I = 1, N
7495	T = Z(I,EN) + U2 * Z(I,NA)
7496	Z(I,EN) = Z(I,EN) + T * V1
7497	Z(I,NA) = Z(I,NA) + T * V2
7498	445 CONTINUE
7499	C
7500	450 IF (BN .EQ. 0.0D0) GO TO 475
7501	IF (AN .LT. DABS(E) * BN) GO TO 455
7502	A1 = B(NA,NA)
7503	A2 = B(EN,NA)
7504	GO TO 460
7505	455 A1 = A(NA,NA)
7506	A2 = A(EN,NA)
7507	C .......... CHOOSE AND APPLY REAL Q ..........
7508	460 S = DABS(A1) + DABS(A2)
7509	IF (S .EQ. 0.0D0) GO TO 475
7510	U1 = A1 / S
7511	U2 = A2 / S
7512	R = DSIGN(DSQRT(U1U1+U2U2),U1)
7513	V1 = -(U1 + R) / R
7514	V2 = -U2 / R
7515	U2 = V2 / V1
7516	C
7517	DO 470 J = NA, N
7518	T = A(NA,J) + U2 * A(EN,J)
7519	A(NA,J) = A(NA,J) + T * V1
7520	A(EN,J) = A(EN,J) + T * V2
7521	T = B(NA,J) + U2 * B(EN,J)
7522	B(NA,J) = B(NA,J) + T * V1
7523	B(EN,J) = B(EN,J) + T * V2
7524	470 CONTINUE
7525	C
7526	475 A(EN,NA) = 0.0D0
7527	B(EN,NA) = 0.0D0
7528	ALFR(NA) = A(NA,NA)
7529	ALFR(EN) = A(EN,EN)
7530	IF (B(NA,NA) .LT. 0.0D0) ALFR(NA) = -ALFR(NA)
7531	IF (B(EN,EN) .LT. 0.0D0) ALFR(EN) = -ALFR(EN)
7532	BETA(NA) = DABS(B(NA,NA))
7533	BETA(EN) = DABS(B(EN,EN))
7534	ALFI(EN) = 0.0D0
7535	ALFI(NA) = 0.0D0
7536	GO TO 505
7537	C .......... TWO COMPLEX ROOTS ..........
7538	480 E = E + C
7539	EI = DSQRT(-D)
7540	A11R = A11 - E * B11
7541	A11I = EI * B11
7542	A12R = A12 - E * B12
7543	A12I = EI * B12
7544	A22R = A22 - E * B22
7545	A22I = EI * B22
7546	IF (DABS(A11R) + DABS(A11I) + DABS(A12R) + DABS(A12I) .LT.
7547	X DABS(A21) + DABS(A22R) + DABS(A22I)) GO TO 482
7548	A1 = A12R
7549	A1I = A12I
7550	A2 = -A11R
7551	A2I = -A11I
7552	GO TO 485
7553	482 A1 = A22R
7554	A1I = A22I
7555	A2 = -A21
7556	A2I = 0.0D0
7557	C .......... CHOOSE COMPLEX Z ..........
7558	485 CZ = DSQRT(A1A1+A1IA1I)
7559	IF (CZ .EQ. 0.0D0) GO TO 487
7560	SZR = (A1 * A2 + A1I * A2I) / CZ
7561	SZI = (A1 * A2I - A1I * A2) / CZ
7562	R = DSQRT(CZCZ+SZRSZR+SZI*SZI)
7563	CZ = CZ / R
7564	SZR = SZR / R
7565	SZI = SZI / R
7566	GO TO 490
7567	487 SZR = 1.0D0
7568	SZI = 0.0D0
7569	490 IF (AN .LT. (DABS(E) + EI) * BN) GO TO 492
7570	A1 = CZ * B11 + SZR * B12
7571	A1I = SZI * B12
7572	A2 = SZR * B22
7573	A2I = SZI * B22
7574	GO TO 495
7575	492 A1 = CZ * A11 + SZR * A12
7576	A1I = SZI * A12
7577	A2 = CZ * A21 + SZR * A22
7578	A2I = SZI * A22
7579	C .......... CHOOSE COMPLEX Q ..........
7580	495 CQ = DSQRT(A1A1+A1IA1I)
7581	IF (CQ .EQ. 0.0D0) GO TO 497
7582	SQR = (A1 * A2 + A1I * A2I) / CQ
7583	SQI = (A1 * A2I - A1I * A2) / CQ
7584	R = DSQRT(CQCQ+SQRSQR+SQI*SQI)
7585	CQ = CQ / R
7586	SQR = SQR / R
7587	SQI = SQI / R
7588	GO TO 500
7589	497 SQR = 1.0D0
7590	SQI = 0.0D0
7591	C .......... COMPUTE DIAGONAL ELEMENTS THAT WOULD RESULT
7592	C IF TRANSFORMATIONS WERE APPLIED ..........
7593	500 SSR = SQR * SZR + SQI * SZI
7594	SSI = SQR * SZI - SQI * SZR
7595	I = 1
7596	TR = CQ * CZ * A11 + CQ * SZR * A12 + SQR * CZ * A21
7597	X + SSR * A22
7598	TI = CQ * SZI * A12 - SQI * CZ * A21 + SSI * A22
7599	DR = CQ * CZ * B11 + CQ * SZR * B12 + SSR * B22
7600	DI = CQ * SZI * B12 + SSI * B22
7601	GO TO 503
7602	502 I = 2
7603	TR = SSR * A11 - SQR * CZ * A12 - CQ * SZR * A21
7604	X + CQ * CZ * A22
7605	TI = -SSI * A11 - SQI * CZ * A12 + CQ * SZI * A21
7606	DR = SSR * B11 - SQR * CZ * B12 + CQ * CZ * B22
7607	DI = -SSI * B11 - SQI * CZ * B12
7608	503 T = TI * DR - TR * DI
7609	J = NA
7610	IF (T .LT. 0.0D0) J = EN
7611	R = DSQRT(DRDR+DIDI)
7612	BETA(J) = BN * R
7613	ALFR(J) = AN * (TR * DR + TI * DI) / R
7614	ALFI(J) = AN * T / R
7615	IF (I .EQ. 1) GO TO 502
7616	505 ISW = 3 - ISW
7617	510 CONTINUE
7618	B(N,1) = EPSB
7619	C
7620	RETURN
7621	END
7622	SUBROUTINE QZVEC(NM,N,A,B,ALFR,ALFI,BETA,Z)
7623	C
7624	INTEGER I,J,K,M,N,EN,II,JJ,NA,NM,NN,ISW,ENM2
7625	DOUBLE PRECISION A(NM,N),B(NM,N),ALFR(N),ALFI(N),BETA(N),Z(NM,N)
7626	DOUBLE PRECISION D,Q,R,S,T,W,X,Y,DI,DR,RA,RR,SA,TI,TR,T1,T2,W1,X1,
7627	X ZZ,Z1,ALFM,ALMI,ALMR,BETM,EPSB
7628	C
7629	C THIS SUBROUTINE IS THE OPTIONAL FOURTH STEP OF THE QZ ALGORITHM
7630	C FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS,
7631	C SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART.
7632	C
7633	C THIS SUBROUTINE ACCEPTS A PAIR OF REAL MATRICES, ONE OF THEM IN
7634	C QUASI-TRIANGULAR FORM (IN WHICH EACH 2-BY-2 BLOCK CORRESPONDS TO
7635	C A PAIR OF COMPLEX EIGENVALUES) AND THE OTHER IN UPPER TRIANGULAR
7636	C FORM. IT COMPUTES THE EIGENVECTORS OF THE TRIANGULAR PROBLEM AND
7637	C TRANSFORMS THE RESULTS BACK TO THE ORIGINAL COORDINATE SYSTEM.
7638	C IT IS USUALLY PRECEDED BY QZHES, QZIT, AND QZVAL.
7639	C
7640	C ON INPUT
7641	C
7642	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
7643	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
7644	C DIMENSION STATEMENT.
7645	C
7646	C N IS THE ORDER OF THE MATRICES.
7647	C
7648	C A CONTAINS A REAL UPPER QUASI-TRIANGULAR MATRIX.
7649	C
7650	C B CONTAINS A REAL UPPER TRIANGULAR MATRIX. IN ADDITION,
7651	C LOCATION B(N,1) CONTAINS THE TOLERANCE QUANTITY (EPSB)
7652	C COMPUTED AND SAVED IN QZIT.
7653	C
7654	C ALFR, ALFI, AND BETA ARE VECTORS WITH COMPONENTS WHOSE
7655	C RATIOS ((ALFR+I*ALFI)/BETA) ARE THE GENERALIZED
7656	C EIGENVALUES. THEY ARE USUALLY OBTAINED FROM QZVAL.
7657	C
7658	C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
7659	C REDUCTIONS BY QZHES, QZIT, AND QZVAL, IF PERFORMED.
7660	C IF THE EIGENVECTORS OF THE TRIANGULAR PROBLEM ARE
7661	C DESIRED, Z MUST CONTAIN THE IDENTITY MATRIX.
7662	C
7663	C ON OUTPUT
7664	C
7665	C A IS UNALTERED. ITS SUBDIAGONAL ELEMENTS PROVIDE INFORMATION
7666	C ABOUT THE STORAGE OF THE COMPLEX EIGENVECTORS.
7667	C
7668	C B HAS BEEN DESTROYED.
7669	C
7670	C ALFR, ALFI, AND BETA ARE UNALTERED.
7671	C
7672	C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS.
7673	C IF ALFI(I) .EQ. 0.0, THE I-TH EIGENVALUE IS REAL AND
7674	C THE I-TH COLUMN OF Z CONTAINS ITS EIGENVECTOR.
7675	C IF ALFI(I) .NE. 0.0, THE I-TH EIGENVALUE IS COMPLEX.
7676	C IF ALFI(I) .GT. 0.0, THE EIGENVALUE IS THE FIRST OF
7677	C A COMPLEX PAIR AND THE I-TH AND (I+1)-TH COLUMNS
7678	C OF Z CONTAIN ITS EIGENVECTOR.
7679	C IF ALFI(I) .LT. 0.0, THE EIGENVALUE IS THE SECOND OF
7680	C A COMPLEX PAIR AND THE (I-1)-TH AND I-TH COLUMNS
7681	C OF Z CONTAIN THE CONJUGATE OF ITS EIGENVECTOR.
7682	C EACH EIGENVECTOR IS NORMALIZED SO THAT THE MODULUS
7683	C OF ITS LARGEST COMPONENT IS 1.0 .
7684	C
7685	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
7686	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
7687	C
7688	C THIS VERSION DATED AUGUST 1983.
7689	C
7690	C ------------------------------------------------------------------
7691	C
7692	EPSB = B(N,1)
7693	ISW = 1
7694	C .......... FOR EN=N STEP -1 UNTIL 1 DO -- ..........
7695	DO 800 NN = 1, N
7696	EN = N + 1 - NN
7697	NA = EN - 1
7698	IF (ISW .EQ. 2) GO TO 795
7699	IF (ALFI(EN) .NE. 0.0D0) GO TO 710
7700	C .......... REAL VECTOR ..........
7701	M = EN
7702	B(EN,EN) = 1.0D0
7703	IF (NA .EQ. 0) GO TO 800
7704	ALFM = ALFR(M)
7705	BETM = BETA(M)
7706	C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
7707	DO 700 II = 1, NA
7708	I = EN - II
7709	W = BETM * A(I,I) - ALFM * B(I,I)
7710	R = 0.0D0
7711	C
7712	DO 610 J = M, EN
7713	610 R = R + (BETM * A(I,J) - ALFM * B(I,J)) * B(J,EN)
7714	C
7715	IF (I .EQ. 1 .OR. ISW .EQ. 2) GO TO 630
7716	IF (BETM * A(I,I-1) .EQ. 0.0D0) GO TO 630
7717	ZZ = W
7718	S = R
7719	GO TO 690
7720	630 M = I
7721	IF (ISW .EQ. 2) GO TO 640
7722	C .......... REAL 1-BY-1 BLOCK ..........
7723	T = W
7724	IF (W .EQ. 0.0D0) T = EPSB
7725	B(I,EN) = -R / T
7726	GO TO 700
7727	C .......... REAL 2-BY-2 BLOCK ..........
7728	640 X = BETM * A(I,I+1) - ALFM * B(I,I+1)
7729	Y = BETM * A(I+1,I)
7730	Q = W * ZZ - X * Y
7731	T = (X * S - ZZ * R) / Q
7732	B(I,EN) = T
7733	IF (DABS(X) .LE. DABS(ZZ)) GO TO 650
7734	B(I+1,EN) = (-R - W * T) / X
7735	GO TO 690
7736	650 B(I+1,EN) = (-S - Y * T) / ZZ
7737	690 ISW = 3 - ISW
7738	700 CONTINUE
7739	C .......... END REAL VECTOR ..........
7740	GO TO 800
7741	C .......... COMPLEX VECTOR ..........
7742	710 M = NA
7743	ALMR = ALFR(M)
7744	ALMI = ALFI(M)
7745	BETM = BETA(M)
7746	C .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT
7747	C EIGENVECTOR MATRIX IS TRIANGULAR ..........
7748	Y = BETM * A(EN,NA)
7749	B(NA,NA) = -ALMI * B(EN,EN) / Y
7750	B(NA,EN) = (ALMR * B(EN,EN) - BETM * A(EN,EN)) / Y
7751	B(EN,NA) = 0.0D0
7752	B(EN,EN) = 1.0D0
7753	ENM2 = NA - 1
7754	IF (ENM2 .EQ. 0) GO TO 795
7755	C .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- ..........
7756	DO 790 II = 1, ENM2
7757	I = NA - II
7758	W = BETM * A(I,I) - ALMR * B(I,I)
7759	W1 = -ALMI * B(I,I)
7760	RA = 0.0D0
7761	SA = 0.0D0
7762	C
7763	DO 760 J = M, EN
7764	X = BETM * A(I,J) - ALMR * B(I,J)
7765	X1 = -ALMI * B(I,J)
7766	RA = RA + X * B(J,NA) - X1 * B(J,EN)
7767	SA = SA + X * B(J,EN) + X1 * B(J,NA)
7768	760 CONTINUE
7769	C
7770	IF (I .EQ. 1 .OR. ISW .EQ. 2) GO TO 770
7771	IF (BETM * A(I,I-1) .EQ. 0.0D0) GO TO 770
7772	ZZ = W
7773	Z1 = W1
7774	R = RA
7775	S = SA
7776	ISW = 2
7777	GO TO 790
7778	770 M = I
7779	IF (ISW .EQ. 2) GO TO 780
7780	C .......... COMPLEX 1-BY-1 BLOCK ..........
7781	TR = -RA
7782	TI = -SA
7783	773 DR = W
7784	DI = W1
7785	C .......... COMPLEX DIVIDE (T1,T2) = (TR,TI) / (DR,DI) ..........
7786	775 IF (DABS(DI) .GT. DABS(DR)) GO TO 777
7787	RR = DI / DR
7788	D = DR + DI * RR
7789	T1 = (TR + TI * RR) / D
7790	T2 = (TI - TR * RR) / D
7791	GO TO (787,782), ISW
7792	777 RR = DR / DI
7793	D = DR * RR + DI
7794	T1 = (TR * RR + TI) / D
7795	T2 = (TI * RR - TR) / D
7796	GO TO (787,782), ISW
7797	C .......... COMPLEX 2-BY-2 BLOCK ..........
7798	780 X = BETM * A(I,I+1) - ALMR * B(I,I+1)
7799	X1 = -ALMI * B(I,I+1)
7800	Y = BETM * A(I+1,I)
7801	TR = Y * RA - W * R + W1 * S
7802	TI = Y * SA - W * S - W1 * R
7803	DR = W * ZZ - W1 * Z1 - X * Y
7804	DI = W * Z1 + W1 * ZZ - X1 * Y
7805	IF (DR .EQ. 0.0D0 .AND. DI .EQ. 0.0D0) DR = EPSB
7806	GO TO 775
7807	782 B(I+1,NA) = T1
7808	B(I+1,EN) = T2
7809	ISW = 1
7810	IF (DABS(Y) .GT. DABS(W) + DABS(W1)) GO TO 785
7811	TR = -RA - X * B(I+1,NA) + X1 * B(I+1,EN)
7812	TI = -SA - X * B(I+1,EN) - X1 * B(I+1,NA)
7813	GO TO 773
7814	785 T1 = (-R - ZZ * B(I+1,NA) + Z1 * B(I+1,EN)) / Y
7815	T2 = (-S - ZZ * B(I+1,EN) - Z1 * B(I+1,NA)) / Y
7816	787 B(I,NA) = T1
7817	B(I,EN) = T2
7818	790 CONTINUE
7819	C .......... END COMPLEX VECTOR ..........
7820	795 ISW = 3 - ISW
7821	800 CONTINUE
7822	C .......... END BACK SUBSTITUTION.
7823	C TRANSFORM TO ORIGINAL COORDINATE SYSTEM.
7824	C FOR J=N STEP -1 UNTIL 1 DO -- ..........
7825	DO 880 JJ = 1, N
7826	J = N + 1 - JJ
7827	C
7828	DO 880 I = 1, N
7829	ZZ = 0.0D0
7830	C
7831	DO 860 K = 1, J
7832	860 ZZ = ZZ + Z(I,K) * B(K,J)
7833	C
7834	Z(I,J) = ZZ
7835	880 CONTINUE
7836	C .......... NORMALIZE SO THAT MODULUS OF LARGEST
7837	C COMPONENT OF EACH VECTOR IS 1.
7838	C (ISW IS 1 INITIALLY FROM BEFORE) ..........
7839	DO 950 J = 1, N
7840	D = 0.0D0
7841	IF (ISW .EQ. 2) GO TO 920
7842	IF (ALFI(J) .NE. 0.0D0) GO TO 945
7843	C
7844	DO 890 I = 1, N
7845	IF (DABS(Z(I,J)) .GT. D) D = DABS(Z(I,J))
7846	890 CONTINUE
7847	C
7848	DO 900 I = 1, N
7849	900 Z(I,J) = Z(I,J) / D
7850	C
7851	GO TO 950
7852	C
7853	920 DO 930 I = 1, N
7854	R = DABS(Z(I,J-1)) + DABS(Z(I,J))
7855	IF (R .NE. 0.0D0) R = R * DSQRT((Z(I,J-1)/R)**2
7856	X +(Z(I,J)/R)**2)
7857	IF (R .GT. D) D = R
7858	930 CONTINUE
7859	C
7860	DO 940 I = 1, N
7861	Z(I,J-1) = Z(I,J-1) / D
7862	Z(I,J) = Z(I,J) / D
7863	940 CONTINUE
7864	C
7865	945 ISW = 3 - ISW
7866	950 CONTINUE
7867	C
7868	RETURN
7869	END
7870	SUBROUTINE RATQR(N,EPS1,D,E,E2,M,W,IND,BD,TYPE,IDEF,IERR)
7871	C
7872	INTEGER I,J,K,M,N,II,JJ,K1,IDEF,IERR,JDEF
7873	DOUBLE PRECISION D(N),E(N),E2(N),W(N),BD(N)
7874	DOUBLE PRECISION F,P,Q,R,S,EP,QP,ERR,TOT,EPS1,DELTA,EPSLON
7875	INTEGER IND(N)
7876	LOGICAL TYPE
7877	C
7878	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE RATQR,
7879	C NUM. MATH. 11, 264-272(1968) BY REINSCH AND BAUER.
7880	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 257-265(1971).
7881	C
7882	C THIS SUBROUTINE FINDS THE ALGEBRAICALLY SMALLEST OR LARGEST
7883	C EIGENVALUES OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE
7884	C RATIONAL QR METHOD WITH NEWTON CORRECTIONS.
7885	C
7886	C ON INPUT
7887	C
7888	C N IS THE ORDER OF THE MATRIX.
7889	C
7890	C EPS1 IS A THEORETICAL ABSOLUTE ERROR TOLERANCE FOR THE
7891	C COMPUTED EIGENVALUES. IF THE INPUT EPS1 IS NON-POSITIVE,
7892	C OR INDEED SMALLER THAN ITS DEFAULT VALUE, IT IS RESET
7893	C AT EACH ITERATION TO THE RESPECTIVE DEFAULT VALUE,
7894	C NAMELY, THE PRODUCT OF THE RELATIVE MACHINE PRECISION
7895	C AND THE MAGNITUDE OF THE CURRENT EIGENVALUE ITERATE.
7896	C THE THEORETICAL ABSOLUTE ERROR IN THE K-TH EIGENVALUE
7897	C IS USUALLY NOT GREATER THAN K TIMES EPS1.
7898	C
7899	C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
7900	C
7901	C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
7902	C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY.
7903	C
7904	C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
7905	C E2(1) IS ARBITRARY.
7906	C
7907	C M IS THE NUMBER OF EIGENVALUES TO BE FOUND.
7908	C
7909	C IDEF SHOULD BE SET TO 1 IF THE INPUT MATRIX IS KNOWN TO BE
7910	C POSITIVE DEFINITE, TO -1 IF THE INPUT MATRIX IS KNOWN TO
7911	C BE NEGATIVE DEFINITE, AND TO 0 OTHERWISE.
7912	C
7913	C TYPE SHOULD BE SET TO .TRUE. IF THE SMALLEST EIGENVALUES
7914	C ARE TO BE FOUND, AND TO .FALSE. IF THE LARGEST EIGENVALUES
7915	C ARE TO BE FOUND.
7916	C
7917	C ON OUTPUT
7918	C
7919	C EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS
7920	C (LAST) DEFAULT VALUE.
7921	C
7922	C D AND E ARE UNALTERED (UNLESS W OVERWRITES D).
7923	C
7924	C ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED
7925	C AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE
7926	C MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES.
7927	C E2(1) IS SET TO 0.0D0 IF THE SMALLEST EIGENVALUES HAVE BEEN
7928	C FOUND, AND TO 2.0D0 IF THE LARGEST EIGENVALUES HAVE BEEN
7929	C FOUND. E2 IS OTHERWISE UNALTERED (UNLESS OVERWRITTEN BY BD).
7930	C
7931	C W CONTAINS THE M ALGEBRAICALLY SMALLEST EIGENVALUES IN
7932	C ASCENDING ORDER, OR THE M LARGEST EIGENVALUES IN
7933	C DESCENDING ORDER. IF AN ERROR EXIT IS MADE BECAUSE OF
7934	C AN INCORRECT SPECIFICATION OF IDEF, NO EIGENVALUES
7935	C ARE FOUND. IF THE NEWTON ITERATES FOR A PARTICULAR
7936	C EIGENVALUE ARE NOT MONOTONE, THE BEST ESTIMATE OBTAINED
7937	C IS RETURNED AND IERR IS SET. W MAY COINCIDE WITH D.
7938	C
7939	C IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES
7940	C ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W --
7941	C 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM
7942	C THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC..
7943	C
7944	C BD CONTAINS REFINED BOUNDS FOR THE THEORETICAL ERRORS OF THE
7945	C CORRESPONDING EIGENVALUES IN W. THESE BOUNDS ARE USUALLY
7946	C WITHIN THE TOLERANCE SPECIFIED BY EPS1. BD MAY COINCIDE
7947	C WITH E2.
7948	C
7949	C IERR IS SET TO
7950	C ZERO FOR NORMAL RETURN,
7951	C 6*N+1 IF IDEF IS SET TO 1 AND TYPE TO .TRUE.
7952	C WHEN THE MATRIX IS NOT POSITIVE DEFINITE, OR
7953	C IF IDEF IS SET TO -1 AND TYPE TO .FALSE.
7954	C WHEN THE MATRIX IS NOT NEGATIVE DEFINITE,
7955	C 5*N+K IF SUCCESSIVE ITERATES TO THE K-TH EIGENVALUE
7956	C ARE NOT MONOTONE INCREASING, WHERE K REFERS
7957	C TO THE LAST SUCH OCCURRENCE.
7958	C
7959	C NOTE THAT SUBROUTINE TRIDIB IS GENERALLY FASTER AND MORE
7960	C ACCURATE THAN RATQR IF THE EIGENVALUES ARE CLUSTERED.
7961	C
7962	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
7963	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
7964	C
7965	C THIS VERSION DATED AUGUST 1983.
7966	C
7967	C ------------------------------------------------------------------
7968	C
7969	IERR = 0
7970	JDEF = IDEF
7971	C .......... COPY D ARRAY INTO W ..........
7972	DO 20 I = 1, N
7973	20 W(I) = D(I)
7974	C
7975	IF (TYPE) GO TO 40
7976	J = 1
7977	GO TO 400
7978	40 ERR = 0.0D0
7979	S = 0.0D0
7980	C .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES AND DEFINE
7981	C INITIAL SHIFT FROM LOWER GERSCHGORIN BOUND.
7982	C COPY E2 ARRAY INTO BD ..........
7983	TOT = W(1)
7984	Q = 0.0D0
7985	J = 0
7986	C
7987	DO 100 I = 1, N
7988	P = Q
7989	IF (I .EQ. 1) GO TO 60
7990	IF (P .GT. EPSLON(DABS(D(I)) + DABS(D(I-1)))) GO TO 80
7991	60 E2(I) = 0.0D0
7992	80 BD(I) = E2(I)
7993	C .......... COUNT ALSO IF ELEMENT OF E2 HAS UNDERFLOWED ..........
7994	IF (E2(I) .EQ. 0.0D0) J = J + 1
7995	IND(I) = J
7996	Q = 0.0D0
7997	IF (I .NE. N) Q = DABS(E(I+1))
7998	TOT = DMIN1(W(I)-P-Q,TOT)
7999	100 CONTINUE
8000	C
8001	IF (JDEF .EQ. 1 .AND. TOT .LT. 0.0D0) GO TO 140
8002	C
8003	DO 110 I = 1, N
8004	110 W(I) = W(I) - TOT
8005	C
8006	GO TO 160
8007	140 TOT = 0.0D0
8008	C
8009	160 DO 360 K = 1, M
8010	C .......... NEXT QR TRANSFORMATION ..........
8011	180 TOT = TOT + S
8012	DELTA = W(N) - S
8013	I = N
8014	F = DABS(EPSLON(TOT))
8015	IF (EPS1 .LT. F) EPS1 = F
8016	IF (DELTA .GT. EPS1) GO TO 190
8017	IF (DELTA .LT. (-EPS1)) GO TO 1000
8018	GO TO 300
8019	C .......... REPLACE SMALL SUB-DIAGONAL SQUARES BY ZERO
8020	C TO REDUCE THE INCIDENCE OF UNDERFLOWS ..........
8021	190 IF (K .EQ. N) GO TO 210
8022	K1 = K + 1
8023	DO 200 J = K1, N
8024	IF (BD(J) .LE. (EPSLON(W(J)+W(J-1))) ** 2) BD(J) = 0.0D0
8025	200 CONTINUE
8026	C
8027	210 F = BD(N) / DELTA
8028	QP = DELTA + F
8029	P = 1.0D0
8030	IF (K .EQ. N) GO TO 260
8031	K1 = N - K
8032	C .......... FOR I=N-1 STEP -1 UNTIL K DO -- ..........
8033	DO 240 II = 1, K1
8034	I = N - II
8035	Q = W(I) - S - F
8036	R = Q / QP
8037	P = P * R + 1.0D0
8038	EP = F * R
8039	W(I+1) = QP + EP
8040	DELTA = Q - EP
8041	IF (DELTA .GT. EPS1) GO TO 220
8042	IF (DELTA .LT. (-EPS1)) GO TO 1000
8043	GO TO 300
8044	220 F = BD(I) / Q
8045	QP = DELTA + F
8046	BD(I+1) = QP * EP
8047	240 CONTINUE
8048	C
8049	260 W(K) = QP
8050	S = QP / P
8051	IF (TOT + S .GT. TOT) GO TO 180
8052	C .......... SET ERROR -- IRREGULAR END OF ITERATION.
8053	C DEFLATE MINIMUM DIAGONAL ELEMENT ..........
8054	IERR = 5 * N + K
8055	S = 0.0D0
8056	DELTA = QP
8057	C
8058	DO 280 J = K, N
8059	IF (W(J) .GT. DELTA) GO TO 280
8060	I = J
8061	DELTA = W(J)
8062	280 CONTINUE
8063	C .......... CONVERGENCE ..........
8064	300 IF (I .LT. N) BD(I+1) = BD(I) * F / QP
8065	II = IND(I)
8066	IF (I .EQ. K) GO TO 340
8067	K1 = I - K
8068	C .......... FOR J=I-1 STEP -1 UNTIL K DO -- ..........
8069	DO 320 JJ = 1, K1
8070	J = I - JJ
8071	W(J+1) = W(J) - S
8072	BD(J+1) = BD(J)
8073	IND(J+1) = IND(J)
8074	320 CONTINUE
8075	C
8076	340 W(K) = TOT
8077	ERR = ERR + DABS(DELTA)
8078	BD(K) = ERR
8079	IND(K) = II
8080	360 CONTINUE
8081	C
8082	IF (TYPE) GO TO 1001
8083	F = BD(1)
8084	E2(1) = 2.0D0
8085	BD(1) = F
8086	J = 2
8087	C .......... NEGATE ELEMENTS OF W FOR LARGEST VALUES ..........
8088	400 DO 500 I = 1, N
8089	500 W(I) = -W(I)
8090	C
8091	JDEF = -JDEF
8092	GO TO (40,1001), J
8093	C .......... SET ERROR -- IDEF SPECIFIED INCORRECTLY ..........
8094	1000 IERR = 6 * N + 1
8095	1001 RETURN
8096	END
8097	SUBROUTINE REBAK(NM,N,B,DL,M,Z)
8098	C
8099	INTEGER I,J,K,M,N,I1,II,NM
8100	DOUBLE PRECISION B(NM,N),DL(N),Z(NM,M)
8101	DOUBLE PRECISION X
8102	C
8103	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE REBAKA,
8104	C NUM. MATH. 11, 99-110(1968) BY MARTIN AND WILKINSON.
8105	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971).
8106	C
8107	C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A GENERALIZED
8108	C SYMMETRIC EIGENSYSTEM BY BACK TRANSFORMING THOSE OF THE
8109	C DERIVED SYMMETRIC MATRIX DETERMINED BY REDUC.
8110	C
8111	C ON INPUT
8112	C
8113	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
8114	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
8115	C DIMENSION STATEMENT.
8116	C
8117	C N IS THE ORDER OF THE MATRIX SYSTEM.
8118	C
8119	C B CONTAINS INFORMATION ABOUT THE SIMILARITY TRANSFORMATION
8120	C (CHOLESKY DECOMPOSITION) USED IN THE REDUCTION BY REDUC
8121	C IN ITS STRICT LOWER TRIANGLE.
8122	C
8123	C DL CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATION.
8124	C
8125	C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
8126	C
8127	C Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED
8128	C IN ITS FIRST M COLUMNS.
8129	C
8130	C ON OUTPUT
8131	C
8132	C Z CONTAINS THE TRANSFORMED EIGENVECTORS
8133	C IN ITS FIRST M COLUMNS.
8134	C
8135	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
8136	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
8137	C
8138	C THIS VERSION DATED AUGUST 1983.
8139	C
8140	C ------------------------------------------------------------------
8141	C
8142	IF (M .EQ. 0) GO TO 200
8143	C
8144	DO 100 J = 1, M
8145	C .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
8146	DO 100 II = 1, N
8147	I = N + 1 - II
8148	I1 = I + 1
8149	X = Z(I,J)
8150	IF (I .EQ. N) GO TO 80
8151	C
8152	DO 60 K = I1, N
8153	60 X = X - B(K,I) * Z(K,J)
8154	C
8155	80 Z(I,J) = X / DL(I)
8156	100 CONTINUE
8157	C
8158	200 RETURN
8159	END
8160	SUBROUTINE REBAKB(NM,N,B,DL,M,Z)
8161	C
8162	INTEGER I,J,K,M,N,I1,II,NM
8163	DOUBLE PRECISION B(NM,N),DL(N),Z(NM,M)
8164	DOUBLE PRECISION X
8165	C
8166	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE REBAKB,
8167	C NUM. MATH. 11, 99-110(1968) BY MARTIN AND WILKINSON.
8168	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971).
8169	C
8170	C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A GENERALIZED
8171	C SYMMETRIC EIGENSYSTEM BY BACK TRANSFORMING THOSE OF THE
8172	C DERIVED SYMMETRIC MATRIX DETERMINED BY REDUC2.
8173	C
8174	C ON INPUT
8175	C
8176	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
8177	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
8178	C DIMENSION STATEMENT.
8179	C
8180	C N IS THE ORDER OF THE MATRIX SYSTEM.
8181	C
8182	C B CONTAINS INFORMATION ABOUT THE SIMILARITY TRANSFORMATION
8183	C (CHOLESKY DECOMPOSITION) USED IN THE REDUCTION BY REDUC2
8184	C IN ITS STRICT LOWER TRIANGLE.
8185	C
8186	C DL CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATION.
8187	C
8188	C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
8189	C
8190	C Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED
8191	C IN ITS FIRST M COLUMNS.
8192	C
8193	C ON OUTPUT
8194	C
8195	C Z CONTAINS THE TRANSFORMED EIGENVECTORS
8196	C IN ITS FIRST M COLUMNS.
8197	C
8198	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
8199	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
8200	C
8201	C THIS VERSION DATED AUGUST 1983.
8202	C
8203	C ------------------------------------------------------------------
8204	C
8205	IF (M .EQ. 0) GO TO 200
8206	C
8207	DO 100 J = 1, M
8208	C .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
8209	DO 100 II = 1, N
8210	I1 = N - II
8211	I = I1 + 1
8212	X = DL(I) * Z(I,J)
8213	IF (I .EQ. 1) GO TO 80
8214	C
8215	DO 60 K = 1, I1
8216	60 X = X + B(I,K) * Z(K,J)
8217	C
8218	80 Z(I,J) = X
8219	100 CONTINUE
8220	C
8221	200 RETURN
8222	END
8223	SUBROUTINE REDUC(NM,N,A,B,DL,IERR)
8224	C
8225	INTEGER I,J,K,N,I1,J1,NM,NN,IERR
8226	DOUBLE PRECISION A(NM,N),B(NM,N),DL(N)
8227	DOUBLE PRECISION X,Y
8228	C
8229	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE REDUC1,
8230	C NUM. MATH. 11, 99-110(1968) BY MARTIN AND WILKINSON.
8231	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971).
8232	C
8233	C THIS SUBROUTINE REDUCES THE GENERALIZED SYMMETRIC EIGENPROBLEM
8234	C AX=(LAMBDA)BX, WHERE B IS POSITIVE DEFINITE, TO THE STANDARD
8235	C SYMMETRIC EIGENPROBLEM USING THE CHOLESKY FACTORIZATION OF B.
8236	C
8237	C ON INPUT
8238	C
8239	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
8240	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
8241	C DIMENSION STATEMENT.
8242	C
8243	C N IS THE ORDER OF THE MATRICES A AND B. IF THE CHOLESKY
8244	C FACTOR L OF B IS ALREADY AVAILABLE, N SHOULD BE PREFIXED
8245	C WITH A MINUS SIGN.
8246	C
8247	C A AND B CONTAIN THE REAL SYMMETRIC INPUT MATRICES. ONLY THE
8248	C FULL UPPER TRIANGLES OF THE MATRICES NEED BE SUPPLIED. IF
8249	C N IS NEGATIVE, THE STRICT LOWER TRIANGLE OF B CONTAINS,
8250	C INSTEAD, THE STRICT LOWER TRIANGLE OF ITS CHOLESKY FACTOR L.
8251	C
8252	C DL CONTAINS, IF N IS NEGATIVE, THE DIAGONAL ELEMENTS OF L.
8253	C
8254	C ON OUTPUT
8255	C
8256	C A CONTAINS IN ITS FULL LOWER TRIANGLE THE FULL LOWER TRIANGLE
8257	C OF THE SYMMETRIC MATRIX DERIVED FROM THE REDUCTION TO THE
8258	C STANDARD FORM. THE STRICT UPPER TRIANGLE OF A IS UNALTERED.
8259	C
8260	C B CONTAINS IN ITS STRICT LOWER TRIANGLE THE STRICT LOWER
8261	C TRIANGLE OF ITS CHOLESKY FACTOR L. THE FULL UPPER
8262	C TRIANGLE OF B IS UNALTERED.
8263	C
8264	C DL CONTAINS THE DIAGONAL ELEMENTS OF L.
8265	C
8266	C IERR IS SET TO
8267	C ZERO FOR NORMAL RETURN,
8268	C 7*N+1 IF B IS NOT POSITIVE DEFINITE.
8269	C
8270	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
8271	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
8272	C
8273	C THIS VERSION DATED AUGUST 1983.
8274	C
8275	C ------------------------------------------------------------------
8276	C
8277	IERR = 0
8278	NN = IABS(N)
8279	IF (N .LT. 0) GO TO 100
8280	C .......... FORM L IN THE ARRAYS B AND DL ..........
8281	DO 80 I = 1, N
8282	I1 = I - 1
8283	C
8284	DO 80 J = I, N
8285	X = B(I,J)
8286	IF (I .EQ. 1) GO TO 40
8287	C
8288	DO 20 K = 1, I1
8289	20 X = X - B(I,K) * B(J,K)
8290	C
8291	40 IF (J .NE. I) GO TO 60
8292	IF (X .LE. 0.0D0) GO TO 1000
8293	Y = DSQRT(X)
8294	DL(I) = Y
8295	GO TO 80
8296	60 B(J,I) = X / Y
8297	80 CONTINUE
8298	C .......... FORM THE TRANSPOSE OF THE UPPER TRIANGLE OF INV(L)*A
8299	C IN THE LOWER TRIANGLE OF THE ARRAY A ..........
8300	100 DO 200 I = 1, NN
8301	I1 = I - 1
8302	Y = DL(I)
8303	C
8304	DO 200 J = I, NN
8305	X = A(I,J)
8306	IF (I .EQ. 1) GO TO 180
8307	C
8308	DO 160 K = 1, I1
8309	160 X = X - B(I,K) * A(J,K)
8310	C
8311	180 A(J,I) = X / Y
8312	200 CONTINUE
8313	C .......... PRE-MULTIPLY BY INV(L) AND OVERWRITE ..........
8314	DO 300 J = 1, NN
8315	J1 = J - 1
8316	C
8317	DO 300 I = J, NN
8318	X = A(I,J)
8319	IF (I .EQ. J) GO TO 240
8320	I1 = I - 1
8321	C
8322	DO 220 K = J, I1
8323	220 X = X - A(K,J) * B(I,K)
8324	C
8325	240 IF (J .EQ. 1) GO TO 280
8326	C
8327	DO 260 K = 1, J1
8328	260 X = X - A(J,K) * B(I,K)
8329	C
8330	280 A(I,J) = X / DL(I)
8331	300 CONTINUE
8332	C
8333	GO TO 1001
8334	C .......... SET ERROR -- B IS NOT POSITIVE DEFINITE ..........
8335	1000 IERR = 7 * N + 1
8336	1001 RETURN
8337	END
8338	SUBROUTINE REDUC2(NM,N,A,B,DL,IERR)
8339	C
8340	INTEGER I,J,K,N,I1,J1,NM,NN,IERR
8341	DOUBLE PRECISION A(NM,N),B(NM,N),DL(N)
8342	DOUBLE PRECISION X,Y
8343	C
8344	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE REDUC2,
8345	C NUM. MATH. 11, 99-110(1968) BY MARTIN AND WILKINSON.
8346	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971).
8347	C
8348	C THIS SUBROUTINE REDUCES THE GENERALIZED SYMMETRIC EIGENPROBLEMS
8349	C ABX=(LAMBDA)X OR BAY=(LAMBDA)Y, WHERE B IS POSITIVE DEFINITE,
8350	C TO THE STANDARD SYMMETRIC EIGENPROBLEM USING THE CHOLESKY
8351	C FACTORIZATION OF B.
8352	C
8353	C ON INPUT
8354	C
8355	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
8356	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
8357	C DIMENSION STATEMENT.
8358	C
8359	C N IS THE ORDER OF THE MATRICES A AND B. IF THE CHOLESKY
8360	C FACTOR L OF B IS ALREADY AVAILABLE, N SHOULD BE PREFIXED
8361	C WITH A MINUS SIGN.
8362	C
8363	C A AND B CONTAIN THE REAL SYMMETRIC INPUT MATRICES. ONLY THE
8364	C FULL UPPER TRIANGLES OF THE MATRICES NEED BE SUPPLIED. IF
8365	C N IS NEGATIVE, THE STRICT LOWER TRIANGLE OF B CONTAINS,
8366	C INSTEAD, THE STRICT LOWER TRIANGLE OF ITS CHOLESKY FACTOR L.
8367	C
8368	C DL CONTAINS, IF N IS NEGATIVE, THE DIAGONAL ELEMENTS OF L.
8369	C
8370	C ON OUTPUT
8371	C
8372	C A CONTAINS IN ITS FULL LOWER TRIANGLE THE FULL LOWER TRIANGLE
8373	C OF THE SYMMETRIC MATRIX DERIVED FROM THE REDUCTION TO THE
8374	C STANDARD FORM. THE STRICT UPPER TRIANGLE OF A IS UNALTERED.
8375	C
8376	C B CONTAINS IN ITS STRICT LOWER TRIANGLE THE STRICT LOWER
8377	C TRIANGLE OF ITS CHOLESKY FACTOR L. THE FULL UPPER
8378	C TRIANGLE OF B IS UNALTERED.
8379	C
8380	C DL CONTAINS THE DIAGONAL ELEMENTS OF L.
8381	C
8382	C IERR IS SET TO
8383	C ZERO FOR NORMAL RETURN,
8384	C 7*N+1 IF B IS NOT POSITIVE DEFINITE.
8385	C
8386	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
8387	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
8388	C
8389	C THIS VERSION DATED AUGUST 1983.
8390	C
8391	C ------------------------------------------------------------------
8392	C
8393	IERR = 0
8394	NN = IABS(N)
8395	IF (N .LT. 0) GO TO 100
8396	C .......... FORM L IN THE ARRAYS B AND DL ..........
8397	DO 80 I = 1, N
8398	I1 = I - 1
8399	C
8400	DO 80 J = I, N
8401	X = B(I,J)
8402	IF (I .EQ. 1) GO TO 40
8403	C
8404	DO 20 K = 1, I1
8405	20 X = X - B(I,K) * B(J,K)
8406	C
8407	40 IF (J .NE. I) GO TO 60
8408	IF (X .LE. 0.0D0) GO TO 1000
8409	Y = DSQRT(X)
8410	DL(I) = Y
8411	GO TO 80
8412	60 B(J,I) = X / Y
8413	80 CONTINUE
8414	C .......... FORM THE LOWER TRIANGLE OF A*L
8415	C IN THE LOWER TRIANGLE OF THE ARRAY A ..........
8416	100 DO 200 I = 1, NN
8417	I1 = I + 1
8418	C
8419	DO 200 J = 1, I
8420	X = A(J,I) * DL(J)
8421	IF (J .EQ. I) GO TO 140
8422	J1 = J + 1
8423	C
8424	DO 120 K = J1, I
8425	120 X = X + A(K,I) * B(K,J)
8426	C
8427	140 IF (I .EQ. NN) GO TO 180
8428	C
8429	DO 160 K = I1, NN
8430	160 X = X + A(I,K) * B(K,J)
8431	C
8432	180 A(I,J) = X
8433	200 CONTINUE
8434	C .......... PRE-MULTIPLY BY TRANSPOSE(L) AND OVERWRITE ..........
8435	DO 300 I = 1, NN
8436	I1 = I + 1
8437	Y = DL(I)
8438	C
8439	DO 300 J = 1, I
8440	X = Y * A(I,J)
8441	IF (I .EQ. NN) GO TO 280
8442	C
8443	DO 260 K = I1, NN
8444	260 X = X + A(K,J) * B(K,I)
8445	C
8446	280 A(I,J) = X
8447	300 CONTINUE
8448	C
8449	GO TO 1001
8450	C .......... SET ERROR -- B IS NOT POSITIVE DEFINITE ..........
8451	1000 IERR = 7 * N + 1
8452	1001 RETURN
8453	END
8454	SUBROUTINE RG(NM,N,A,WR,WI,MATZ,Z,IV1,FV1,IERR)
8455	C
8456	INTEGER N,NM,IS1,IS2,IERR,MATZ
8457	DOUBLE PRECISION A(NM,N),WR(N),WI(N),Z(NM,N),FV1(N)
8458	INTEGER IV1(N)
8459	C
8460	C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
8461	C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
8462	C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
8463	C OF A REAL GENERAL MATRIX.
8464	C
8465	C ON INPUT
8466	C
8467	C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
8468	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
8469	C DIMENSION STATEMENT.
8470	C
8471	C N IS THE ORDER OF THE MATRIX A.
8472	C
8473	C A CONTAINS THE REAL GENERAL MATRIX.
8474	C
8475	C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
8476	C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
8477	C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
8478	C
8479	C ON OUTPUT
8480	C
8481	C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
8482	C RESPECTIVELY, OF THE EIGENVALUES. COMPLEX CONJUGATE
8483	C PAIRS OF EIGENVALUES APPEAR CONSECUTIVELY WITH THE
8484	C EIGENVALUE HAVING THE POSITIVE IMAGINARY PART FIRST.
8485	C
8486	C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS
8487	C IF MATZ IS NOT ZERO. IF THE J-TH EIGENVALUE IS REAL, THE
8488	C J-TH COLUMN OF Z CONTAINS ITS EIGENVECTOR. IF THE J-TH
8489	C EIGENVALUE IS COMPLEX WITH POSITIVE IMAGINARY PART, THE
8490	C J-TH AND (J+1)-TH COLUMNS OF Z CONTAIN THE REAL AND
8491	C IMAGINARY PARTS OF ITS EIGENVECTOR. THE CONJUGATE OF THIS
8492	C VECTOR IS THE EIGENVECTOR FOR THE CONJUGATE EIGENVALUE.
8493	C
8494	C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
8495	C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR HQR
8496	C AND HQR2. THE NORMAL COMPLETION CODE IS ZERO.
8497	C
8498	C IV1 AND FV1 ARE TEMPORARY STORAGE ARRAYS.
8499	C
8500	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
8501	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
8502	C
8503	C THIS VERSION DATED AUGUST 1983.
8504	C
8505	C ------------------------------------------------------------------
8506	C
8507	IF (N .LE. NM) GO TO 10
8508	IERR = 10 * N
8509	GO TO 50
8510	C
8511	10 CALL BALANC(NM,N,A,IS1,IS2,FV1)
8512	CALL ELMHES(NM,N,IS1,IS2,A,IV1)
8513	IF (MATZ .NE. 0) GO TO 20
8514	C .......... FIND EIGENVALUES ONLY ..........
8515	CALL HQR(NM,N,IS1,IS2,A,WR,WI,IERR)
8516	GO TO 50
8517	C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
8518	20 CALL ELTRAN(NM,N,IS1,IS2,A,IV1,Z)
8519	CALL HQR2(NM,N,IS1,IS2,A,WR,WI,Z,IERR)
8520	IF (IERR .NE. 0) GO TO 50
8521	CALL BALBAK(NM,N,IS1,IS2,FV1,N,Z)
8522	50 RETURN
8523	END
8524	SUBROUTINE RGG(NM,N,A,B,ALFR,ALFI,BETA,MATZ,Z,IERR)
8525	C
8526	INTEGER N,NM,IERR,MATZ
8527	DOUBLE PRECISION A(NM,N),B(NM,N),ALFR(N),ALFI(N),BETA(N),Z(NM,N)
8528	LOGICAL TF
8529	C
8530	C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
8531	C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
8532	C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
8533	C FOR THE REAL GENERAL GENERALIZED EIGENPROBLEM AX = (LAMBDA)BX.
8534	C
8535	C ON INPUT
8536	C
8537	C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
8538	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
8539	C DIMENSION STATEMENT.
8540	C
8541	C N IS THE ORDER OF THE MATRICES A AND B.
8542	C
8543	C A CONTAINS A REAL GENERAL MATRIX.
8544	C
8545	C B CONTAINS A REAL GENERAL MATRIX.
8546	C
8547	C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
8548	C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
8549	C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
8550	C
8551	C ON OUTPUT
8552	C
8553	C ALFR AND ALFI CONTAIN THE REAL AND IMAGINARY PARTS,
8554	C RESPECTIVELY, OF THE NUMERATORS OF THE EIGENVALUES.
8555	C
8556	C BETA CONTAINS THE DENOMINATORS OF THE EIGENVALUES,
8557	C WHICH ARE THUS GIVEN BY THE RATIOS (ALFR+I*ALFI)/BETA.
8558	C COMPLEX CONJUGATE PAIRS OF EIGENVALUES APPEAR CONSECUTIVELY
8559	C WITH THE EIGENVALUE HAVING THE POSITIVE IMAGINARY PART FIRST.
8560	C
8561	C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS
8562	C IF MATZ IS NOT ZERO. IF THE J-TH EIGENVALUE IS REAL, THE
8563	C J-TH COLUMN OF Z CONTAINS ITS EIGENVECTOR. IF THE J-TH
8564	C EIGENVALUE IS COMPLEX WITH POSITIVE IMAGINARY PART, THE
8565	C J-TH AND (J+1)-TH COLUMNS OF Z CONTAIN THE REAL AND
8566	C IMAGINARY PARTS OF ITS EIGENVECTOR. THE CONJUGATE OF THIS
8567	C VECTOR IS THE EIGENVECTOR FOR THE CONJUGATE EIGENVALUE.
8568	C
8569	C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
8570	C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR QZIT.
8571	C THE NORMAL COMPLETION CODE IS ZERO.
8572	C
8573	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
8574	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
8575	C
8576	C THIS VERSION DATED AUGUST 1983.
8577	C
8578	C ------------------------------------------------------------------
8579	C
8580	IF (N .LE. NM) GO TO 10
8581	IERR = 10 * N
8582	GO TO 50
8583	C
8584	10 IF (MATZ .NE. 0) GO TO 20
8585	C .......... FIND EIGENVALUES ONLY ..........
8586	TF = .FALSE.
8587	CALL QZHES(NM,N,A,B,TF,Z)
8588	CALL QZIT(NM,N,A,B,0.0D0,TF,Z,IERR)
8589	CALL QZVAL(NM,N,A,B,ALFR,ALFI,BETA,TF,Z)
8590	GO TO 50
8591	C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
8592	20 TF = .TRUE.
8593	CALL QZHES(NM,N,A,B,TF,Z)
8594	CALL QZIT(NM,N,A,B,0.0D0,TF,Z,IERR)
8595	CALL QZVAL(NM,N,A,B,ALFR,ALFI,BETA,TF,Z)
8596	IF (IERR .NE. 0) GO TO 50
8597	CALL QZVEC(NM,N,A,B,ALFR,ALFI,BETA,Z)
8598	50 RETURN
8599	END
8600	SUBROUTINE RS(NM,N,A,W,MATZ,Z,FV1,FV2,IERR)
8601	C
8602	INTEGER N,NM,IERR,MATZ
8603	DOUBLE PRECISION A(NM,N),W(N),Z(NM,N),FV1(N),FV2(N)
8604	C
8605	C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
8606	C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
8607	C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
8608	C OF A REAL SYMMETRIC MATRIX.
8609	C
8610	C ON INPUT
8611	C
8612	C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
8613	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
8614	C DIMENSION STATEMENT.
8615	C
8616	C N IS THE ORDER OF THE MATRIX A.
8617	C
8618	C A CONTAINS THE REAL SYMMETRIC MATRIX.
8619	C
8620	C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
8621	C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
8622	C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
8623	C
8624	C ON OUTPUT
8625	C
8626	C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER.
8627	C
8628	C Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO.
8629	C
8630	C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
8631	C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT
8632	C AND TQL2. THE NORMAL COMPLETION CODE IS ZERO.
8633	C
8634	C FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS.
8635	C
8636	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
8637	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
8638	C
8639	C THIS VERSION DATED AUGUST 1983.
8640	C
8641	C ------------------------------------------------------------------
8642	C
8643	IF (N .LE. NM) GO TO 10
8644	IERR = 10 * N
8645	GO TO 50
8646	C
8647	10 IF (MATZ .NE. 0) GO TO 20
8648	C .......... FIND EIGENVALUES ONLY ..........
8649	CALL TRED1(NM,N,A,W,FV1,FV2)
8650	CALL TQLRAT(N,W,FV2,IERR)
8651	GO TO 50
8652	C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
8653	20 CALL TRED2(NM,N,A,W,FV1,Z)
8654	CALL TQL2(NM,N,W,FV1,Z,IERR)
8655	50 RETURN
8656	END
8657	SUBROUTINE RSB(NM,N,MB,A,W,MATZ,Z,FV1,FV2,IERR)
8658	C
8659	INTEGER N,MB,NM,IERR,MATZ
8660	DOUBLE PRECISION A(NM,MB),W(N),Z(NM,N),FV1(N),FV2(N)
8661	LOGICAL TF
8662	C
8663	C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
8664	C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
8665	C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
8666	C OF A REAL SYMMETRIC BAND MATRIX.
8667	C
8668	C ON INPUT
8669	C
8670	C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
8671	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
8672	C DIMENSION STATEMENT.
8673	C
8674	C N IS THE ORDER OF THE MATRIX A.
8675	C
8676	C MB IS THE HALF BAND WIDTH OF THE MATRIX, DEFINED AS THE
8677	C NUMBER OF ADJACENT DIAGONALS, INCLUDING THE PRINCIPAL
8678	C DIAGONAL, REQUIRED TO SPECIFY THE NON-ZERO PORTION OF THE
8679	C LOWER TRIANGLE OF THE MATRIX.
8680	C
8681	C A CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC
8682	C BAND MATRIX. ITS LOWEST SUBDIAGONAL IS STORED IN THE
8683	C LAST N+1-MB POSITIONS OF THE FIRST COLUMN, ITS NEXT
8684	C SUBDIAGONAL IN THE LAST N+2-MB POSITIONS OF THE
8685	C SECOND COLUMN, FURTHER SUBDIAGONALS SIMILARLY, AND
8686	C FINALLY ITS PRINCIPAL DIAGONAL IN THE N POSITIONS
8687	C OF THE LAST COLUMN. CONTENTS OF STORAGES NOT PART
8688	C OF THE MATRIX ARE ARBITRARY.
8689	C
8690	C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
8691	C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
8692	C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
8693	C
8694	C ON OUTPUT
8695	C
8696	C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER.
8697	C
8698	C Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO.
8699	C
8700	C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
8701	C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT
8702	C AND TQL2. THE NORMAL COMPLETION CODE IS ZERO.
8703	C
8704	C FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS.
8705	C
8706	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
8707	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
8708	C
8709	C THIS VERSION DATED AUGUST 1983.
8710	C
8711	C ------------------------------------------------------------------
8712	C
8713	IF (N .LE. NM) GO TO 5
8714	IERR = 10 * N
8715	GO TO 50
8716	5 IF (MB .GT. 0) GO TO 10
8717	IERR = 12 * N
8718	GO TO 50
8719	10 IF (MB .LE. N) GO TO 15
8720	IERR = 12 * N
8721	GO TO 50
8722	C
8723	15 IF (MATZ .NE. 0) GO TO 20
8724	C .......... FIND EIGENVALUES ONLY ..........
8725	TF = .FALSE.
8726	CALL BANDR(NM,N,MB,A,W,FV1,FV2,TF,Z)
8727	CALL TQLRAT(N,W,FV2,IERR)
8728	GO TO 50
8729	C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
8730	20 TF = .TRUE.
8731	CALL BANDR(NM,N,MB,A,W,FV1,FV1,TF,Z)
8732	CALL TQL2(NM,N,W,FV1,Z,IERR)
8733	50 RETURN
8734	END
8735	SUBROUTINE RSG(NM,N,A,B,W,MATZ,Z,FV1,FV2,IERR)
8736	C
8737	INTEGER N,NM,IERR,MATZ
8738	DOUBLE PRECISION A(NM,N),B(NM,N),W(N),Z(NM,N),FV1(N),FV2(N)
8739	C
8740	C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
8741	C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
8742	C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
8743	C FOR THE REAL SYMMETRIC GENERALIZED EIGENPROBLEM AX = (LAMBDA)BX.
8744	C
8745	C ON INPUT
8746	C
8747	C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
8748	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
8749	C DIMENSION STATEMENT.
8750	C
8751	C N IS THE ORDER OF THE MATRICES A AND B.
8752	C
8753	C A CONTAINS A REAL SYMMETRIC MATRIX.
8754	C
8755	C B CONTAINS A POSITIVE DEFINITE REAL SYMMETRIC MATRIX.
8756	C
8757	C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
8758	C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
8759	C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
8760	C
8761	C ON OUTPUT
8762	C
8763	C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER.
8764	C
8765	C Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO.
8766	C
8767	C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
8768	C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT
8769	C AND TQL2. THE NORMAL COMPLETION CODE IS ZERO.
8770	C
8771	C FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS.
8772	C
8773	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
8774	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
8775	C
8776	C THIS VERSION DATED AUGUST 1983.
8777	C
8778	C ------------------------------------------------------------------
8779	C
8780	IF (N .LE. NM) GO TO 10
8781	IERR = 10 * N
8782	GO TO 50
8783	C
8784	10 CALL REDUC(NM,N,A,B,FV2,IERR)
8785	IF (IERR .NE. 0) GO TO 50
8786	IF (MATZ .NE. 0) GO TO 20
8787	C .......... FIND EIGENVALUES ONLY ..........
8788	CALL TRED1(NM,N,A,W,FV1,FV2)
8789	CALL TQLRAT(N,W,FV2,IERR)
8790	GO TO 50
8791	C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
8792	20 CALL TRED2(NM,N,A,W,FV1,Z)
8793	CALL TQL2(NM,N,W,FV1,Z,IERR)
8794	IF (IERR .NE. 0) GO TO 50
8795	CALL REBAK(NM,N,B,FV2,N,Z)
8796	50 RETURN
8797	END
8798	SUBROUTINE RSGAB(NM,N,A,B,W,MATZ,Z,FV1,FV2,IERR)
8799	C
8800	INTEGER N,NM,IERR,MATZ
8801	DOUBLE PRECISION A(NM,N),B(NM,N),W(N),Z(NM,N),FV1(N),FV2(N)
8802	C
8803	C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
8804	C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
8805	C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
8806	C FOR THE REAL SYMMETRIC GENERALIZED EIGENPROBLEM ABX = (LAMBDA)X.
8807	C
8808	C ON INPUT
8809	C
8810	C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
8811	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
8812	C DIMENSION STATEMENT.
8813	C
8814	C N IS THE ORDER OF THE MATRICES A AND B.
8815	C
8816	C A CONTAINS A REAL SYMMETRIC MATRIX.
8817	C
8818	C B CONTAINS A POSITIVE DEFINITE REAL SYMMETRIC MATRIX.
8819	C
8820	C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
8821	C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
8822	C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
8823	C
8824	C ON OUTPUT
8825	C
8826	C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER.
8827	C
8828	C Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO.
8829	C
8830	C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
8831	C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT
8832	C AND TQL2. THE NORMAL COMPLETION CODE IS ZERO.
8833	C
8834	C FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS.
8835	C
8836	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
8837	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
8838	C
8839	C THIS VERSION DATED AUGUST 1983.
8840	C
8841	C ------------------------------------------------------------------
8842	C
8843	IF (N .LE. NM) GO TO 10
8844	IERR = 10 * N
8845	GO TO 50
8846	C
8847	10 CALL REDUC2(NM,N,A,B,FV2,IERR)
8848	IF (IERR .NE. 0) GO TO 50
8849	IF (MATZ .NE. 0) GO TO 20
8850	C .......... FIND EIGENVALUES ONLY ..........
8851	CALL TRED1(NM,N,A,W,FV1,FV2)
8852	CALL TQLRAT(N,W,FV2,IERR)
8853	GO TO 50
8854	C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
8855	20 CALL TRED2(NM,N,A,W,FV1,Z)
8856	CALL TQL2(NM,N,W,FV1,Z,IERR)
8857	IF (IERR .NE. 0) GO TO 50
8858	CALL REBAK(NM,N,B,FV2,N,Z)
8859	50 RETURN
8860	END
8861	SUBROUTINE RSGBA(NM,N,A,B,W,MATZ,Z,FV1,FV2,IERR)
8862	C
8863	INTEGER N,NM,IERR,MATZ
8864	DOUBLE PRECISION A(NM,N),B(NM,N),W(N),Z(NM,N),FV1(N),FV2(N)
8865	C
8866	C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
8867	C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
8868	C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
8869	C FOR THE REAL SYMMETRIC GENERALIZED EIGENPROBLEM BAX = (LAMBDA)X.
8870	C
8871	C ON INPUT
8872	C
8873	C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
8874	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
8875	C DIMENSION STATEMENT.
8876	C
8877	C N IS THE ORDER OF THE MATRICES A AND B.
8878	C
8879	C A CONTAINS A REAL SYMMETRIC MATRIX.
8880	C
8881	C B CONTAINS A POSITIVE DEFINITE REAL SYMMETRIC MATRIX.
8882	C
8883	C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
8884	C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
8885	C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
8886	C
8887	C ON OUTPUT
8888	C
8889	C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER.
8890	C
8891	C Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO.
8892	C
8893	C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
8894	C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT
8895	C AND TQL2. THE NORMAL COMPLETION CODE IS ZERO.
8896	C
8897	C FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS.
8898	C
8899	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
8900	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
8901	C
8902	C THIS VERSION DATED AUGUST 1983.
8903	C
8904	C ------------------------------------------------------------------
8905	C
8906	IF (N .LE. NM) GO TO 10
8907	IERR = 10 * N
8908	GO TO 50
8909	C
8910	10 CALL REDUC2(NM,N,A,B,FV2,IERR)
8911	IF (IERR .NE. 0) GO TO 50
8912	IF (MATZ .NE. 0) GO TO 20
8913	C .......... FIND EIGENVALUES ONLY ..........
8914	CALL TRED1(NM,N,A,W,FV1,FV2)
8915	CALL TQLRAT(N,W,FV2,IERR)
8916	GO TO 50
8917	C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
8918	20 CALL TRED2(NM,N,A,W,FV1,Z)
8919	CALL TQL2(NM,N,W,FV1,Z,IERR)
8920	IF (IERR .NE. 0) GO TO 50
8921	CALL REBAKB(NM,N,B,FV2,N,Z)
8922	50 RETURN
8923	END
8924	SUBROUTINE RSM(NM,N,A,W,M,Z,FWORK,IWORK,IERR)
8925	C
8926	INTEGER N,NM,M,IWORK(N),IERR
8927	DOUBLE PRECISION A(NM,N),W(N),Z(NM,M),FWORK(1)
8928	C
8929	C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
8930	C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
8931	C TO FIND ALL OF THE EIGENVALUES AND SOME OF THE EIGENVECTORS
8932	C OF A REAL SYMMETRIC MATRIX.
8933	C
8934	C ON INPUT
8935	C
8936	C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
8937	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
8938	C DIMENSION STATEMENT.
8939	C
8940	C N IS THE ORDER OF THE MATRIX A.
8941	C
8942	C A CONTAINS THE REAL SYMMETRIC MATRIX.
8943	C
8944	C M THE EIGENVECTORS CORRESPONDING TO THE FIRST M EIGENVALUES
8945	C ARE TO BE COMPUTED.
8946	C IF M = 0 THEN NO EIGENVECTORS ARE COMPUTED.
8947	C IF M = N THEN ALL OF THE EIGENVECTORS ARE COMPUTED.
8948	C
8949	C ON OUTPUT
8950	C
8951	C W CONTAINS ALL N EIGENVALUES IN ASCENDING ORDER.
8952	C
8953	C Z CONTAINS THE ORTHONORMAL EIGENVECTORS ASSOCIATED WITH
8954	C THE FIRST M EIGENVALUES.
8955	C
8956	C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
8957	C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT,
8958	C IMTQLV AND TINVIT. THE NORMAL COMPLETION CODE IS ZERO.
8959	C
8960	C FWORK IS A TEMPORARY STORAGE ARRAY OF DIMENSION 8*N.
8961	C
8962	C IWORK IS AN INTEGER TEMPORARY STORAGE ARRAY OF DIMENSION N.
8963	C
8964	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
8965	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
8966	C
8967	C THIS VERSION DATED AUGUST 1983.
8968	C
8969	C ------------------------------------------------------------------
8970	C
8971	IERR = 10 * N
8972	IF (N .GT. NM .OR. M .GT. NM) GO TO 50
8973	K1 = 1
8974	K2 = K1 + N
8975	K3 = K2 + N
8976	K4 = K3 + N
8977	K5 = K4 + N
8978	K6 = K5 + N
8979	K7 = K6 + N
8980	K8 = K7 + N
8981	IF (M .GT. 0) GO TO 10
8982	C .......... FIND EIGENVALUES ONLY ..........
8983	CALL TRED1(NM,N,A,W,FWORK(K1),FWORK(K2))
8984	CALL TQLRAT(N,W,FWORK(K2),IERR)
8985	GO TO 50
8986	C .......... FIND ALL EIGENVALUES AND M EIGENVECTORS ..........
8987	10 CALL TRED1(NM,N,A,FWORK(K1),FWORK(K2),FWORK(K3))
8988	CALL IMTQLV(N,FWORK(K1),FWORK(K2),FWORK(K3),W,IWORK,
8989	X IERR,FWORK(K4))
8990	CALL TINVIT(NM,N,FWORK(K1),FWORK(K2),FWORK(K3),M,W,IWORK,Z,IERR,
8991	X FWORK(K4),FWORK(K5),FWORK(K6),FWORK(K7),FWORK(K8))
8992	CALL TRBAK1(NM,N,A,FWORK(K2),M,Z)
8993	50 RETURN
8994	END
8995	SUBROUTINE RSP(NM,N,NV,A,W,MATZ,Z,FV1,FV2,IERR)
8996	C
8997	INTEGER I,J,N,NM,NV,IERR,MATZ
8998	DOUBLE PRECISION A(NV),W(N),Z(NM,N),FV1(N),FV2(N)
8999	C
9000	C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
9001	C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
9002	C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
9003	C OF A REAL SYMMETRIC PACKED MATRIX.
9004	C
9005	C ON INPUT
9006	C
9007	C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
9008	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
9009	C DIMENSION STATEMENT.
9010	C
9011	C N IS THE ORDER OF THE MATRIX A.
9012	C
9013	C NV IS AN INTEGER VARIABLE SET EQUAL TO THE
9014	C DIMENSION OF THE ARRAY A AS SPECIFIED FOR
9015	C A IN THE CALLING PROGRAM. NV MUST NOT BE
9016	C LESS THAN N*(N+1)/2.
9017	C
9018	C A CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC
9019	C PACKED MATRIX STORED ROW-WISE.
9020	C
9021	C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
9022	C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
9023	C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
9024	C
9025	C ON OUTPUT
9026	C
9027	C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER.
9028	C
9029	C Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO.
9030	C
9031	C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
9032	C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT
9033	C AND TQL2. THE NORMAL COMPLETION CODE IS ZERO.
9034	C
9035	C FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS.
9036	C
9037	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
9038	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
9039	C
9040	C THIS VERSION DATED AUGUST 1983.
9041	C
9042	C ------------------------------------------------------------------
9043	C
9044	IF (N .LE. NM) GO TO 5
9045	IERR = 10 * N
9046	GO TO 50
9047	5 IF (NV .GE. (N * (N + 1)) / 2) GO TO 10
9048	IERR = 20 * N
9049	GO TO 50
9050	C
9051	10 CALL TRED3(N,NV,A,W,FV1,FV2)
9052	IF (MATZ .NE. 0) GO TO 20
9053	C .......... FIND EIGENVALUES ONLY ..........
9054	CALL TQLRAT(N,W,FV2,IERR)
9055	GO TO 50
9056	C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
9057	20 DO 40 I = 1, N
9058	C
9059	DO 30 J = 1, N
9060	Z(J,I) = 0.0D0
9061	30 CONTINUE
9062	C
9063	Z(I,I) = 1.0D0
9064	40 CONTINUE
9065	C
9066	CALL TQL2(NM,N,W,FV1,Z,IERR)
9067	IF (IERR .NE. 0) GO TO 50
9068	CALL TRBAK3(NM,N,NV,A,N,Z)
9069	50 RETURN
9070	END
9071	SUBROUTINE RST(NM,N,W,E,MATZ,Z,IERR)
9072	C
9073	INTEGER I,J,N,NM,IERR,MATZ
9074	DOUBLE PRECISION W(N),E(N),Z(NM,N)
9075	C
9076	C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
9077	C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
9078	C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
9079	C OF A REAL SYMMETRIC TRIDIAGONAL MATRIX.
9080	C
9081	C ON INPUT
9082	C
9083	C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
9084	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
9085	C DIMENSION STATEMENT.
9086	C
9087	C N IS THE ORDER OF THE MATRIX.
9088	C
9089	C W CONTAINS THE DIAGONAL ELEMENTS OF THE REAL
9090	C SYMMETRIC TRIDIAGONAL MATRIX.
9091	C
9092	C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE MATRIX IN
9093	C ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY.
9094	C
9095	C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
9096	C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
9097	C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
9098	C
9099	C ON OUTPUT
9100	C
9101	C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER.
9102	C
9103	C Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO.
9104	C
9105	C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
9106	C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR IMTQL1
9107	C AND IMTQL2. THE NORMAL COMPLETION CODE IS ZERO.
9108	C
9109	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
9110	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
9111	C
9112	C THIS VERSION DATED AUGUST 1983.
9113	C
9114	C ------------------------------------------------------------------
9115	C
9116	IF (N .LE. NM) GO TO 10
9117	IERR = 10 * N
9118	GO TO 50
9119	C
9120	10 IF (MATZ .NE. 0) GO TO 20
9121	C .......... FIND EIGENVALUES ONLY ..........
9122	CALL IMTQL1(N,W,E,IERR)
9123	GO TO 50
9124	C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
9125	20 DO 40 I = 1, N
9126	C
9127	DO 30 J = 1, N
9128	Z(J,I) = 0.0D0
9129	30 CONTINUE
9130	C
9131	Z(I,I) = 1.0D0
9132	40 CONTINUE
9133	C
9134	CALL IMTQL2(NM,N,W,E,Z,IERR)
9135	50 RETURN
9136	END
9137	SUBROUTINE RT(NM,N,A,W,MATZ,Z,FV1,IERR)
9138	C
9139	INTEGER N,NM,IERR,MATZ
9140	DOUBLE PRECISION A(NM,3),W(N),Z(NM,N),FV1(N)
9141	C
9142	C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
9143	C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
9144	C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
9145	C OF A SPECIAL REAL TRIDIAGONAL MATRIX.
9146	C
9147	C ON INPUT
9148	C
9149	C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
9150	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
9151	C DIMENSION STATEMENT.
9152	C
9153	C N IS THE ORDER OF THE MATRIX A.
9154	C
9155	C A CONTAINS THE SPECIAL REAL TRIDIAGONAL MATRIX IN ITS
9156	C FIRST THREE COLUMNS. THE SUBDIAGONAL ELEMENTS ARE STORED
9157	C IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN, THE
9158	C DIAGONAL ELEMENTS IN THE SECOND COLUMN, AND THE SUPERDIAGONAL
9159	C ELEMENTS IN THE FIRST N-1 POSITIONS OF THE THIRD COLUMN.
9160	C ELEMENTS A(1,1) AND A(N,3) ARE ARBITRARY.
9161	C
9162	C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
9163	C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
9164	C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
9165	C
9166	C ON OUTPUT
9167	C
9168	C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER.
9169	C
9170	C Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO.
9171	C
9172	C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
9173	C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR IMTQL1
9174	C AND IMTQL2. THE NORMAL COMPLETION CODE IS ZERO.
9175	C
9176	C FV1 IS A TEMPORARY STORAGE ARRAY.
9177	C
9178	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
9179	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
9180	C
9181	C THIS VERSION DATED AUGUST 1983.
9182	C
9183	C ------------------------------------------------------------------
9184	C
9185	IF (N .LE. NM) GO TO 10
9186	IERR = 10 * N
9187	GO TO 50
9188	C
9189	10 IF (MATZ .NE. 0) GO TO 20
9190	C .......... FIND EIGENVALUES ONLY ..........
9191	CALL FIGI(NM,N,A,W,FV1,FV1,IERR)
9192	IF (IERR .GT. 0) GO TO 50
9193	CALL IMTQL1(N,W,FV1,IERR)
9194	GO TO 50
9195	C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
9196	20 CALL FIGI2(NM,N,A,W,FV1,Z,IERR)
9197	IF (IERR .NE. 0) GO TO 50
9198	CALL IMTQL2(NM,N,W,FV1,Z,IERR)
9199	50 RETURN
9200	END
9201	SUBROUTINE SVD(NM,M,N,A,W,MATU,U,MATV,V,IERR,RV1)
9202	C
9203	INTEGER I,J,K,L,M,N,II,I1,KK,K1,LL,L1,MN,NM,ITS,IERR
9204	DOUBLE PRECISION A(NM,N),W(N),U(NM,N),V(NM,N),RV1(N)
9205	DOUBLE PRECISION C,F,G,H,S,X,Y,Z,TST1,TST2,SCALE,PYTHAG
9206	LOGICAL MATU,MATV
9207	C
9208	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE SVD,
9209	C NUM. MATH. 14, 403-420(1970) BY GOLUB AND REINSCH.
9210	C HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 134-151(1971).
9211	C
9212	C THIS SUBROUTINE DETERMINES THE SINGULAR VALUE DECOMPOSITION
9213	C T
9214	C A=USV OF A REAL M BY N RECTANGULAR MATRIX. HOUSEHOLDER
9215	C BIDIAGONALIZATION AND A VARIANT OF THE QR ALGORITHM ARE USED.
9216	C
9217	C ON INPUT
9218	C
9219	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
9220	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
9221	C DIMENSION STATEMENT. NOTE THAT NM MUST BE AT LEAST
9222	C AS LARGE AS THE MAXIMUM OF M AND N.
9223	C
9224	C M IS THE NUMBER OF ROWS OF A (AND U).
9225	C
9226	C N IS THE NUMBER OF COLUMNS OF A (AND U) AND THE ORDER OF V.
9227	C
9228	C A CONTAINS THE RECTANGULAR INPUT MATRIX TO BE DECOMPOSED.
9229	C
9230	C MATU SHOULD BE SET TO .TRUE. IF THE U MATRIX IN THE
9231	C DECOMPOSITION IS DESIRED, AND TO .FALSE. OTHERWISE.
9232	C
9233	C MATV SHOULD BE SET TO .TRUE. IF THE V MATRIX IN THE
9234	C DECOMPOSITION IS DESIRED, AND TO .FALSE. OTHERWISE.
9235	C
9236	C ON OUTPUT
9237	C
9238	C A IS UNALTERED (UNLESS OVERWRITTEN BY U OR V).
9239	C
9240	C W CONTAINS THE N (NON-NEGATIVE) SINGULAR VALUES OF A (THE
9241	C DIAGONAL ELEMENTS OF S). THEY ARE UNORDERED. IF AN
9242	C ERROR EXIT IS MADE, THE SINGULAR VALUES SHOULD BE CORRECT
9243	C FOR INDICES IERR+1,IERR+2,...,N.
9244	C
9245	C U CONTAINS THE MATRIX U (ORTHOGONAL COLUMN VECTORS) OF THE
9246	C DECOMPOSITION IF MATU HAS BEEN SET TO .TRUE. OTHERWISE
9247	C U IS USED AS A TEMPORARY ARRAY. U MAY COINCIDE WITH A.
9248	C IF AN ERROR EXIT IS MADE, THE COLUMNS OF U CORRESPONDING
9249	C TO INDICES OF CORRECT SINGULAR VALUES SHOULD BE CORRECT.
9250	C
9251	C V CONTAINS THE MATRIX V (ORTHOGONAL) OF THE DECOMPOSITION IF
9252	C MATV HAS BEEN SET TO .TRUE. OTHERWISE V IS NOT REFERENCED.
9253	C V MAY ALSO COINCIDE WITH A IF U IS NOT NEEDED. IF AN ERROR
9254	C EXIT IS MADE, THE COLUMNS OF V CORRESPONDING TO INDICES OF
9255	C CORRECT SINGULAR VALUES SHOULD BE CORRECT.
9256	C
9257	C IERR IS SET TO
9258	C ZERO FOR NORMAL RETURN,
9259	C K IF THE K-TH SINGULAR VALUE HAS NOT BEEN
9260	C DETERMINED AFTER 30 ITERATIONS.
9261	C
9262	C RV1 IS A TEMPORARY STORAGE ARRAY.
9263	C
9264	C CALLS PYTHAG FOR DSQRT(AA + BB) .
9265	C
9266	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
9267	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
9268	C
9269	C THIS VERSION DATED AUGUST 1983.
9270	C
9271	C ------------------------------------------------------------------
9272	C
9273	IERR = 0
9274	C
9275	DO 100 I = 1, M
9276	C
9277	DO 100 J = 1, N
9278	U(I,J) = A(I,J)
9279	100 CONTINUE
9280	C .......... HOUSEHOLDER REDUCTION TO BIDIAGONAL FORM ..........
9281	G = 0.0D0
9282	SCALE = 0.0D0
9283	X = 0.0D0
9284	C
9285	DO 300 I = 1, N
9286	L = I + 1
9287	RV1(I) = SCALE * G
9288	G = 0.0D0
9289	S = 0.0D0
9290	SCALE = 0.0D0
9291	IF (I .GT. M) GO TO 210
9292	C
9293	DO 120 K = I, M
9294	120 SCALE = SCALE + DABS(U(K,I))
9295	C
9296	IF (SCALE .EQ. 0.0D0) GO TO 210
9297	C
9298	DO 130 K = I, M
9299	U(K,I) = U(K,I) / SCALE
9300	S = S + U(K,I)**2
9301	130 CONTINUE
9302	C
9303	F = U(I,I)
9304	G = -DSIGN(DSQRT(S),F)
9305	H = F * G - S
9306	U(I,I) = F - G
9307	IF (I .EQ. N) GO TO 190
9308	C
9309	DO 150 J = L, N
9310	S = 0.0D0
9311	C
9312	DO 140 K = I, M
9313	140 S = S + U(K,I) * U(K,J)
9314	C
9315	F = S / H
9316	C
9317	DO 150 K = I, M
9318	U(K,J) = U(K,J) + F * U(K,I)
9319	150 CONTINUE
9320	C
9321	190 DO 200 K = I, M
9322	200 U(K,I) = SCALE * U(K,I)
9323	C
9324	210 W(I) = SCALE * G
9325	G = 0.0D0
9326	S = 0.0D0
9327	SCALE = 0.0D0
9328	IF (I .GT. M .OR. I .EQ. N) GO TO 290
9329	C
9330	DO 220 K = L, N
9331	220 SCALE = SCALE + DABS(U(I,K))
9332	C
9333	IF (SCALE .EQ. 0.0D0) GO TO 290
9334	C
9335	DO 230 K = L, N
9336	U(I,K) = U(I,K) / SCALE
9337	S = S + U(I,K)**2
9338	230 CONTINUE
9339	C
9340	F = U(I,L)
9341	G = -DSIGN(DSQRT(S),F)
9342	H = F * G - S
9343	U(I,L) = F - G
9344	C
9345	DO 240 K = L, N
9346	240 RV1(K) = U(I,K) / H
9347	C
9348	IF (I .EQ. M) GO TO 270
9349	C
9350	DO 260 J = L, M
9351	S = 0.0D0
9352	C
9353	DO 250 K = L, N
9354	250 S = S + U(J,K) * U(I,K)
9355	C
9356	DO 260 K = L, N
9357	U(J,K) = U(J,K) + S * RV1(K)
9358	260 CONTINUE
9359	C
9360	270 DO 280 K = L, N
9361	280 U(I,K) = SCALE * U(I,K)
9362	C
9363	290 X = DMAX1(X,DABS(W(I))+DABS(RV1(I)))
9364	300 CONTINUE
9365	C .......... ACCUMULATION OF RIGHT-HAND TRANSFORMATIONS ..........
9366	IF (.NOT. MATV) GO TO 410
9367	C .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
9368	DO 400 II = 1, N
9369	I = N + 1 - II
9370	IF (I .EQ. N) GO TO 390
9371	IF (G .EQ. 0.0D0) GO TO 360
9372	C
9373	DO 320 J = L, N
9374	C .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ..........
9375	320 V(J,I) = (U(I,J) / U(I,L)) / G
9376	C
9377	DO 350 J = L, N
9378	S = 0.0D0
9379	C
9380	DO 340 K = L, N
9381	340 S = S + U(I,K) * V(K,J)
9382	C
9383	DO 350 K = L, N
9384	V(K,J) = V(K,J) + S * V(K,I)
9385	350 CONTINUE
9386	C
9387	360 DO 380 J = L, N
9388	V(I,J) = 0.0D0
9389	V(J,I) = 0.0D0
9390	380 CONTINUE
9391	C
9392	390 V(I,I) = 1.0D0
9393	G = RV1(I)
9394	L = I
9395	400 CONTINUE
9396	C .......... ACCUMULATION OF LEFT-HAND TRANSFORMATIONS ..........
9397	410 IF (.NOT. MATU) GO TO 510
9398	C ..........FOR I=MIN(M,N) STEP -1 UNTIL 1 DO -- ..........
9399	MN = N
9400	IF (M .LT. N) MN = M
9401	C
9402	DO 500 II = 1, MN
9403	I = MN + 1 - II
9404	L = I + 1
9405	G = W(I)
9406	IF (I .EQ. N) GO TO 430
9407	C
9408	DO 420 J = L, N
9409	420 U(I,J) = 0.0D0
9410	C
9411	430 IF (G .EQ. 0.0D0) GO TO 475
9412	IF (I .EQ. MN) GO TO 460
9413	C
9414	DO 450 J = L, N
9415	S = 0.0D0
9416	C
9417	DO 440 K = L, M
9418	440 S = S + U(K,I) * U(K,J)
9419	C .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ..........
9420	F = (S / U(I,I)) / G
9421	C
9422	DO 450 K = I, M
9423	U(K,J) = U(K,J) + F * U(K,I)
9424	450 CONTINUE
9425	C
9426	460 DO 470 J = I, M
9427	470 U(J,I) = U(J,I) / G
9428	C
9429	GO TO 490
9430	C
9431	475 DO 480 J = I, M
9432	480 U(J,I) = 0.0D0
9433	C
9434	490 U(I,I) = U(I,I) + 1.0D0
9435	500 CONTINUE
9436	C .......... DIAGONALIZATION OF THE BIDIAGONAL FORM ..........
9437	510 TST1 = X
9438	C .......... FOR K=N STEP -1 UNTIL 1 DO -- ..........
9439	DO 700 KK = 1, N
9440	K1 = N - KK
9441	K = K1 + 1
9442	ITS = 0
9443	C .......... TEST FOR SPLITTING.
9444	C FOR L=K STEP -1 UNTIL 1 DO -- ..........
9445	520 DO 530 LL = 1, K
9446	L1 = K - LL
9447	L = L1 + 1
9448	TST2 = TST1 + DABS(RV1(L))
9449	IF (TST2 .EQ. TST1) GO TO 565
9450	C .......... RV1(1) IS ALWAYS ZERO, SO THERE IS NO EXIT
9451	C THROUGH THE BOTTOM OF THE LOOP ..........
9452	TST2 = TST1 + DABS(W(L1))
9453	IF (TST2 .EQ. TST1) GO TO 540
9454	530 CONTINUE
9455	C .......... CANCELLATION OF RV1(L) IF L GREATER THAN 1 ..........
9456	540 C = 0.0D0
9457	S = 1.0D0
9458	C
9459	DO 560 I = L, K
9460	F = S * RV1(I)
9461	RV1(I) = C * RV1(I)
9462	TST2 = TST1 + DABS(F)
9463	IF (TST2 .EQ. TST1) GO TO 565
9464	G = W(I)
9465	H = PYTHAG(F,G)
9466	W(I) = H
9467	C = G / H
9468	S = -F / H
9469	IF (.NOT. MATU) GO TO 560
9470	C
9471	DO 550 J = 1, M
9472	Y = U(J,L1)
9473	Z = U(J,I)
9474	U(J,L1) = Y * C + Z * S
9475	U(J,I) = -Y * S + Z * C
9476	550 CONTINUE
9477	C
9478	560 CONTINUE
9479	C .......... TEST FOR CONVERGENCE ..........
9480	565 Z = W(K)
9481	IF (L .EQ. K) GO TO 650
9482	C .......... SHIFT FROM BOTTOM 2 BY 2 MINOR ..........
9483	IF (ITS .EQ. 30) GO TO 1000
9484	ITS = ITS + 1
9485	X = W(L)
9486	Y = W(K1)
9487	G = RV1(K1)
9488	H = RV1(K)
9489	F = 0.5D0 * (((G + Z) / H) * ((G - Z) / Y) + Y / H - H / Y)
9490	G = PYTHAG(F,1.0D0)
9491	F = X - (Z / X) * Z + (H / X) * (Y / (F + DSIGN(G,F)) - H)
9492	C .......... NEXT QR TRANSFORMATION ..........
9493	C = 1.0D0
9494	S = 1.0D0
9495	C
9496	DO 600 I1 = L, K1
9497	I = I1 + 1
9498	G = RV1(I)
9499	Y = W(I)
9500	H = S * G
9501	G = C * G
9502	Z = PYTHAG(F,H)
9503	RV1(I1) = Z
9504	C = F / Z
9505	S = H / Z
9506	F = X * C + G * S
9507	G = -X * S + G * C
9508	H = Y * S
9509	Y = Y * C
9510	IF (.NOT. MATV) GO TO 575
9511	C
9512	DO 570 J = 1, N
9513	X = V(J,I1)
9514	Z = V(J,I)
9515	V(J,I1) = X * C + Z * S
9516	V(J,I) = -X * S + Z * C
9517	570 CONTINUE
9518	C
9519	575 Z = PYTHAG(F,H)
9520	W(I1) = Z
9521	C .......... ROTATION CAN BE ARBITRARY IF Z IS ZERO ..........
9522	IF (Z .EQ. 0.0D0) GO TO 580
9523	C = F / Z
9524	S = H / Z
9525	580 F = C * G + S * Y
9526	X = -S * G + C * Y
9527	IF (.NOT. MATU) GO TO 600
9528	C
9529	DO 590 J = 1, M
9530	Y = U(J,I1)
9531	Z = U(J,I)
9532	U(J,I1) = Y * C + Z * S
9533	U(J,I) = -Y * S + Z * C
9534	590 CONTINUE
9535	C
9536	600 CONTINUE
9537	C
9538	RV1(L) = 0.0D0
9539	RV1(K) = F
9540	W(K) = X
9541	GO TO 520
9542	C .......... CONVERGENCE ..........
9543	650 IF (Z .GE. 0.0D0) GO TO 700
9544	C .......... W(K) IS MADE NON-NEGATIVE ..........
9545	W(K) = -Z
9546	IF (.NOT. MATV) GO TO 700
9547	C
9548	DO 690 J = 1, N
9549	690 V(J,K) = -V(J,K)
9550	C
9551	700 CONTINUE
9552	C
9553	GO TO 1001
9554	C .......... SET ERROR -- NO CONVERGENCE TO A
9555	C SINGULAR VALUE AFTER 30 ITERATIONS ..........
9556	1000 IERR = K
9557	1001 RETURN
9558	END
9559	SUBROUTINE TINVIT(NM,N,D,E,E2,M,W,IND,Z,
9560	X IERR,RV1,RV2,RV3,RV4,RV6)
9561	C
9562	INTEGER I,J,M,N,P,Q,R,S,II,IP,JJ,NM,ITS,TAG,IERR,GROUP
9563	DOUBLE PRECISION D(N),E(N),E2(N),W(M),Z(NM,M),
9564	X RV1(N),RV2(N),RV3(N),RV4(N),RV6(N)
9565	DOUBLE PRECISION U,V,UK,XU,X0,X1,EPS2,EPS3,EPS4,NORM,ORDER,EPSLON,
9566	X PYTHAG
9567	INTEGER IND(M)
9568	C
9569	C THIS SUBROUTINE IS A TRANSLATION OF THE INVERSE ITERATION TECH-
9570	C NIQUE IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON.
9571	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971).
9572	C
9573	C THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A TRIDIAGONAL
9574	C SYMMETRIC MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES,
9575	C USING INVERSE ITERATION.
9576	C
9577	C ON INPUT
9578	C
9579	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
9580	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
9581	C DIMENSION STATEMENT.
9582	C
9583	C N IS THE ORDER OF THE MATRIX.
9584	C
9585	C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
9586	C
9587	C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
9588	C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY.
9589	C
9590	C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E,
9591	C WITH ZEROS CORRESPONDING TO NEGLIGIBLE ELEMENTS OF E.
9592	C E(I) IS CONSIDERED NEGLIGIBLE IF IT IS NOT LARGER THAN
9593	C THE PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE SUM
9594	C OF THE MAGNITUDES OF D(I) AND D(I-1). E2(1) MUST CONTAIN
9595	C 0.0D0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, OR 2.0D0
9596	C IF THE EIGENVALUES ARE IN DESCENDING ORDER. IF BISECT,
9597	C TRIDIB, OR IMTQLV HAS BEEN USED TO FIND THE EIGENVALUES,
9598	C THEIR OUTPUT E2 ARRAY IS EXACTLY WHAT IS EXPECTED HERE.
9599	C
9600	C M IS THE NUMBER OF SPECIFIED EIGENVALUES.
9601	C
9602	C W CONTAINS THE M EIGENVALUES IN ASCENDING OR DESCENDING ORDER.
9603	C
9604	C IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES
9605	C ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W --
9606	C 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM
9607	C THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC.
9608	C
9609	C ON OUTPUT
9610	C
9611	C ALL INPUT ARRAYS ARE UNALTERED.
9612	C
9613	C Z CONTAINS THE ASSOCIATED SET OF ORTHONORMAL EIGENVECTORS.
9614	C ANY VECTOR WHICH FAILS TO CONVERGE IS SET TO ZERO.
9615	C
9616	C IERR IS SET TO
9617	C ZERO FOR NORMAL RETURN,
9618	C -R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH
9619	C EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS.
9620	C
9621	C RV1, RV2, RV3, RV4, AND RV6 ARE TEMPORARY STORAGE ARRAYS.
9622	C
9623	C CALLS PYTHAG FOR DSQRT(AA + BB) .
9624	C
9625	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
9626	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
9627	C
9628	C THIS VERSION DATED AUGUST 1983.
9629	C
9630	C ------------------------------------------------------------------
9631	C
9632	IERR = 0
9633	IF (M .EQ. 0) GO TO 1001
9634	TAG = 0
9635	ORDER = 1.0D0 - E2(1)
9636	Q = 0
9637	C .......... ESTABLISH AND PROCESS NEXT SUBMATRIX ..........
9638	100 P = Q + 1
9639	C
9640	DO 120 Q = P, N
9641	IF (Q .EQ. N) GO TO 140
9642	IF (E2(Q+1) .EQ. 0.0D0) GO TO 140
9643	120 CONTINUE
9644	C .......... FIND VECTORS BY INVERSE ITERATION ..........
9645	140 TAG = TAG + 1
9646	S = 0
9647	C
9648	DO 920 R = 1, M
9649	IF (IND(R) .NE. TAG) GO TO 920
9650	ITS = 1
9651	X1 = W(R)
9652	IF (S .NE. 0) GO TO 510
9653	C .......... CHECK FOR ISOLATED ROOT ..........
9654	XU = 1.0D0
9655	IF (P .NE. Q) GO TO 490
9656	RV6(P) = 1.0D0
9657	GO TO 870
9658	490 NORM = DABS(D(P))
9659	IP = P + 1
9660	C
9661	DO 500 I = IP, Q
9662	500 NORM = DMAX1(NORM, DABS(D(I))+DABS(E(I)))
9663	C .......... EPS2 IS THE CRITERION FOR GROUPING,
9664	C EPS3 REPLACES ZERO PIVOTS AND EQUAL
9665	C ROOTS ARE MODIFIED BY EPS3,
9666	C EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW ..........
9667	EPS2 = 1.0D-3 * NORM
9668	EPS3 = EPSLON(NORM)
9669	UK = Q - P + 1
9670	EPS4 = UK * EPS3
9671	UK = EPS4 / DSQRT(UK)
9672	S = P
9673	505 GROUP = 0
9674	GO TO 520
9675	C .......... LOOK FOR CLOSE OR COINCIDENT ROOTS ..........
9676	510 IF (DABS(X1-X0) .GE. EPS2) GO TO 505
9677	GROUP = GROUP + 1
9678	IF (ORDER * (X1 - X0) .LE. 0.0D0) X1 = X0 + ORDER * EPS3
9679	C .......... ELIMINATION WITH INTERCHANGES AND
9680	C INITIALIZATION OF VECTOR ..........
9681	520 V = 0.0D0
9682	C
9683	DO 580 I = P, Q
9684	RV6(I) = UK
9685	IF (I .EQ. P) GO TO 560
9686	IF (DABS(E(I)) .LT. DABS(U)) GO TO 540
9687	C .......... WARNING -- A DIVIDE CHECK MAY OCCUR HERE IF
9688	C E2 ARRAY HAS NOT BEEN SPECIFIED CORRECTLY ..........
9689	XU = U / E(I)
9690	RV4(I) = XU
9691	RV1(I-1) = E(I)
9692	RV2(I-1) = D(I) - X1
9693	RV3(I-1) = 0.0D0
9694	IF (I .NE. Q) RV3(I-1) = E(I+1)
9695	U = V - XU * RV2(I-1)
9696	V = -XU * RV3(I-1)
9697	GO TO 580
9698	540 XU = E(I) / U
9699	RV4(I) = XU
9700	RV1(I-1) = U
9701	RV2(I-1) = V
9702	RV3(I-1) = 0.0D0
9703	560 U = D(I) - X1 - XU * V
9704	IF (I .NE. Q) V = E(I+1)
9705	580 CONTINUE
9706	C
9707	IF (U .EQ. 0.0D0) U = EPS3
9708	RV1(Q) = U
9709	RV2(Q) = 0.0D0
9710	RV3(Q) = 0.0D0
9711	C .......... BACK SUBSTITUTION
9712	C FOR I=Q STEP -1 UNTIL P DO -- ..........
9713	600 DO 620 II = P, Q
9714	I = P + Q - II
9715	RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I)
9716	V = U
9717	U = RV6(I)
9718	620 CONTINUE
9719	C .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS
9720	C MEMBERS OF GROUP ..........
9721	IF (GROUP .EQ. 0) GO TO 700
9722	J = R
9723	C
9724	DO 680 JJ = 1, GROUP
9725	630 J = J - 1
9726	IF (IND(J) .NE. TAG) GO TO 630
9727	XU = 0.0D0
9728	C
9729	DO 640 I = P, Q
9730	640 XU = XU + RV6(I) * Z(I,J)
9731	C
9732	DO 660 I = P, Q
9733	660 RV6(I) = RV6(I) - XU * Z(I,J)
9734	C
9735	680 CONTINUE
9736	C
9737	700 NORM = 0.0D0
9738	C
9739	DO 720 I = P, Q
9740	720 NORM = NORM + DABS(RV6(I))
9741	C
9742	IF (NORM .GE. 1.0D0) GO TO 840
9743	C .......... FORWARD SUBSTITUTION ..........
9744	IF (ITS .EQ. 5) GO TO 830
9745	IF (NORM .NE. 0.0D0) GO TO 740
9746	RV6(S) = EPS4
9747	S = S + 1
9748	IF (S .GT. Q) S = P
9749	GO TO 780
9750	740 XU = EPS4 / NORM
9751	C
9752	DO 760 I = P, Q
9753	760 RV6(I) = RV6(I) * XU
9754	C .......... ELIMINATION OPERATIONS ON NEXT VECTOR
9755	C ITERATE ..........
9756	780 DO 820 I = IP, Q
9757	U = RV6(I)
9758	C .......... IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE
9759	C WAS PERFORMED EARLIER IN THE
9760	C TRIANGULARIZATION PROCESS ..........
9761	IF (RV1(I-1) .NE. E(I)) GO TO 800
9762	U = RV6(I-1)
9763	RV6(I-1) = RV6(I)
9764	800 RV6(I) = U - RV4(I) * RV6(I-1)
9765	820 CONTINUE
9766	C
9767	ITS = ITS + 1
9768	GO TO 600
9769	C .......... SET ERROR -- NON-CONVERGED EIGENVECTOR ..........
9770	830 IERR = -R
9771	XU = 0.0D0
9772	GO TO 870
9773	C .......... NORMALIZE SO THAT SUM OF SQUARES IS
9774	C 1 AND EXPAND TO FULL ORDER ..........
9775	840 U = 0.0D0
9776	C
9777	DO 860 I = P, Q
9778	860 U = PYTHAG(U,RV6(I))
9779	C
9780	XU = 1.0D0 / U
9781	C
9782	870 DO 880 I = 1, N
9783	880 Z(I,R) = 0.0D0
9784	C
9785	DO 900 I = P, Q
9786	900 Z(I,R) = RV6(I) * XU
9787	C
9788	X0 = X1
9789	920 CONTINUE
9790	C
9791	IF (Q .LT. N) GO TO 100
9792	1001 RETURN
9793	END
9794	SUBROUTINE TQL1(N,D,E,IERR)
9795	C
9796	INTEGER I,J,L,M,N,II,L1,L2,MML,IERR
9797	DOUBLE PRECISION D(N),E(N)
9798	DOUBLE PRECISION C,C2,C3,DL1,EL1,F,G,H,P,R,S,S2,TST1,TST2,PYTHAG
9799	C
9800	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL1,
9801	C NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND
9802	C WILKINSON.
9803	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971).
9804	C
9805	C THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC
9806	C TRIDIAGONAL MATRIX BY THE QL METHOD.
9807	C
9808	C ON INPUT
9809	C
9810	C N IS THE ORDER OF THE MATRIX.
9811	C
9812	C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
9813	C
9814	C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
9815	C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY.
9816	C
9817	C ON OUTPUT
9818	C
9819	C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN
9820	C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND
9821	C ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE
9822	C THE SMALLEST EIGENVALUES.
9823	C
9824	C E HAS BEEN DESTROYED.
9825	C
9826	C IERR IS SET TO
9827	C ZERO FOR NORMAL RETURN,
9828	C J IF THE J-TH EIGENVALUE HAS NOT BEEN
9829	C DETERMINED AFTER 30 ITERATIONS.
9830	C
9831	C CALLS PYTHAG FOR DSQRT(AA + BB) .
9832	C
9833	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
9834	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
9835	C
9836	C THIS VERSION DATED AUGUST 1983.
9837	C
9838	C ------------------------------------------------------------------
9839	C
9840	IERR = 0
9841	IF (N .EQ. 1) GO TO 1001
9842	C
9843	DO 100 I = 2, N
9844	100 E(I-1) = E(I)
9845	C
9846	F = 0.0D0
9847	TST1 = 0.0D0
9848	E(N) = 0.0D0
9849	C
9850	DO 290 L = 1, N
9851	J = 0
9852	H = DABS(D(L)) + DABS(E(L))
9853	IF (TST1 .LT. H) TST1 = H
9854	C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT ..........
9855	DO 110 M = L, N
9856	TST2 = TST1 + DABS(E(M))
9857	IF (TST2 .EQ. TST1) GO TO 120
9858	C .......... E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
9859	C THROUGH THE BOTTOM OF THE LOOP ..........
9860	110 CONTINUE
9861	C
9862	120 IF (M .EQ. L) GO TO 210
9863	130 IF (J .EQ. 30) GO TO 1000
9864	J = J + 1
9865	C .......... FORM SHIFT ..........
9866	L1 = L + 1
9867	L2 = L1 + 1
9868	G = D(L)
9869	P = (D(L1) - G) / (2.0D0 * E(L))
9870	R = PYTHAG(P,1.0D0)
9871	D(L) = E(L) / (P + DSIGN(R,P))
9872	D(L1) = E(L) * (P + DSIGN(R,P))
9873	DL1 = D(L1)
9874	H = G - D(L)
9875	IF (L2 .GT. N) GO TO 145
9876	C
9877	DO 140 I = L2, N
9878	140 D(I) = D(I) - H
9879	C
9880	145 F = F + H
9881	C .......... QL TRANSFORMATION ..........
9882	P = D(M)
9883	C = 1.0D0
9884	C2 = C
9885	EL1 = E(L1)
9886	S = 0.0D0
9887	MML = M - L
9888	C .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
9889	DO 200 II = 1, MML
9890	C3 = C2
9891	C2 = C
9892	S2 = S
9893	I = M - II
9894	G = C * E(I)
9895	H = C * P
9896	R = PYTHAG(P,E(I))
9897	E(I+1) = S * R
9898	S = E(I) / R
9899	C = P / R
9900	P = C * D(I) - S * G
9901	D(I+1) = H + S * (C * G + S * D(I))
9902	200 CONTINUE
9903	C
9904	P = -S * S2 * C3 * EL1 * E(L) / DL1
9905	E(L) = S * P
9906	D(L) = C * P
9907	TST2 = TST1 + DABS(E(L))
9908	IF (TST2 .GT. TST1) GO TO 130
9909	210 P = D(L) + F
9910	C .......... ORDER EIGENVALUES ..........
9911	IF (L .EQ. 1) GO TO 250
9912	C .......... FOR I=L STEP -1 UNTIL 2 DO -- ..........
9913	DO 230 II = 2, L
9914	I = L + 2 - II
9915	IF (P .GE. D(I-1)) GO TO 270
9916	D(I) = D(I-1)
9917	230 CONTINUE
9918	C
9919	250 I = 1
9920	270 D(I) = P
9921	290 CONTINUE
9922	C
9923	GO TO 1001
9924	C .......... SET ERROR -- NO CONVERGENCE TO AN
9925	C EIGENVALUE AFTER 30 ITERATIONS ..........
9926	1000 IERR = L
9927	1001 RETURN
9928	END
9929	SUBROUTINE TQL2(NM,N,D,E,Z,IERR)
9930	C
9931	INTEGER I,J,K,L,M,N,II,L1,L2,NM,MML,IERR
9932	DOUBLE PRECISION D(N),E(N),Z(NM,N)
9933	DOUBLE PRECISION C,C2,C3,DL1,EL1,F,G,H,P,R,S,S2,TST1,TST2,PYTHAG
9934	C
9935	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2,
9936	C NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND
9937	C WILKINSON.
9938	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971).
9939	C
9940	C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
9941	C OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD.
9942	C THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO
9943	C BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS
9944	C FULL MATRIX TO TRIDIAGONAL FORM.
9945	C
9946	C ON INPUT
9947	C
9948	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
9949	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
9950	C DIMENSION STATEMENT.
9951	C
9952	C N IS THE ORDER OF THE MATRIX.
9953	C
9954	C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
9955	C
9956	C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
9957	C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY.
9958	C
9959	C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
9960	C REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS
9961	C OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN
9962	C THE IDENTITY MATRIX.
9963	C
9964	C ON OUTPUT
9965	C
9966	C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN
9967	C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT
9968	C UNORDERED FOR INDICES 1,2,...,IERR-1.
9969	C
9970	C E HAS BEEN DESTROYED.
9971	C
9972	C Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC
9973	C TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE,
9974	C Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED
9975	C EIGENVALUES.
9976	C
9977	C IERR IS SET TO
9978	C ZERO FOR NORMAL RETURN,
9979	C J IF THE J-TH EIGENVALUE HAS NOT BEEN
9980	C DETERMINED AFTER 30 ITERATIONS.
9981	C
9982	C CALLS PYTHAG FOR DSQRT(AA + BB) .
9983	C
9984	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
9985	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
9986	C
9987	C THIS VERSION DATED AUGUST 1983.
9988	C
9989	C ------------------------------------------------------------------
9990	C
9991	IERR = 0
9992	IF (N .EQ. 1) GO TO 1001
9993	C
9994	DO 100 I = 2, N
9995	100 E(I-1) = E(I)
9996	C
9997	F = 0.0D0
9998	TST1 = 0.0D0
9999	E(N) = 0.0D0
10000	C
10001	DO 240 L = 1, N
10002	J = 0
10003	H = DABS(D(L)) + DABS(E(L))
10004	IF (TST1 .LT. H) TST1 = H
10005	C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT ..........
10006	DO 110 M = L, N
10007	TST2 = TST1 + DABS(E(M))
10008	IF (TST2 .EQ. TST1) GO TO 120
10009	C .......... E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
10010	C THROUGH THE BOTTOM OF THE LOOP ..........
10011	110 CONTINUE
10012	C
10013	120 IF (M .EQ. L) GO TO 220
10014	130 IF (J .EQ. 30) GO TO 1000
10015	J = J + 1
10016	C .......... FORM SHIFT ..........
10017	L1 = L + 1
10018	L2 = L1 + 1
10019	G = D(L)
10020	P = (D(L1) - G) / (2.0D0 * E(L))
10021	R = PYTHAG(P,1.0D0)
10022	D(L) = E(L) / (P + DSIGN(R,P))
10023	D(L1) = E(L) * (P + DSIGN(R,P))
10024	DL1 = D(L1)
10025	H = G - D(L)
10026	IF (L2 .GT. N) GO TO 145
10027	C
10028	DO 140 I = L2, N
10029	140 D(I) = D(I) - H
10030	C
10031	145 F = F + H
10032	C .......... QL TRANSFORMATION ..........
10033	P = D(M)
10034	C = 1.0D0
10035	C2 = C
10036	EL1 = E(L1)
10037	S = 0.0D0
10038	MML = M - L
10039	C .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
10040	DO 200 II = 1, MML
10041	C3 = C2
10042	C2 = C
10043	S2 = S
10044	I = M - II
10045	G = C * E(I)
10046	H = C * P
10047	R = PYTHAG(P,E(I))
10048	E(I+1) = S * R
10049	S = E(I) / R
10050	C = P / R
10051	P = C * D(I) - S * G
10052	D(I+1) = H + S * (C * G + S * D(I))
10053	C .......... FORM VECTOR ..........
10054	DO 180 K = 1, N
10055	H = Z(K,I+1)
10056	Z(K,I+1) = S * Z(K,I) + C * H
10057	Z(K,I) = C * Z(K,I) - S * H
10058	180 CONTINUE
10059	C
10060	200 CONTINUE
10061	C
10062	P = -S * S2 * C3 * EL1 * E(L) / DL1
10063	E(L) = S * P
10064	D(L) = C * P
10065	TST2 = TST1 + DABS(E(L))
10066	IF (TST2 .GT. TST1) GO TO 130
10067	220 D(L) = D(L) + F
10068	240 CONTINUE
10069	C .......... ORDER EIGENVALUES AND EIGENVECTORS ..........
10070	DO 300 II = 2, N
10071	I = II - 1
10072	K = I
10073	P = D(I)
10074	C
10075	DO 260 J = II, N
10076	IF (D(J) .GE. P) GO TO 260
10077	K = J
10078	P = D(J)
10079	260 CONTINUE
10080	C
10081	IF (K .EQ. I) GO TO 300
10082	D(K) = D(I)
10083	D(I) = P
10084	C
10085	DO 280 J = 1, N
10086	P = Z(J,I)
10087	Z(J,I) = Z(J,K)
10088	Z(J,K) = P
10089	280 CONTINUE
10090	C
10091	300 CONTINUE
10092	C
10093	GO TO 1001
10094	C .......... SET ERROR -- NO CONVERGENCE TO AN
10095	C EIGENVALUE AFTER 30 ITERATIONS ..........
10096	1000 IERR = L
10097	1001 RETURN
10098	END
10099	SUBROUTINE TQLRAT(N,D,E2,IERR)
10100	C
10101	INTEGER I,J,L,M,N,II,L1,MML,IERR
10102	DOUBLE PRECISION D(N),E2(N)
10103	DOUBLE PRECISION B,C,F,G,H,P,R,S,T,EPSLON,PYTHAG
10104	C
10105	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQLRAT,
10106	C ALGORITHM 464, COMM. ACM 16, 689(1973) BY REINSCH.
10107	C
10108	C THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC
10109	C TRIDIAGONAL MATRIX BY THE RATIONAL QL METHOD.
10110	C
10111	C ON INPUT
10112	C
10113	C N IS THE ORDER OF THE MATRIX.
10114	C
10115	C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
10116	C
10117	C E2 CONTAINS THE SQUARES OF THE SUBDIAGONAL ELEMENTS OF THE
10118	C INPUT MATRIX IN ITS LAST N-1 POSITIONS. E2(1) IS ARBITRARY.
10119	C
10120	C ON OUTPUT
10121	C
10122	C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN
10123	C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND
10124	C ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE
10125	C THE SMALLEST EIGENVALUES.
10126	C
10127	C E2 HAS BEEN DESTROYED.
10128	C
10129	C IERR IS SET TO
10130	C ZERO FOR NORMAL RETURN,
10131	C J IF THE J-TH EIGENVALUE HAS NOT BEEN
10132	C DETERMINED AFTER 30 ITERATIONS.
10133	C
10134	C CALLS PYTHAG FOR DSQRT(AA + BB) .
10135	C
10136	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
10137	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
10138	C
10139	C THIS VERSION DATED AUGUST 1983.
10140	C
10141	C ------------------------------------------------------------------
10142	C
10143	IERR = 0
10144	IF (N .EQ. 1) GO TO 1001
10145	C
10146	DO 100 I = 2, N
10147	100 E2(I-1) = E2(I)
10148	C
10149	F = 0.0D0
10150	T = 0.0D0
10151	E2(N) = 0.0D0
10152	C
10153	DO 290 L = 1, N
10154	J = 0
10155	H = DABS(D(L)) + DSQRT(E2(L))
10156	IF (T .GT. H) GO TO 105
10157	T = H
10158	B = EPSLON(T)
10159	C = B * B
10160	C .......... LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT ..........
10161	105 DO 110 M = L, N
10162	IF (E2(M) .LE. C) GO TO 120
10163	C .......... E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
10164	C THROUGH THE BOTTOM OF THE LOOP ..........
10165	110 CONTINUE
10166	C
10167	120 IF (M .EQ. L) GO TO 210
10168	130 IF (J .EQ. 30) GO TO 1000
10169	J = J + 1
10170	C .......... FORM SHIFT ..........
10171	L1 = L + 1
10172	S = DSQRT(E2(L))
10173	G = D(L)
10174	P = (D(L1) - G) / (2.0D0 * S)
10175	R = PYTHAG(P,1.0D0)
10176	D(L) = S / (P + DSIGN(R,P))
10177	H = G - D(L)
10178	C
10179	DO 140 I = L1, N
10180	140 D(I) = D(I) - H
10181	C
10182	F = F + H
10183	C .......... RATIONAL QL TRANSFORMATION ..........
10184	G = D(M)
10185	IF (G .EQ. 0.0D0) G = B
10186	H = G
10187	S = 0.0D0
10188	MML = M - L
10189	C .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
10190	DO 200 II = 1, MML
10191	I = M - II
10192	P = G * H
10193	R = P + E2(I)
10194	E2(I+1) = S * R
10195	S = E2(I) / R
10196	D(I+1) = H + S * (H + D(I))
10197	G = D(I) - E2(I) / G
10198	IF (G .EQ. 0.0D0) G = B
10199	H = G * P / R
10200	200 CONTINUE
10201	C
10202	E2(L) = S * G
10203	D(L) = H
10204	C .......... GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST ..........
10205	IF (H .EQ. 0.0D0) GO TO 210
10206	IF (DABS(E2(L)) .LE. DABS(C/H)) GO TO 210
10207	E2(L) = H * E2(L)
10208	IF (E2(L) .NE. 0.0D0) GO TO 130
10209	210 P = D(L) + F
10210	C .......... ORDER EIGENVALUES ..........
10211	IF (L .EQ. 1) GO TO 250
10212	C .......... FOR I=L STEP -1 UNTIL 2 DO -- ..........
10213	DO 230 II = 2, L
10214	I = L + 2 - II
10215	IF (P .GE. D(I-1)) GO TO 270
10216	D(I) = D(I-1)
10217	230 CONTINUE
10218	C
10219	250 I = 1
10220	270 D(I) = P
10221	290 CONTINUE
10222	C
10223	GO TO 1001
10224	C .......... SET ERROR -- NO CONVERGENCE TO AN
10225	C EIGENVALUE AFTER 30 ITERATIONS ..........
10226	1000 IERR = L
10227	1001 RETURN
10228	END
10229	SUBROUTINE TRBAK1(NM,N,A,E,M,Z)
10230	C
10231	INTEGER I,J,K,L,M,N,NM
10232	DOUBLE PRECISION A(NM,N),E(N),Z(NM,M)
10233	DOUBLE PRECISION S
10234	C
10235	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK1,
10236	C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
10237	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
10238	C
10239	C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC
10240	C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
10241	C SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY TRED1.
10242	C
10243	C ON INPUT
10244	C
10245	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
10246	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
10247	C DIMENSION STATEMENT.
10248	C
10249	C N IS THE ORDER OF THE MATRIX.
10250	C
10251	C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS-
10252	C FORMATIONS USED IN THE REDUCTION BY TRED1
10253	C IN ITS STRICT LOWER TRIANGLE.
10254	C
10255	C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
10256	C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY.
10257	C
10258	C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
10259	C
10260	C Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED
10261	C IN ITS FIRST M COLUMNS.
10262	C
10263	C ON OUTPUT
10264	C
10265	C Z CONTAINS THE TRANSFORMED EIGENVECTORS
10266	C IN ITS FIRST M COLUMNS.
10267	C
10268	C NOTE THAT TRBAK1 PRESERVES VECTOR EUCLIDEAN NORMS.
10269	C
10270	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
10271	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
10272	C
10273	C THIS VERSION DATED AUGUST 1983.
10274	C
10275	C ------------------------------------------------------------------
10276	C
10277	IF (M .EQ. 0) GO TO 200
10278	IF (N .EQ. 1) GO TO 200
10279	C
10280	DO 140 I = 2, N
10281	L = I - 1
10282	IF (E(I) .EQ. 0.0D0) GO TO 140
10283	C
10284	DO 130 J = 1, M
10285	S = 0.0D0
10286	C
10287	DO 110 K = 1, L
10288	110 S = S + A(I,K) * Z(K,J)
10289	C .......... DIVISOR BELOW IS NEGATIVE OF H FORMED IN TRED1.
10290	C DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ..........
10291	S = (S / A(I,L)) / E(I)
10292	C
10293	DO 120 K = 1, L
10294	120 Z(K,J) = Z(K,J) + S * A(I,K)
10295	C
10296	130 CONTINUE
10297	C
10298	140 CONTINUE
10299	C
10300	200 RETURN
10301	END
10302	SUBROUTINE TRBAK3(NM,N,NV,A,M,Z)
10303	C
10304	INTEGER I,J,K,L,M,N,IK,IZ,NM,NV
10305	DOUBLE PRECISION A(NV),Z(NM,M)
10306	DOUBLE PRECISION H,S
10307	C
10308	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK3,
10309	C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
10310	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
10311	C
10312	C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC
10313	C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
10314	C SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY TRED3.
10315	C
10316	C ON INPUT
10317	C
10318	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
10319	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
10320	C DIMENSION STATEMENT.
10321	C
10322	C N IS THE ORDER OF THE MATRIX.
10323	C
10324	C NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A
10325	C AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT.
10326	C
10327	C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANSFORMATIONS
10328	C USED IN THE REDUCTION BY TRED3 IN ITS FIRST
10329	C N*(N+1)/2 POSITIONS.
10330	C
10331	C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
10332	C
10333	C Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED
10334	C IN ITS FIRST M COLUMNS.
10335	C
10336	C ON OUTPUT
10337	C
10338	C Z CONTAINS THE TRANSFORMED EIGENVECTORS
10339	C IN ITS FIRST M COLUMNS.
10340	C
10341	C NOTE THAT TRBAK3 PRESERVES VECTOR EUCLIDEAN NORMS.
10342	C
10343	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
10344	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
10345	C
10346	C THIS VERSION DATED AUGUST 1983.
10347	C
10348	C ------------------------------------------------------------------
10349	C
10350	IF (M .EQ. 0) GO TO 200
10351	IF (N .EQ. 1) GO TO 200
10352	C
10353	DO 140 I = 2, N
10354	L = I - 1
10355	IZ = (I * L) / 2
10356	IK = IZ + I
10357	H = A(IK)
10358	IF (H .EQ. 0.0D0) GO TO 140
10359	C
10360	DO 130 J = 1, M
10361	S = 0.0D0
10362	IK = IZ
10363	C
10364	DO 110 K = 1, L
10365	IK = IK + 1
10366	S = S + A(IK) * Z(K,J)
10367	110 CONTINUE
10368	C .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ..........
10369	S = (S / H) / H
10370	IK = IZ
10371	C
10372	DO 120 K = 1, L
10373	IK = IK + 1
10374	Z(K,J) = Z(K,J) - S * A(IK)
10375	120 CONTINUE
10376	C
10377	130 CONTINUE
10378	C
10379	140 CONTINUE
10380	C
10381	200 RETURN
10382	END
10383	SUBROUTINE TRED1(NM,N,A,D,E,E2)
10384	C
10385	INTEGER I,J,K,L,N,II,NM,JP1
10386	DOUBLE PRECISION A(NM,N),D(N),E(N),E2(N)
10387	DOUBLE PRECISION F,G,H,SCALE
10388	C
10389	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED1,
10390	C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
10391	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
10392	C
10393	C THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX
10394	C TO A SYMMETRIC TRIDIAGONAL MATRIX USING
10395	C ORTHOGONAL SIMILARITY TRANSFORMATIONS.
10396	C
10397	C ON INPUT
10398	C
10399	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
10400	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
10401	C DIMENSION STATEMENT.
10402	C
10403	C N IS THE ORDER OF THE MATRIX.
10404	C
10405	C A CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE
10406	C LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED.
10407	C
10408	C ON OUTPUT
10409	C
10410	C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS-
10411	C FORMATIONS USED IN THE REDUCTION IN ITS STRICT LOWER
10412	C TRIANGLE. THE FULL UPPER TRIANGLE OF A IS UNALTERED.
10413	C
10414	C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX.
10415	C
10416	C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
10417	C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO.
10418	C
10419	C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
10420	C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
10421	C
10422	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
10423	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
10424	C
10425	C THIS VERSION DATED AUGUST 1983.
10426	C
10427	C ------------------------------------------------------------------
10428	C
10429	DO 100 I = 1, N
10430	D(I) = A(N,I)
10431	A(N,I) = A(I,I)
10432	100 CONTINUE
10433	C .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
10434	DO 300 II = 1, N
10435	I = N + 1 - II
10436	L = I - 1
10437	H = 0.0D0
10438	SCALE = 0.0D0
10439	IF (L .LT. 1) GO TO 130
10440	C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) ..........
10441	DO 120 K = 1, L
10442	120 SCALE = SCALE + DABS(D(K))
10443	C
10444	IF (SCALE .NE. 0.0D0) GO TO 140
10445	C
10446	DO 125 J = 1, L
10447	D(J) = A(L,J)
10448	A(L,J) = A(I,J)
10449	A(I,J) = 0.0D0
10450	125 CONTINUE
10451	C
10452	130 E(I) = 0.0D0
10453	E2(I) = 0.0D0
10454	GO TO 300
10455	C
10456	140 DO 150 K = 1, L
10457	D(K) = D(K) / SCALE
10458	H = H + D(K) * D(K)
10459	150 CONTINUE
10460	C
10461	E2(I) = SCALE * SCALE * H
10462	F = D(L)
10463	G = -DSIGN(DSQRT(H),F)
10464	E(I) = SCALE * G
10465	H = H - F * G
10466	D(L) = F - G
10467	IF (L .EQ. 1) GO TO 285
10468	C .......... FORM A*U ..........
10469	DO 170 J = 1, L
10470	170 E(J) = 0.0D0
10471	C
10472	DO 240 J = 1, L
10473	F = D(J)
10474	G = E(J) + A(J,J) * F
10475	JP1 = J + 1
10476	IF (L .LT. JP1) GO TO 220
10477	C
10478	DO 200 K = JP1, L
10479	G = G + A(K,J) * D(K)
10480	E(K) = E(K) + A(K,J) * F
10481	200 CONTINUE
10482	C
10483	220 E(J) = G
10484	240 CONTINUE
10485	C .......... FORM P ..........
10486	F = 0.0D0
10487	C
10488	DO 245 J = 1, L
10489	E(J) = E(J) / H
10490	F = F + E(J) * D(J)
10491	245 CONTINUE
10492	C
10493	H = F / (H + H)
10494	C .......... FORM Q ..........
10495	DO 250 J = 1, L
10496	250 E(J) = E(J) - H * D(J)
10497	C .......... FORM REDUCED A ..........
10498	DO 280 J = 1, L
10499	F = D(J)
10500	G = E(J)
10501	C
10502	DO 260 K = J, L
10503	260 A(K,J) = A(K,J) - F * E(K) - G * D(K)
10504	C
10505	280 CONTINUE
10506	C
10507	285 DO 290 J = 1, L
10508	F = D(J)
10509	D(J) = A(L,J)
10510	A(L,J) = A(I,J)
10511	A(I,J) = F * SCALE
10512	290 CONTINUE
10513	C
10514	300 CONTINUE
10515	C
10516	RETURN
10517	END
10518	SUBROUTINE TRED2(NM,N,A,D,E,Z)
10519	C
10520	INTEGER I,J,K,L,N,II,NM,JP1
10521	DOUBLE PRECISION A(NM,N),D(N),E(N),Z(NM,N)
10522	DOUBLE PRECISION F,G,H,HH,SCALE
10523	C
10524	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED2,
10525	C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
10526	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
10527	C
10528	C THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX TO A
10529	C SYMMETRIC TRIDIAGONAL MATRIX USING AND ACCUMULATING
10530	C ORTHOGONAL SIMILARITY TRANSFORMATIONS.
10531	C
10532	C ON INPUT
10533	C
10534	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
10535	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
10536	C DIMENSION STATEMENT.
10537	C
10538	C N IS THE ORDER OF THE MATRIX.
10539	C
10540	C A CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE
10541	C LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED.
10542	C
10543	C ON OUTPUT
10544	C
10545	C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX.
10546	C
10547	C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
10548	C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO.
10549	C
10550	C Z CONTAINS THE ORTHOGONAL TRANSFORMATION MATRIX
10551	C PRODUCED IN THE REDUCTION.
10552	C
10553	C A AND Z MAY COINCIDE. IF DISTINCT, A IS UNALTERED.
10554	C
10555	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
10556	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
10557	C
10558	C THIS VERSION DATED AUGUST 1983.
10559	C
10560	C ------------------------------------------------------------------
10561	C
10562	DO 100 I = 1, N
10563	C
10564	DO 80 J = I, N
10565	80 Z(J,I) = A(J,I)
10566	C
10567	D(I) = A(N,I)
10568	100 CONTINUE
10569	C
10570	IF (N .EQ. 1) GO TO 510
10571	C .......... FOR I=N STEP -1 UNTIL 2 DO -- ..........
10572	DO 300 II = 2, N
10573	I = N + 2 - II
10574	L = I - 1
10575	H = 0.0D0
10576	SCALE = 0.0D0
10577	IF (L .LT. 2) GO TO 130
10578	C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) ..........
10579	DO 120 K = 1, L
10580	120 SCALE = SCALE + DABS(D(K))
10581	C
10582	IF (SCALE .NE. 0.0D0) GO TO 140
10583	130 E(I) = D(L)
10584	C
10585	DO 135 J = 1, L
10586	D(J) = Z(L,J)
10587	Z(I,J) = 0.0D0
10588	Z(J,I) = 0.0D0
10589	135 CONTINUE
10590	C
10591	GO TO 290
10592	C
10593	140 DO 150 K = 1, L
10594	D(K) = D(K) / SCALE
10595	H = H + D(K) * D(K)
10596	150 CONTINUE
10597	C
10598	F = D(L)
10599	G = -DSIGN(DSQRT(H),F)
10600	E(I) = SCALE * G
10601	H = H - F * G
10602	D(L) = F - G
10603	C .......... FORM A*U ..........
10604	DO 170 J = 1, L
10605	170 E(J) = 0.0D0
10606	C
10607	DO 240 J = 1, L
10608	F = D(J)
10609	Z(J,I) = F
10610	G = E(J) + Z(J,J) * F
10611	JP1 = J + 1
10612	IF (L .LT. JP1) GO TO 220
10613	C
10614	DO 200 K = JP1, L
10615	G = G + Z(K,J) * D(K)
10616	E(K) = E(K) + Z(K,J) * F
10617	200 CONTINUE
10618	C
10619	220 E(J) = G
10620	240 CONTINUE
10621	C .......... FORM P ..........
10622	F = 0.0D0
10623	C
10624	DO 245 J = 1, L
10625	E(J) = E(J) / H
10626	F = F + E(J) * D(J)
10627	245 CONTINUE
10628	C
10629	HH = F / (H + H)
10630	C .......... FORM Q ..........
10631	DO 250 J = 1, L
10632	250 E(J) = E(J) - HH * D(J)
10633	C .......... FORM REDUCED A ..........
10634	DO 280 J = 1, L
10635	F = D(J)
10636	G = E(J)
10637	C
10638	DO 260 K = J, L
10639	260 Z(K,J) = Z(K,J) - F * E(K) - G * D(K)
10640	C
10641	D(J) = Z(L,J)
10642	Z(I,J) = 0.0D0
10643	280 CONTINUE
10644	C
10645	290 D(I) = H
10646	300 CONTINUE
10647	C .......... ACCUMULATION OF TRANSFORMATION MATRICES ..........
10648	DO 500 I = 2, N
10649	L = I - 1
10650	Z(N,L) = Z(L,L)
10651	Z(L,L) = 1.0D0
10652	H = D(I)
10653	IF (H .EQ. 0.0D0) GO TO 380
10654	C
10655	DO 330 K = 1, L
10656	330 D(K) = Z(K,I) / H
10657	C
10658	DO 360 J = 1, L
10659	G = 0.0D0
10660	C
10661	DO 340 K = 1, L
10662	340 G = G + Z(K,I) * Z(K,J)
10663	C
10664	DO 360 K = 1, L
10665	Z(K,J) = Z(K,J) - G * D(K)
10666	360 CONTINUE
10667	C
10668	380 DO 400 K = 1, L
10669	400 Z(K,I) = 0.0D0
10670	C
10671	500 CONTINUE
10672	C
10673	510 DO 520 I = 1, N
10674	D(I) = Z(N,I)
10675	Z(N,I) = 0.0D0
10676	520 CONTINUE
10677	C
10678	Z(N,N) = 1.0D0
10679	E(1) = 0.0D0
10680	RETURN
10681	END
10682	SUBROUTINE TRED3(N,NV,A,D,E,E2)
10683	C
10684	INTEGER I,J,K,L,N,II,IZ,JK,NV,JM1
10685	DOUBLE PRECISION A(NV),D(N),E(N),E2(N)
10686	DOUBLE PRECISION F,G,H,HH,SCALE
10687	C
10688	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED3,
10689	C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
10690	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
10691	C
10692	C THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX, STORED AS
10693	C A ONE-DIMENSIONAL ARRAY, TO A SYMMETRIC TRIDIAGONAL MATRIX
10694	C USING ORTHOGONAL SIMILARITY TRANSFORMATIONS.
10695	C
10696	C ON INPUT
10697	C
10698	C N IS THE ORDER OF THE MATRIX.
10699	C
10700	C NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A
10701	C AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT.
10702	C
10703	C A CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC
10704	C INPUT MATRIX, STORED ROW-WISE AS A ONE-DIMENSIONAL
10705	C ARRAY, IN ITS FIRST N*(N+1)/2 POSITIONS.
10706	C
10707	C ON OUTPUT
10708	C
10709	C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL
10710	C TRANSFORMATIONS USED IN THE REDUCTION.
10711	C
10712	C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX.
10713	C
10714	C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
10715	C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO.
10716	C
10717	C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
10718	C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
10719	C
10720	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
10721	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
10722	C
10723	C THIS VERSION DATED AUGUST 1983.
10724	C
10725	C ------------------------------------------------------------------
10726	C
10727	C .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
10728	DO 300 II = 1, N
10729	I = N + 1 - II
10730	L = I - 1
10731	IZ = (I * L) / 2
10732	H = 0.0D0
10733	SCALE = 0.0D0
10734	IF (L .LT. 1) GO TO 130
10735	C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) ..........
10736	DO 120 K = 1, L
10737	IZ = IZ + 1
10738	D(K) = A(IZ)
10739	SCALE = SCALE + DABS(D(K))
10740	120 CONTINUE
10741	C
10742	IF (SCALE .NE. 0.0D0) GO TO 140
10743	130 E(I) = 0.0D0
10744	E2(I) = 0.0D0
10745	GO TO 290
10746	C
10747	140 DO 150 K = 1, L
10748	D(K) = D(K) / SCALE
10749	H = H + D(K) * D(K)
10750	150 CONTINUE
10751	C
10752	E2(I) = SCALE * SCALE * H
10753	F = D(L)
10754	G = -DSIGN(DSQRT(H),F)
10755	E(I) = SCALE * G
10756	H = H - F * G
10757	D(L) = F - G
10758	A(IZ) = SCALE * D(L)
10759	IF (L .EQ. 1) GO TO 290
10760	JK = 1
10761	C
10762	DO 240 J = 1, L
10763	F = D(J)
10764	G = 0.0D0
10765	JM1 = J - 1
10766	IF (JM1 .LT. 1) GO TO 220
10767	C
10768	DO 200 K = 1, JM1
10769	G = G + A(JK) * D(K)
10770	E(K) = E(K) + A(JK) * F
10771	JK = JK + 1
10772	200 CONTINUE
10773	C
10774	220 E(J) = G + A(JK) * F
10775	JK = JK + 1
10776	240 CONTINUE
10777	C .......... FORM P ..........
10778	F = 0.0D0
10779	C
10780	DO 245 J = 1, L
10781	E(J) = E(J) / H
10782	F = F + E(J) * D(J)
10783	245 CONTINUE
10784	C
10785	HH = F / (H + H)
10786	C .......... FORM Q ..........
10787	DO 250 J = 1, L
10788	250 E(J) = E(J) - HH * D(J)
10789	C
10790	JK = 1
10791	C .......... FORM REDUCED A ..........
10792	DO 280 J = 1, L
10793	F = D(J)
10794	G = E(J)
10795	C
10796	DO 260 K = 1, J
10797	A(JK) = A(JK) - F * E(K) - G * D(K)
10798	JK = JK + 1
10799	260 CONTINUE
10800	C
10801	280 CONTINUE
10802	C
10803	290 D(I) = A(IZ+1)
10804	A(IZ+1) = SCALE * DSQRT(H)
10805	300 CONTINUE
10806	C
10807	RETURN
10808	END
10809	SUBROUTINE TRIDIB(N,EPS1,D,E,E2,LB,UB,M11,M,W,IND,IERR,RV4,RV5)
10810	C
10811	INTEGER I,J,K,L,M,N,P,Q,R,S,II,M1,M2,M11,M22,TAG,IERR,ISTURM
10812	DOUBLE PRECISION D(N),E(N),E2(N),W(M),RV4(N),RV5(N)
10813	DOUBLE PRECISION U,V,LB,T1,T2,UB,XU,X0,X1,EPS1,TST1,TST2,EPSLON
10814	INTEGER IND(M)
10815	C
10816	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BISECT,
10817	C NUM. MATH. 9, 386-393(1967) BY BARTH, MARTIN, AND WILKINSON.
10818	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 249-256(1971).
10819	C
10820	C THIS SUBROUTINE FINDS THOSE EIGENVALUES OF A TRIDIAGONAL
10821	C SYMMETRIC MATRIX BETWEEN SPECIFIED BOUNDARY INDICES,
10822	C USING BISECTION.
10823	C
10824	C ON INPUT
10825	C
10826	C N IS THE ORDER OF THE MATRIX.
10827	C
10828	C EPS1 IS AN ABSOLUTE ERROR TOLERANCE FOR THE COMPUTED
10829	C EIGENVALUES. IF THE INPUT EPS1 IS NON-POSITIVE,
10830	C IT IS RESET FOR EACH SUBMATRIX TO A DEFAULT VALUE,
10831	C NAMELY, MINUS THE PRODUCT OF THE RELATIVE MACHINE
10832	C PRECISION AND THE 1-NORM OF THE SUBMATRIX.
10833	C
10834	C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
10835	C
10836	C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
10837	C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY.
10838	C
10839	C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
10840	C E2(1) IS ARBITRARY.
10841	C
10842	C M11 SPECIFIES THE LOWER BOUNDARY INDEX FOR THE DESIRED
10843	C EIGENVALUES.
10844	C
10845	C M SPECIFIES THE NUMBER OF EIGENVALUES DESIRED. THE UPPER
10846	C BOUNDARY INDEX M22 IS THEN OBTAINED AS M22=M11+M-1.
10847	C
10848	C ON OUTPUT
10849	C
10850	C EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS
10851	C (LAST) DEFAULT VALUE.
10852	C
10853	C D AND E ARE UNALTERED.
10854	C
10855	C ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED
10856	C AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE
10857	C MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES.
10858	C E2(1) IS ALSO SET TO ZERO.
10859	C
10860	C LB AND UB DEFINE AN INTERVAL CONTAINING EXACTLY THE DESIRED
10861	C EIGENVALUES.
10862	C
10863	C W CONTAINS, IN ITS FIRST M POSITIONS, THE EIGENVALUES
10864	C BETWEEN INDICES M11 AND M22 IN ASCENDING ORDER.
10865	C
10866	C IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES
10867	C ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W --
10868	C 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM
10869	C THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC..
10870	C
10871	C IERR IS SET TO
10872	C ZERO FOR NORMAL RETURN,
10873	C 3*N+1 IF MULTIPLE EIGENVALUES AT INDEX M11 MAKE
10874	C UNIQUE SELECTION IMPOSSIBLE,
10875	C 3*N+2 IF MULTIPLE EIGENVALUES AT INDEX M22 MAKE
10876	C UNIQUE SELECTION IMPOSSIBLE.
10877	C
10878	C RV4 AND RV5 ARE TEMPORARY STORAGE ARRAYS.
10879	C
10880	C NOTE THAT SUBROUTINE TQL1, IMTQL1, OR TQLRAT IS GENERALLY FASTER
10881	C THAN TRIDIB, IF MORE THAN N/4 EIGENVALUES ARE TO BE FOUND.
10882	C
10883	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
10884	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
10885	C
10886	C THIS VERSION DATED AUGUST 1983.
10887	C
10888	C ------------------------------------------------------------------
10889	C
10890	IERR = 0
10891	TAG = 0
10892	XU = D(1)
10893	X0 = D(1)
10894	U = 0.0D0
10895	C .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES AND DETERMINE AN
10896	C INTERVAL CONTAINING ALL THE EIGENVALUES ..........
10897	DO 40 I = 1, N
10898	X1 = U
10899	U = 0.0D0
10900	IF (I .NE. N) U = DABS(E(I+1))
10901	XU = DMIN1(D(I)-(X1+U),XU)
10902	X0 = DMAX1(D(I)+(X1+U),X0)
10903	IF (I .EQ. 1) GO TO 20
10904	TST1 = DABS(D(I)) + DABS(D(I-1))
10905	TST2 = TST1 + DABS(E(I))
10906	IF (TST2 .GT. TST1) GO TO 40
10907	20 E2(I) = 0.0D0
10908	40 CONTINUE
10909	C
10910	X1 = N
10911	X1 = X1 * EPSLON(DMAX1(DABS(XU),DABS(X0)))
10912	XU = XU - X1
10913	T1 = XU
10914	X0 = X0 + X1
10915	T2 = X0
10916	C .......... DETERMINE AN INTERVAL CONTAINING EXACTLY
10917	C THE DESIRED EIGENVALUES ..........
10918	P = 1
10919	Q = N
10920	M1 = M11 - 1
10921	IF (M1 .EQ. 0) GO TO 75
10922	ISTURM = 1
10923	50 V = X1
10924	X1 = XU + (X0 - XU) * 0.5D0
10925	IF (X1 .EQ. V) GO TO 980
10926	GO TO 320
10927	60 IF (S - M1) 65, 73, 70
10928	65 XU = X1
10929	GO TO 50
10930	70 X0 = X1
10931	GO TO 50
10932	73 XU = X1
10933	T1 = X1
10934	75 M22 = M1 + M
10935	IF (M22 .EQ. N) GO TO 90
10936	X0 = T2
10937	ISTURM = 2
10938	GO TO 50
10939	80 IF (S - M22) 65, 85, 70
10940	85 T2 = X1
10941	90 Q = 0
10942	R = 0
10943	C .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING
10944	C INTERVAL BY THE GERSCHGORIN BOUNDS ..........
10945	100 IF (R .EQ. M) GO TO 1001
10946	TAG = TAG + 1
10947	P = Q + 1
10948	XU = D(P)
10949	X0 = D(P)
10950	U = 0.0D0
10951	C
10952	DO 120 Q = P, N
10953	X1 = U
10954	U = 0.0D0
10955	V = 0.0D0
10956	IF (Q .EQ. N) GO TO 110
10957	U = DABS(E(Q+1))
10958	V = E2(Q+1)
10959	110 XU = DMIN1(D(Q)-(X1+U),XU)
10960	X0 = DMAX1(D(Q)+(X1+U),X0)
10961	IF (V .EQ. 0.0D0) GO TO 140
10962	120 CONTINUE
10963	C
10964	140 X1 = EPSLON(DMAX1(DABS(XU),DABS(X0)))
10965	IF (EPS1 .LE. 0.0D0) EPS1 = -X1
10966	IF (P .NE. Q) GO TO 180
10967	C .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL ..........
10968	IF (T1 .GT. D(P) .OR. D(P) .GE. T2) GO TO 940
10969	M1 = P
10970	M2 = P
10971	RV5(P) = D(P)
10972	GO TO 900
10973	180 X1 = X1 * (Q - P + 1)
10974	LB = DMAX1(T1,XU-X1)
10975	UB = DMIN1(T2,X0+X1)
10976	X1 = LB
10977	ISTURM = 3
10978	GO TO 320
10979	200 M1 = S + 1
10980	X1 = UB
10981	ISTURM = 4
10982	GO TO 320
10983	220 M2 = S
10984	IF (M1 .GT. M2) GO TO 940
10985	C .......... FIND ROOTS BY BISECTION ..........
10986	X0 = UB
10987	ISTURM = 5
10988	C
10989	DO 240 I = M1, M2
10990	RV5(I) = UB
10991	RV4(I) = LB
10992	240 CONTINUE
10993	C .......... LOOP FOR K-TH EIGENVALUE
10994	C FOR K=M2 STEP -1 UNTIL M1 DO --
10995	C (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) ..........
10996	K = M2
10997	250 XU = LB
10998	C .......... FOR I=K STEP -1 UNTIL M1 DO -- ..........
10999	DO 260 II = M1, K
11000	I = M1 + K - II
11001	IF (XU .GE. RV4(I)) GO TO 260
11002	XU = RV4(I)
11003	GO TO 280
11004	260 CONTINUE
11005	C
11006	280 IF (X0 .GT. RV5(K)) X0 = RV5(K)
11007	C .......... NEXT BISECTION STEP ..........
11008	300 X1 = (XU + X0) * 0.5D0
11009	IF ((X0 - XU) .LE. DABS(EPS1)) GO TO 420
11010	TST1 = 2.0D0 * (DABS(XU) + DABS(X0))
11011	TST2 = TST1 + (X0 - XU)
11012	IF (TST2 .EQ. TST1) GO TO 420
11013	C .......... IN-LINE PROCEDURE FOR STURM SEQUENCE ..........
11014	320 S = P - 1
11015	U = 1.0D0
11016	C
11017	DO 340 I = P, Q
11018	IF (U .NE. 0.0D0) GO TO 325
11019	V = DABS(E(I)) / EPSLON(1.0D0)
11020	IF (E2(I) .EQ. 0.0D0) V = 0.0D0
11021	GO TO 330
11022	325 V = E2(I) / U
11023	330 U = D(I) - X1 - V
11024	IF (U .LT. 0.0D0) S = S + 1
11025	340 CONTINUE
11026	C
11027	GO TO (60,80,200,220,360), ISTURM
11028	C .......... REFINE INTERVALS ..........
11029	360 IF (S .GE. K) GO TO 400
11030	XU = X1
11031	IF (S .GE. M1) GO TO 380
11032	RV4(M1) = X1
11033	GO TO 300
11034	380 RV4(S+1) = X1
11035	IF (RV5(S) .GT. X1) RV5(S) = X1
11036	GO TO 300
11037	400 X0 = X1
11038	GO TO 300
11039	C .......... K-TH EIGENVALUE FOUND ..........
11040	420 RV5(K) = X1
11041	K = K - 1
11042	IF (K .GE. M1) GO TO 250
11043	C .......... ORDER EIGENVALUES TAGGED WITH THEIR
11044	C SUBMATRIX ASSOCIATIONS ..........
11045	900 S = R
11046	R = R + M2 - M1 + 1
11047	J = 1
11048	K = M1
11049	C
11050	DO 920 L = 1, R
11051	IF (J .GT. S) GO TO 910
11052	IF (K .GT. M2) GO TO 940
11053	IF (RV5(K) .GE. W(L)) GO TO 915
11054	C
11055	DO 905 II = J, S
11056	I = L + S - II
11057	W(I+1) = W(I)
11058	IND(I+1) = IND(I)
11059	905 CONTINUE
11060	C
11061	910 W(L) = RV5(K)
11062	IND(L) = TAG
11063	K = K + 1
11064	GO TO 920
11065	915 J = J + 1
11066	920 CONTINUE
11067	C
11068	940 IF (Q .LT. N) GO TO 100
11069	GO TO 1001
11070	C .......... SET ERROR -- INTERVAL CANNOT BE FOUND CONTAINING
11071	C EXACTLY THE DESIRED EIGENVALUES ..........
11072	980 IERR = 3 * N + ISTURM
11073	1001 LB = T1
11074	UB = T2
11075	RETURN
11076	END
11077	SUBROUTINE TSTURM(NM,N,EPS1,D,E,E2,LB,UB,MM,M,W,Z,
11078	X IERR,RV1,RV2,RV3,RV4,RV5,RV6)
11079	C
11080	INTEGER I,J,K,M,N,P,Q,R,S,II,IP,JJ,MM,M1,M2,NM,ITS,
11081	X IERR,GROUP,ISTURM
11082	DOUBLE PRECISION D(N),E(N),E2(N),W(MM),Z(NM,MM),
11083	X RV1(N),RV2(N),RV3(N),RV4(N),RV5(N),RV6(N)
11084	DOUBLE PRECISION U,V,LB,T1,T2,UB,UK,XU,X0,X1,EPS1,EPS2,EPS3,EPS4,
11085	X NORM,TST1,TST2,EPSLON,PYTHAG
11086	C
11087	C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRISTURM
11088	C BY PETERS AND WILKINSON.
11089	C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971).
11090	C
11091	C THIS SUBROUTINE FINDS THOSE EIGENVALUES OF A TRIDIAGONAL
11092	C SYMMETRIC MATRIX WHICH LIE IN A SPECIFIED INTERVAL AND THEIR
11093	C ASSOCIATED EIGENVECTORS, USING BISECTION AND INVERSE ITERATION.
11094	C
11095	C ON INPUT
11096	C
11097	C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
11098	C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
11099	C DIMENSION STATEMENT.
11100	C
11101	C N IS THE ORDER OF THE MATRIX.
11102	C
11103	C EPS1 IS AN ABSOLUTE ERROR TOLERANCE FOR THE COMPUTED
11104	C EIGENVALUES. IT SHOULD BE CHOSEN COMMENSURATE WITH
11105	C RELATIVE PERTURBATIONS IN THE MATRIX ELEMENTS OF THE
11106	C ORDER OF THE RELATIVE MACHINE PRECISION. IF THE
11107	C INPUT EPS1 IS NON-POSITIVE, IT IS RESET FOR EACH
11108	C SUBMATRIX TO A DEFAULT VALUE, NAMELY, MINUS THE
11109	C PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE
11110	C 1-NORM OF THE SUBMATRIX.
11111	C
11112	C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
11113	C
11114	C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
11115	C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY.
11116	C
11117	C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
11118	C E2(1) IS ARBITRARY.
11119	C
11120	C LB AND UB DEFINE THE INTERVAL TO BE SEARCHED FOR EIGENVALUES.
11121	C IF LB IS NOT LESS THAN UB, NO EIGENVALUES WILL BE FOUND.
11122	C
11123	C MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF
11124	C EIGENVALUES IN THE INTERVAL. WARNING. IF MORE THAN
11125	C MM EIGENVALUES ARE DETERMINED TO LIE IN THE INTERVAL,
11126	C AN ERROR RETURN IS MADE WITH NO VALUES OR VECTORS FOUND.
11127	C
11128	C ON OUTPUT
11129	C
11130	C EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS
11131	C (LAST) DEFAULT VALUE.
11132	C
11133	C D AND E ARE UNALTERED.
11134	C
11135	C ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED
11136	C AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE
11137	C MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES.
11138	C E2(1) IS ALSO SET TO ZERO.
11139	C
11140	C M IS THE NUMBER OF EIGENVALUES DETERMINED TO LIE IN (LB,UB).
11141	C
11142	C W CONTAINS THE M EIGENVALUES IN ASCENDING ORDER IF THE MATRIX
11143	C DOES NOT SPLIT. IF THE MATRIX SPLITS, THE EIGENVALUES ARE
11144	C IN ASCENDING ORDER FOR EACH SUBMATRIX. IF A VECTOR ERROR
11145	C EXIT IS MADE, W CONTAINS THOSE VALUES ALREADY FOUND.
11146	C
11147	C Z CONTAINS THE ASSOCIATED SET OF ORTHONORMAL EIGENVECTORS.
11148	C IF AN ERROR EXIT IS MADE, Z CONTAINS THOSE VECTORS
11149	C ALREADY FOUND.
11150	C
11151	C IERR IS SET TO
11152	C ZERO FOR NORMAL RETURN,
11153	C 3*N+1 IF M EXCEEDS MM.
11154	C 4*N+R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH
11155	C EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS.
11156	C
11157	C RV1, RV2, RV3, RV4, RV5, AND RV6 ARE TEMPORARY STORAGE ARRAYS.
11158	C
11159	C THE ALGOL PROCEDURE STURMCNT CONTAINED IN TRISTURM
11160	C APPEARS IN TSTURM IN-LINE.
11161	C
11162	C CALLS PYTHAG FOR DSQRT(AA + BB) .
11163	C
11164	C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
11165	C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
11166	C
11167	C THIS VERSION DATED AUGUST 1983.
11168	C
11169	C ------------------------------------------------------------------
11170	C
11171	IERR = 0
11172	T1 = LB
11173	T2 = UB
11174	C .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES ..........
11175	DO 40 I = 1, N
11176	IF (I .EQ. 1) GO TO 20
11177	TST1 = DABS(D(I)) + DABS(D(I-1))
11178	TST2 = TST1 + DABS(E(I))
11179	IF (TST2 .GT. TST1) GO TO 40
11180	20 E2(I) = 0.0D0
11181	40 CONTINUE
11182	C .......... DETERMINE THE NUMBER OF EIGENVALUES
11183	C IN THE INTERVAL ..........
11184	P = 1
11185	Q = N
11186	X1 = UB
11187	ISTURM = 1
11188	GO TO 320
11189	60 M = S
11190	X1 = LB
11191	ISTURM = 2
11192	GO TO 320
11193	80 M = M - S
11194	IF (M .GT. MM) GO TO 980
11195	Q = 0
11196	R = 0
11197	C .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING
11198	C INTERVAL BY THE GERSCHGORIN BOUNDS ..........
11199	100 IF (R .EQ. M) GO TO 1001
11200	P = Q + 1
11201	XU = D(P)
11202	X0 = D(P)
11203	U = 0.0D0
11204	C
11205	DO 120 Q = P, N
11206	X1 = U
11207	U = 0.0D0
11208	V = 0.0D0
11209	IF (Q .EQ. N) GO TO 110
11210	U = DABS(E(Q+1))
11211	V = E2(Q+1)
11212	110 XU = DMIN1(D(Q)-(X1+U),XU)
11213	X0 = DMAX1(D(Q)+(X1+U),X0)
11214	IF (V .EQ. 0.0D0) GO TO 140
11215	120 CONTINUE
11216	C
11217	140 X1 = EPSLON(DMAX1(DABS(XU),DABS(X0)))
11218	IF (EPS1 .LE. 0.0D0) EPS1 = -X1
11219	IF (P .NE. Q) GO TO 180
11220	C .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL ..........
11221	IF (T1 .GT. D(P) .OR. D(P) .GE. T2) GO TO 940
11222	R = R + 1
11223	C
11224	DO 160 I = 1, N
11225	160 Z(I,R) = 0.0D0
11226	C
11227	W(R) = D(P)
11228	Z(P,R) = 1.0D0
11229	GO TO 940
11230	180 U = Q-P+1
11231	X1 = U * X1
11232	LB = DMAX1(T1,XU-X1)
11233	UB = DMIN1(T2,X0+X1)
11234	X1 = LB
11235	ISTURM = 3
11236	GO TO 320
11237	200 M1 = S + 1
11238	X1 = UB
11239	ISTURM = 4
11240	GO TO 320
11241	220 M2 = S
11242	IF (M1 .GT. M2) GO TO 940
11243	C .......... FIND ROOTS BY BISECTION ..........
11244	X0 = UB
11245	ISTURM = 5
11246	C
11247	DO 240 I = M1, M2
11248	RV5(I) = UB
11249	RV4(I) = LB
11250	240 CONTINUE
11251	C .......... LOOP FOR K-TH EIGENVALUE
11252	C FOR K=M2 STEP -1 UNTIL M1 DO --
11253	C (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) ..........
11254	K = M2
11255	250 XU = LB
11256	C .......... FOR I=K STEP -1 UNTIL M1 DO -- ..........
11257	DO 260 II = M1, K
11258	I = M1 + K - II
11259	IF (XU .GE. RV4(I)) GO TO 260
11260	XU = RV4(I)
11261	GO TO 280
11262	260 CONTINUE
11263	C
11264	280 IF (X0 .GT. RV5(K)) X0 = RV5(K)
11265	C .......... NEXT BISECTION STEP ..........
11266	300 X1 = (XU + X0) * 0.5D0
11267	IF ((X0 - XU) .LE. DABS(EPS1)) GO TO 420
11268	TST1 = 2.0D0 * (DABS(XU) + DABS(X0))
11269	TST2 = TST1 + (X0 - XU)
11270	IF (TST2 .EQ. TST1) GO TO 420
11271	C .......... IN-LINE PROCEDURE FOR STURM SEQUENCE ..........
11272	320 S = P - 1
11273	U = 1.0D0
11274	C
11275	DO 340 I = P, Q
11276	IF (U .NE. 0.0D0) GO TO 325
11277	V = DABS(E(I)) / EPSLON(1.0D0)
11278	IF (E2(I) .EQ. 0.0D0) V = 0.0D0
11279	GO TO 330
11280	325 V = E2(I) / U
11281	330 U = D(I) - X1 - V
11282	IF (U .LT. 0.0D0) S = S + 1
11283	340 CONTINUE
11284	C
11285	GO TO (60,80,200,220,360), ISTURM
11286	C .......... REFINE INTERVALS ..........
11287	360 IF (S .GE. K) GO TO 400
11288	XU = X1
11289	IF (S .GE. M1) GO TO 380
11290	RV4(M1) = X1
11291	GO TO 300
11292	380 RV4(S+1) = X1
11293	IF (RV5(S) .GT. X1) RV5(S) = X1
11294	GO TO 300
11295	400 X0 = X1
11296	GO TO 300
11297	C .......... K-TH EIGENVALUE FOUND ..........
11298	420 RV5(K) = X1
11299	K = K - 1
11300	IF (K .GE. M1) GO TO 250
11301	C .......... FIND VECTORS BY INVERSE ITERATION ..........
11302	NORM = DABS(D(P))
11303	IP = P + 1
11304	C
11305	DO 500 I = IP, Q
11306	500 NORM = DMAX1(NORM, DABS(D(I)) + DABS(E(I)))
11307	C .......... EPS2 IS THE CRITERION FOR GROUPING,
11308	C EPS3 REPLACES ZERO PIVOTS AND EQUAL
11309	C ROOTS ARE MODIFIED BY EPS3,
11310	C EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW ..........
11311	EPS2 = 1.0D-3 * NORM
11312	EPS3 = EPSLON(NORM)
11313	UK = Q - P + 1
11314	EPS4 = UK * EPS3
11315	UK = EPS4 / DSQRT(UK)
11316	GROUP = 0
11317	S = P
11318	C
11319	DO 920 K = M1, M2
11320	R = R + 1
11321	ITS = 1
11322	W(R) = RV5(K)
11323	X1 = RV5(K)
11324	C .......... LOOK FOR CLOSE OR COINCIDENT ROOTS ..........
11325	IF (K .EQ. M1) GO TO 520
11326	IF (X1 - X0 .GE. EPS2) GROUP = -1
11327	GROUP = GROUP + 1
11328	IF (X1 .LE. X0) X1 = X0 + EPS3
11329	C .......... ELIMINATION WITH INTERCHANGES AND
11330	C INITIALIZATION OF VECTOR ..........
11331	520 V = 0.0D0
11332	C
11333	DO 580 I = P, Q
11334	RV6(I) = UK
11335	IF (I .EQ. P) GO TO 560
11336	IF (DABS(E(I)) .LT. DABS(U)) GO TO 540
11337	XU = U / E(I)
11338	RV4(I) = XU
11339	RV1(I-1) = E(I)
11340	RV2(I-1) = D(I) - X1
11341	RV3(I-1) = 0.0D0
11342	IF (I .NE. Q) RV3(I-1) = E(I+1)
11343	U = V - XU * RV2(I-1)
11344	V = -XU * RV3(I-1)
11345	GO TO 580
11346	540 XU = E(I) / U
11347	RV4(I) = XU
11348	RV1(I-1) = U
11349	RV2(I-1) = V
11350	RV3(I-1) = 0.0D0
11351	560 U = D(I) - X1 - XU * V
11352	IF (I .NE. Q) V = E(I+1)
11353	580 CONTINUE
11354	C
11355	IF (U .EQ. 0.0D0) U = EPS3
11356	RV1(Q) = U
11357	RV2(Q) = 0.0D0
11358	RV3(Q) = 0.0D0
11359	C .......... BACK SUBSTITUTION
11360	C FOR I=Q STEP -1 UNTIL P DO -- ..........
11361	600 DO 620 II = P, Q
11362	I = P + Q - II
11363	RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I)
11364	V = U
11365	U = RV6(I)
11366	620 CONTINUE
11367	C .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS
11368	C MEMBERS OF GROUP ..........
11369	IF (GROUP .EQ. 0) GO TO 700
11370	C
11371	DO 680 JJ = 1, GROUP
11372	J = R - GROUP - 1 + JJ
11373	XU = 0.0D0
11374	C
11375	DO 640 I = P, Q
11376	640 XU = XU + RV6(I) * Z(I,J)
11377	C
11378	DO 660 I = P, Q
11379	660 RV6(I) = RV6(I) - XU * Z(I,J)
11380	C
11381	680 CONTINUE
11382	C
11383	700 NORM = 0.0D0
11384	C
11385	DO 720 I = P, Q
11386	720 NORM = NORM + DABS(RV6(I))
11387	C
11388	IF (NORM .GE. 1.0D0) GO TO 840
11389	C .......... FORWARD SUBSTITUTION ..........
11390	IF (ITS .EQ. 5) GO TO 960
11391	IF (NORM .NE. 0.0D0) GO TO 740
11392	RV6(S) = EPS4
11393	S = S + 1
11394	IF (S .GT. Q) S = P
11395	GO TO 780
11396	740 XU = EPS4 / NORM
11397	C
11398	DO 760 I = P, Q
11399	760 RV6(I) = RV6(I) * XU
11400	C .......... ELIMINATION OPERATIONS ON NEXT VECTOR
11401	C ITERATE ..........
11402	780 DO 820 I = IP, Q
11403	U = RV6(I)
11404	C .......... IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE
11405	C WAS PERFORMED EARLIER IN THE
11406	C TRIANGULARIZATION PROCESS ..........
11407	IF (RV1(I-1) .NE. E(I)) GO TO 800
11408	U = RV6(I-1)
11409	RV6(I-1) = RV6(I)
11410	800 RV6(I) = U - RV4(I) * RV6(I-1)
11411	820 CONTINUE
11412	C
11413	ITS = ITS + 1
11414	GO TO 600
11415	C .......... NORMALIZE SO THAT SUM OF SQUARES IS
11416	C 1 AND EXPAND TO FULL ORDER ..........
11417	840 U = 0.0D0
11418	C
11419	DO 860 I = P, Q
11420	860 U = PYTHAG(U,RV6(I))
11421	C
11422	XU = 1.0D0 / U
11423	C
11424	DO 880 I = 1, N
11425	880 Z(I,R) = 0.0D0
11426	C
11427	DO 900 I = P, Q
11428	900 Z(I,R) = RV6(I) * XU
11429	C
11430	X0 = X1
11431	920 CONTINUE
11432	C
11433	940 IF (Q .LT. N) GO TO 100
11434	GO TO 1001
11435	C .......... SET ERROR -- NON-CONVERGED EIGENVECTOR ..........
11436	960 IERR = 4 * N + R
11437	GO TO 1001
11438	C .......... SET ERROR -- UNDERESTIMATE OF NUMBER OF
11439	C EIGENVALUES IN INTERVAL ..........
11440	980 IERR = 3 * N + 1
11441	1001 LB = T1
11442	UB = T2
11443	RETURN
11444	END

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: tags/arb-7.0.1/EISPACK/eispack.f

Download in other formats: