Context Navigation

source: branches/stable/EISPACK/eispack.cxx

Visit:

Last change on this file was 5390, checked in by westram, 18 years ago
TAB-Ex
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 481.8 KB

Line
1	/* eispack.f -- translated by f2c (version 19950110).
2	You must link the resulting object file with the libraries:
3	-lf2c -lm (in that order)
4	*/
5
6	#ifdef __cplusplus
7	extern "C" {
8	#endif
9	#include "f2c.h"
10
11	/* Table of constant values */
12
13	static doublereal c_b141 = 1.;
14	static doublereal c_b550 = 0.;
15
16	/* Subroutine / int cdiv_(doublereal ar, doublereal ai, doublereal br,
17	doublereal bi, doublereal cr, doublereal *ci)
18	{
19	/* System generated locals */
20	doublereal d_1, d_2;
21
22	/* Local variables */
23	static doublereal s, ais, bis, ars, brs;
24
25
26	/* COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI) */
27
28	s = abs(br) + abs(bi);
29	ars = *ar / s;
30	ais = *ai / s;
31	brs = *br / s;
32	bis = *bi / s;
33	/* Computing 2nd power */
34	d_1 = brs;
35	/* Computing 2nd power */
36	d_2 = bis;
37	s = d_1 * d_1 + d_2 * d_2;
38	cr = (ars brs + ais * bis) / s;
39	ci = (ais brs - ars * bis) / s;
40	return 0;
41	} /* cdiv_ */
42
43	/* Subroutine / int csroot_(doublereal xr, doublereal xi, doublereal yr,
44	doublereal *yi)
45	{
46	/* Builtin functions */
47	double sqrt(doublereal);
48
49	/* Local variables */
50	static doublereal s, ti, tr;
51	extern doublereal pythag_(doublereal , doublereal );
52
53
54	/* (YR,YI) = COMPLEX DSQRT(XR,XI) */
55	/* BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI) */
56
57	tr = *xr;
58	ti = *xi;
59	s = sqrt((pythag_(&tr, &ti) + abs(tr)) * .5);
60	if (tr >= 0.) {
61	*yr = s;
62	}
63	if (ti < 0.) {
64	s = -s;
65	}
66	if (tr <= 0.) {
67	*yi = s;
68	}
69	if (tr < 0.) {
70	yr = ti / yi * .5;
71	}
72	if (tr > 0.) {
73	yi = ti / yr * .5;
74	}
75	return 0;
76	} /* csroot_ */
77
78	doublereal epslon_(doublereal *x)
79	{
80	/* System generated locals */
81	doublereal ret_val, d_1;
82
83	/* Local variables */
84	static doublereal a, b, c, eps;
85
86
87	/* ESTIMATE UNIT ROUNDOFF IN QUANTITIES OF SIZE X. */
88
89
90	/* THIS PROGRAM SHOULD FUNCTION PROPERLY ON ALL SYSTEMS */
91	/* SATISFYING THE FOLLOWING TWO ASSUMPTIONS, */
92	/* 1. THE BASE USED IN REPRESENTING FLOATING POINT */
93	/* NUMBERS IS NOT A POWER OF THREE. */
94	/* 2. THE QUANTITY A IN STATEMENT 10 IS REPRESENTED TO */
95	/* THE ACCURACY USED IN FLOATING POINT VARIABLES */
96	/* THAT ARE STORED IN MEMORY. */
97	/* THE STATEMENT NUMBER 10 AND THE GO TO 10 ARE INTENDED TO */
98	/* FORCE OPTIMIZING COMPILERS TO GENERATE CODE SATISFYING */
99	/* ASSUMPTION 2. */
100	/* UNDER THESE ASSUMPTIONS, IT SHOULD BE TRUE THAT, */
101	/* A IS NOT EXACTLY EQUAL TO FOUR-THIRDS, */
102	/* B HAS A ZERO FOR ITS LAST BIT OR DIGIT, */
103	/* C IS NOT EXACTLY EQUAL TO ONE, */
104	/* EPS MEASURES THE SEPARATION OF 1.0 FROM */
105	/* THE NEXT LARGER FLOATING POINT NUMBER. */
106	/* THE DEVELOPERS OF EISPACK WOULD APPRECIATE BEING INFORMED */
107	/* ABOUT ANY SYSTEMS WHERE THESE ASSUMPTIONS DO NOT HOLD. */
108
109	/* THIS VERSION DATED 4/6/83. */
110
111	a = 1.3333333333333333;
112	L10:
113	b = a - 1.;
114	c = b + b + b;
115	eps = (d_1 = c - 1., abs(d_1));
116	if (eps == 0.) {
117	goto L10;
118	}
119	ret_val = eps * abs(*x);
120	return ret_val;
121	} /* epslon_ */
122
123	doublereal pythag_(doublereal a, doublereal b)
124	{
125	/* System generated locals */
126	doublereal ret_val, d_1, d_2, d_3;
127
128	/* Local variables */
129	static doublereal p, r, s, t, u;
130
131
132	/* FINDS DSQRT(A2+B2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW */
133
134	/* Computing MAX */
135	d_1 = abs(a), d_2 = abs(b);
136	p = max(d_1,d_2);
137	if (p == 0.) {
138	goto L20;
139	}
140	/* Computing MIN */
141	d_2 = abs(a), d_3 = abs(b);
142	/* Computing 2nd power */
143	d_1 = min(d_2,d_3) / p;
144	r = d_1 * d_1;
145	L10:
146	t = r + 4.;
147	if (t == 4.) {
148	goto L20;
149	}
150	s = r / t;
151	u = s * 2. + 1.;
152	p = u * p;
153	/* Computing 2nd power */
154	d_1 = s / u;
155	r = d_1 * d_1 * r;
156	goto L10;
157	L20:
158	ret_val = p;
159	return ret_val;
160	} /* pythag_ */
161
162	/* Subroutine / int bakvec_(integer nm, integer n, doublereal t,
163	doublereal e, integer m, doublereal z, integer ierr)
164	{
165	/* System generated locals */
166	integer t_dim1, t_offset, z_dim1, z_offset, i_1, i_2;
167
168	/* Local variables */
169	static integer i, j;
170
171
172
173	/* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A NONSYMMETRIC */
174	/* TRIDIAGONAL MATRIX BY BACK TRANSFORMING THOSE OF THE */
175	/* CORRESPONDING SYMMETRIC MATRIX DETERMINED BY FIGI. */
176
177	/* ON INPUT */
178
179	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
180	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
181	/* DIMENSION STATEMENT. */
182
183	/* N IS THE ORDER OF THE MATRIX. */
184
185	/* T CONTAINS THE NONSYMMETRIC MATRIX. ITS SUBDIAGONAL IS */
186	/* STORED IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN, */
187	/* ITS DIAGONAL IN THE N POSITIONS OF THE SECOND COLUMN, */
188	/* AND ITS SUPERDIAGONAL IN THE FIRST N-1 POSITIONS OF */
189	/* THE THIRD COLUMN. T(1,1) AND T(N,3) ARE ARBITRARY. */
190
191	/* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE SYMMETRIC */
192	/* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */
193
194	/* M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. */
195
196	/* Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED */
197	/* IN ITS FIRST M COLUMNS. */
198
199	/* ON OUTPUT */
200
201	/* T IS UNALTERED. */
202
203	/* E IS DESTROYED. */
204
205	/* Z CONTAINS THE TRANSFORMED EIGENVECTORS */
206	/* IN ITS FIRST M COLUMNS. */
207
208	/* IERR IS SET TO */
209	/* ZERO FOR NORMAL RETURN, */
210	/* 2*N+I IF E(I) IS ZERO WITH T(I,1) OR T(I-1,3) NON-ZERO.
211	*/
212	/* IN THIS CASE, THE SYMMETRIC MATRIX IS NOT SIMILAR
213	*/
214	/* TO THE ORIGINAL MATRIX, AND THE EIGENVECTORS */
215	/* CANNOT BE FOUND BY THIS PROGRAM. */
216
217	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
218	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
219	*/
220
221	/* THIS VERSION DATED AUGUST 1983. */
222
223	/* ------------------------------------------------------------------
224	*/
225
226	/* Parameter adjustments */
227	t_dim1 = *nm;
228	t_offset = t_dim1 + 1;
229	t -= t_offset;
230	--e;
231	z_dim1 = *nm;
232	z_offset = z_dim1 + 1;
233	z -= z_offset;
234
235	/* Function Body */
236	*ierr = 0;
237	if (*m == 0) {
238	goto L1001;
239	}
240	e[1] = 1.;
241	if (*n == 1) {
242	goto L1001;
243	}
244
245	i_1 = *n;
246	for (i = 2; i <= i_1; ++i) {
247	if (e[i] != 0.) {
248	goto L80;
249	}
250	if (t[i + t_dim1] != 0. \|\| t[i - 1 + t_dim1 * 3] != 0.) {
251	goto L1000;
252	}
253	e[i] = 1.;
254	goto L100;
255	L80:
256	e[i] = e[i - 1] * e[i] / t[i - 1 + t_dim1 * 3];
257	L100:
258	;
259	}
260
261	i_1 = *m;
262	for (j = 1; j <= i_1; ++j) {
263
264	i_2 = *n;
265	for (i = 2; i <= i_2; ++i) {
266	z[i + j * z_dim1] *= e[i];
267	/* L120: */
268	}
269	}
270
271	goto L1001;
272	/* .......... SET ERROR -- EIGENVECTORS CANNOT BE */
273	/* FOUND BY THIS PROGRAM .......... */
274	L1000:
275	ierr = (n << 1) + i;
276	L1001:
277	return 0;
278	} /* bakvec_ */
279
280	/* Subroutine / int balanc_(integer nm, integer n, doublereal a, integer *
281	low, integer igh, doublereal scale)
282	{
283	/* System generated locals */
284	integer a_dim1, a_offset, i_1, i_2;
285	doublereal d_1;
286
287	/* Local variables */
288	static integer iexc;
289	static doublereal c, f, g;
290	static integer i, j, k, l, m;
291	static doublereal r, s, radix, b2;
292	static integer jj;
293	static logical noconv;
294
295
296
297	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALANCE, */
298	/* NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. */
299	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). */
300
301	/* THIS SUBROUTINE BALANCES A REAL MATRIX AND ISOLATES */
302	/* EIGENVALUES WHENEVER POSSIBLE. */
303
304	/* ON INPUT */
305
306	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
307	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
308	/* DIMENSION STATEMENT. */
309
310	/* N IS THE ORDER OF THE MATRIX. */
311
312	/* A CONTAINS THE INPUT MATRIX TO BE BALANCED. */
313
314	/* ON OUTPUT */
315
316	/* A CONTAINS THE BALANCED MATRIX. */
317
318	/* LOW AND IGH ARE TWO INTEGERS SUCH THAT A(I,J) */
319	/* IS EQUAL TO ZERO IF */
320	/* (1) I IS GREATER THAN J AND */
321	/* (2) J=1,...,LOW-1 OR I=IGH+1,...,N. */
322
323	/* SCALE CONTAINS INFORMATION DETERMINING THE */
324	/* PERMUTATIONS AND SCALING FACTORS USED. */
325
326	/* SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH */
327	/* HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED */
328	/* WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS */
329	/* OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN */
330	/* SCALE(J) = P(J), FOR J = 1,...,LOW-1 */
331	/* = D(J,J), J = LOW,...,IGH */
332	/* = P(J) J = IGH+1,...,N. */
333	/* THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1, */
334	/* THEN 1 TO LOW-1. */
335
336	/* NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY. */
337
338	/* THE ALGOL PROCEDURE EXC CONTAINED IN BALANCE APPEARS IN */
339	/* BALANC IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS */
340	/* K,L HAVE BEEN REVERSED.) */
341
342	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
343	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
344	*/
345
346	/* THIS VERSION DATED AUGUST 1983. */
347
348	/* ------------------------------------------------------------------
349	*/
350
351	/* Parameter adjustments */
352	--scale;
353	a_dim1 = *nm;
354	a_offset = a_dim1 + 1;
355	a -= a_offset;
356
357	/* Function Body */
358	radix = 16.;
359
360	b2 = radix * radix;
361	k = 1;
362	l = *n;
363	goto L100;
364	/* .......... IN-LINE PROCEDURE FOR ROW AND */
365	/* COLUMN EXCHANGE .......... */
366	L20:
367	scale[m] = (doublereal) j;
368	if (j == m) {
369	goto L50;
370	}
371
372	i_1 = l;
373	for (i = 1; i <= i_1; ++i) {
374	f = a[i + j * a_dim1];
375	a[i + j * a_dim1] = a[i + m * a_dim1];
376	a[i + m * a_dim1] = f;
377	/* L30: */
378	}
379
380	i_1 = *n;
381	for (i = k; i <= i_1; ++i) {
382	f = a[j + i * a_dim1];
383	a[j + i * a_dim1] = a[m + i * a_dim1];
384	a[m + i * a_dim1] = f;
385	/* L40: */
386	}
387
388	L50:
389	switch (iexc) {
390	case 1: goto L80;
391	case 2: goto L130;
392	}
393	/* .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE */
394	/* AND PUSH THEM DOWN .......... */
395	L80:
396	if (l == 1) {
397	goto L280;
398	}
399	--l;
400	/* .......... FOR J=L STEP -1 UNTIL 1 DO -- .......... */
401	L100:
402	i_1 = l;
403	for (jj = 1; jj <= i_1; ++jj) {
404	j = l + 1 - jj;
405
406	i_2 = l;
407	for (i = 1; i <= i_2; ++i) {
408	if (i == j) {
409	goto L110;
410	}
411	if (a[j + i * a_dim1] != 0.) {
412	goto L120;
413	}
414	L110:
415	;
416	}
417
418	m = l;
419	iexc = 1;
420	goto L20;
421	L120:
422	;
423	}
424
425	goto L140;
426	/* .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE */
427	/* AND PUSH THEM LEFT .......... */
428	L130:
429	++k;
430
431	L140:
432	i_1 = l;
433	for (j = k; j <= i_1; ++j) {
434
435	i_2 = l;
436	for (i = k; i <= i_2; ++i) {
437	if (i == j) {
438	goto L150;
439	}
440	if (a[i + j * a_dim1] != 0.) {
441	goto L170;
442	}
443	L150:
444	;
445	}
446
447	m = k;
448	iexc = 2;
449	goto L20;
450	L170:
451	;
452	}
453	/* .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L .......... */
454	i_1 = l;
455	for (i = k; i <= i_1; ++i) {
456	/* L180: */
457	scale[i] = 1.;
458	}
459	/* .......... ITERATIVE LOOP FOR NORM REDUCTION .......... */
460	L190:
461	noconv = FALSE_;
462
463	i_1 = l;
464	for (i = k; i <= i_1; ++i) {
465	c = 0.;
466	r = 0.;
467
468	i_2 = l;
469	for (j = k; j <= i_2; ++j) {
470	if (j == i) {
471	goto L200;
472	}
473	c += (d_1 = a[j + i * a_dim1], abs(d_1));
474	r += (d_1 = a[i + j * a_dim1], abs(d_1));
475	L200:
476	;
477	}
478	/* .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW .........
479	. */
480	if (c == 0. \|\| r == 0.) {
481	goto L270;
482	}
483	g = r / radix;
484	f = 1.;
485	s = c + r;
486	L210:
487	if (c >= g) {
488	goto L220;
489	}
490	f *= radix;
491	c *= b2;
492	goto L210;
493	L220:
494	g = r * radix;
495	L230:
496	if (c < g) {
497	goto L240;
498	}
499	f /= radix;
500	c /= b2;
501	goto L230;
502	/* .......... NOW BALANCE .......... */
503	L240:
504	if ((c + r) / f >= s * .95) {
505	goto L270;
506	}
507	g = 1. / f;
508	scale[i] *= f;
509	noconv = TRUE_;
510
511	i_2 = *n;
512	for (j = k; j <= i_2; ++j) {
513	/* L250: */
514	a[i + j * a_dim1] *= g;
515	}
516
517	i_2 = l;
518	for (j = 1; j <= i_2; ++j) {
519	/* L260: */
520	a[j + i * a_dim1] *= f;
521	}
522
523	L270:
524	;
525	}
526
527	if (noconv) {
528	goto L190;
529	}
530
531	L280:
532	*low = k;
533	*igh = l;
534	return 0;
535	} /* balanc_ */
536
537	/* Subroutine / int balbak_(integer nm, integer n, integer low, integer *
538	igh, doublereal scale, integer m, doublereal *z)
539	{
540	/* System generated locals */
541	integer z_dim1, z_offset, i_1, i_2;
542
543	/* Local variables */
544	static integer i, j, k;
545	static doublereal s;
546	static integer ii;
547
548
549
550	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALBAK, */
551	/* NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. */
552	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). */
553
554	/* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL GENERAL */
555	/* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */
556	/* BALANCED MATRIX DETERMINED BY BALANC. */
557
558	/* ON INPUT */
559
560	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
561	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
562	/* DIMENSION STATEMENT. */
563
564	/* N IS THE ORDER OF THE MATRIX. */
565
566	/* LOW AND IGH ARE INTEGERS DETERMINED BY BALANC. */
567
568	/* SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS */
569	/* AND SCALING FACTORS USED BY BALANC. */
570
571	/* M IS THE NUMBER OF COLUMNS OF Z TO BE BACK TRANSFORMED. */
572
573	/* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGEN- */
574	/* VECTORS TO BE BACK TRANSFORMED IN ITS FIRST M COLUMNS. */
575
576	/* ON OUTPUT */
577
578	/* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE */
579	/* TRANSFORMED EIGENVECTORS IN ITS FIRST M COLUMNS. */
580
581	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
582	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
583	*/
584
585	/* THIS VERSION DATED AUGUST 1983. */
586
587	/* ------------------------------------------------------------------
588	*/
589
590	/* Parameter adjustments */
591	--scale;
592	z_dim1 = *nm;
593	z_offset = z_dim1 + 1;
594	z -= z_offset;
595
596	/* Function Body */
597	if (*m == 0) {
598	goto L200;
599	}
600	if (igh == low) {
601	goto L120;
602	}
603
604	i_1 = *igh;
605	for (i = *low; i <= i_1; ++i) {
606	s = scale[i];
607	/* .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED */
608	/* IF THE FOREGOING STATEMENT IS REPLACED BY */
609	/* S=1.0D0/SCALE(I). .......... */
610	i_2 = *m;
611	for (j = 1; j <= i_2; ++j) {
612	/* L100: */
613	z[i + j * z_dim1] *= s;
614	}
615
616	/* L110: */
617	}
618	/* ......... FOR I=LOW-1 STEP -1 UNTIL 1, */
619	/* IGH+1 STEP 1 UNTIL N DO -- .......... */
620	L120:
621	i_1 = *n;
622	for (ii = 1; ii <= i_1; ++ii) {
623	i = ii;
624	if (i >= low && i <= igh) {
625	goto L140;
626	}
627	if (i < *low) {
628	i = *low - ii;
629	}
630	k = (integer) scale[i];
631	if (k == i) {
632	goto L140;
633	}
634
635	i_2 = *m;
636	for (j = 1; j <= i_2; ++j) {
637	s = z[i + j * z_dim1];
638	z[i + j * z_dim1] = z[k + j * z_dim1];
639	z[k + j * z_dim1] = s;
640	/* L130: */
641	}
642
643	L140:
644	;
645	}
646
647	L200:
648	return 0;
649	} /* balbak_ */
650
651	/* Subroutine / int bandr_(integer nm, integer n, integer mb, doublereal *
652	a, doublereal d, doublereal e, doublereal e2, logical matz,
653	doublereal *z)
654	{
655	/* System generated locals */
656	integer a_dim1, a_offset, z_dim1, z_offset, i_1, i_2, i_3, i_4, i_5,
657	i_6;
658	doublereal d_1;
659
660	/* Builtin functions */
661	double sqrt(doublereal);
662
663	/* Local variables */
664	static doublereal dmin_;
665	static integer maxl, maxr;
666	static doublereal g;
667	static integer j, k, l, r;
668	static doublereal u, b1, b2, c2, f1, f2;
669	static integer i1, i2, j1, j2, m1, n2, r1;
670	static doublereal s2;
671	static integer kr, mr;
672	static doublereal dminrt;
673	static integer ugl;
674
675
676
677	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BANDRD, */
678	/* NUM. MATH. 12, 231-241(1968) BY SCHWARZ. */
679	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 273-283(1971). */
680
681	/* THIS SUBROUTINE REDUCES A REAL SYMMETRIC BAND MATRIX */
682	/* TO A SYMMETRIC TRIDIAGONAL MATRIX USING AND OPTIONALLY */
683	/* ACCUMULATING ORTHOGONAL SIMILARITY TRANSFORMATIONS. */
684
685	/* ON INPUT */
686
687	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
688	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
689	/* DIMENSION STATEMENT. */
690
691	/* N IS THE ORDER OF THE MATRIX. */
692
693	/* MB IS THE (HALF) BAND WIDTH OF THE MATRIX, DEFINED AS THE */
694	/* NUMBER OF ADJACENT DIAGONALS, INCLUDING THE PRINCIPAL */
695	/* DIAGONAL, REQUIRED TO SPECIFY THE NON-ZERO PORTION OF THE */
696	/* LOWER TRIANGLE OF THE MATRIX. */
697
698	/* A CONTAINS THE LOWER TRIANGLE OF THE SYMMETRIC BAND INPUT */
699	/* MATRIX STORED AS AN N BY MB ARRAY. ITS LOWEST SUBDIAGONAL */
700	/* IS STORED IN THE LAST N+1-MB POSITIONS OF THE FIRST COLUMN, */
701	/* ITS NEXT SUBDIAGONAL IN THE LAST N+2-MB POSITIONS OF THE */
702	/* SECOND COLUMN, FURTHER SUBDIAGONALS SIMILARLY, AND FINALLY */
703	/* ITS PRINCIPAL DIAGONAL IN THE N POSITIONS OF THE LAST COLUMN.
704	*/
705	/* CONTENTS OF STORAGES NOT PART OF THE MATRIX ARE ARBITRARY. */
706
707	/* MATZ SHOULD BE SET TO .TRUE. IF THE TRANSFORMATION MATRIX IS */
708	/* TO BE ACCUMULATED, AND TO .FALSE. OTHERWISE. */
709
710	/* ON OUTPUT */
711
712	/* A HAS BEEN DESTROYED, EXCEPT FOR ITS LAST TWO COLUMNS WHICH */
713	/* CONTAIN A COPY OF THE TRIDIAGONAL MATRIX. */
714
715	/* D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. */
716
717	/* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL */
718	/* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. */
719
720	/* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */
721	/* E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. */
722
723	/* Z CONTAINS THE ORTHOGONAL TRANSFORMATION MATRIX PRODUCED IN */
724	/* THE REDUCTION IF MATZ HAS BEEN SET TO .TRUE. OTHERWISE, Z */
725	/* IS NOT REFERENCED. */
726
727	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
728	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
729	*/
730
731	/* THIS VERSION DATED AUGUST 1983. */
732
733	/* ------------------------------------------------------------------
734	*/
735
736	/* Parameter adjustments */
737	z_dim1 = *nm;
738	z_offset = z_dim1 + 1;
739	z -= z_offset;
740	--e2;
741	--e;
742	--d;
743	a_dim1 = *nm;
744	a_offset = a_dim1 + 1;
745	a -= a_offset;
746
747	/* Function Body */
748	dmin_ = 5.4210108624275222e-20;
749	dminrt = 2.3283064365386963e-10;
750	/* .......... INITIALIZE DIAGONAL SCALING MATRIX .......... */
751	i_1 = *n;
752	for (j = 1; j <= i_1; ++j) {
753	/* L30: */
754	d[j] = 1.;
755	}
756
757	if (! (*matz)) {
758	goto L60;
759	}
760
761	i_1 = *n;
762	for (j = 1; j <= i_1; ++j) {
763
764	i_2 = *n;
765	for (k = 1; k <= i_2; ++k) {
766	/* L40: */
767	z[j + k * z_dim1] = 0.;
768	}
769
770	z[j + j * z_dim1] = 1.;
771	/* L50: */
772	}
773
774	L60:
775	m1 = *mb - 1;
776	if ((i_1 = m1 - 1) < 0) {
777	goto L900;
778	} else if (i_1 == 0) {
779	goto L800;
780	} else {
781	goto L70;
782	}
783	L70:
784	n2 = *n - 2;
785
786	i_1 = n2;
787	for (k = 1; k <= i_1; ++k) {
788	/* Computing MIN */
789	i_2 = m1, i_3 = *n - k;
790	maxr = min(i_2,i_3);
791	/* .......... FOR R=MAXR STEP -1 UNTIL 2 DO -- .......... */
792	i_2 = maxr;
793	for (r1 = 2; r1 <= i_2; ++r1) {
794	r = maxr + 2 - r1;
795	kr = k + r;
796	mr = *mb - r;
797	g = a[kr + mr * a_dim1];
798	a[kr - 1 + a_dim1] = a[kr - 1 + (mr + 1) * a_dim1];
799	ugl = k;
800
801	i_3 = *n;
802	i_4 = m1;
803	for (j = kr; i_4 < 0 ? j >= i_3 : j <= i_3; j += i_4) {
804	j1 = j - 1;
805	j2 = j1 - 1;
806	if (g == 0.) {
807	goto L600;
808	}
809	b1 = a[j1 + a_dim1] / g;
810	b2 = b1 * d[j1] / d[j];
811	s2 = 1. / (b1 * b2 + 1.);
812	if (s2 >= .5) {
813	goto L450;
814	}
815	b1 = g / a[j1 + a_dim1];
816	b2 = b1 * d[j] / d[j1];
817	c2 = 1. - s2;
818	d[j1] = c2 * d[j1];
819	d[j] = c2 * d[j];
820	f1 = a[j + m1 * a_dim1] * 2.;
821	f2 = b1 * a[j1 + mb a_dim1];
822	a[j + m1 * a_dim1] = -b2 * (b1 * a[j + m1 * a_dim1] - a[j + *
823	mb * a_dim1]) - f2 + a[j + m1 * a_dim1];
824	a[j1 + mb a_dim1] = b2 * (b2 * a[j + mb a_dim1] + f1) +
825	a[j1 + mb a_dim1];
826	a[j + mb a_dim1] = b1 * (f2 - f1) + a[j + mb a_dim1];
827
828	i_5 = j2;
829	for (l = ugl; l <= i_5; ++l) {
830	i2 = *mb - j + l;
831	u = a[j1 + (i2 + 1) * a_dim1] + b2 * a[j + i2 * a_dim1];
832	a[j + i2 * a_dim1] = -b1 * a[j1 + (i2 + 1) * a_dim1] + a[
833	j + i2 * a_dim1];
834	a[j1 + (i2 + 1) * a_dim1] = u;
835	/* L200: */
836	}
837
838	ugl = j;
839	a[j1 + a_dim1] += b2 * g;
840	if (j == *n) {
841	goto L350;
842	}
843	/* Computing MIN */
844	i_5 = m1, i_6 = *n - j1;
845	maxl = min(i_5,i_6);
846
847	i_5 = maxl;
848	for (l = 2; l <= i_5; ++l) {
849	i1 = j1 + l;
850	i2 = *mb - l;
851	u = a[i1 + i2 * a_dim1] + b2 * a[i1 + (i2 + 1) * a_dim1];
852	a[i1 + (i2 + 1) * a_dim1] = -b1 * a[i1 + i2 * a_dim1] + a[
853	i1 + (i2 + 1) * a_dim1];
854	a[i1 + i2 * a_dim1] = u;
855	/* L300: */
856	}
857
858	i1 = j + m1;
859	if (i1 > *n) {
860	goto L350;
861	}
862	g = b2 * a[i1 + a_dim1];
863	L350:
864	if (! (*matz)) {
865	goto L500;
866	}
867
868	i_5 = *n;
869	for (l = 1; l <= i_5; ++l) {
870	u = z[l + j1 * z_dim1] + b2 * z[l + j * z_dim1];
871	z[l + j * z_dim1] = -b1 * z[l + j1 * z_dim1] + z[l + j *
872	z_dim1];
873	z[l + j1 * z_dim1] = u;
874	/* L400: */
875	}
876
877	goto L500;
878
879	L450:
880	u = d[j1];
881	d[j1] = s2 * d[j];
882	d[j] = s2 * u;
883	f1 = a[j + m1 * a_dim1] * 2.;
884	f2 = b1 * a[j + mb a_dim1];
885	u = b1 * (f2 - f1) + a[j1 + mb a_dim1];
886	a[j + m1 * a_dim1] = b2 * (b1 * a[j + m1 * a_dim1] - a[j1 + *
887	mb * a_dim1]) + f2 - a[j + m1 * a_dim1];
888	a[j1 + mb a_dim1] = b2 * (b2 * a[j1 + mb a_dim1] + f1)
889	+ a[j + mb a_dim1];
890	a[j + mb a_dim1] = u;
891
892	i_5 = j2;
893	for (l = ugl; l <= i_5; ++l) {
894	i2 = *mb - j + l;
895	u = b2 * a[j1 + (i2 + 1) * a_dim1] + a[j + i2 * a_dim1];
896	a[j + i2 * a_dim1] = -a[j1 + (i2 + 1) * a_dim1] + b1 * a[
897	j + i2 * a_dim1];
898	a[j1 + (i2 + 1) * a_dim1] = u;
899	/* L460: */
900	}
901
902	ugl = j;
903	a[j1 + a_dim1] = b2 * a[j1 + a_dim1] + g;
904	if (j == *n) {
905	goto L480;
906	}
907	/* Computing MIN */
908	i_5 = m1, i_6 = *n - j1;
909	maxl = min(i_5,i_6);
910
911	i_5 = maxl;
912	for (l = 2; l <= i_5; ++l) {
913	i1 = j1 + l;
914	i2 = *mb - l;
915	u = b2 * a[i1 + i2 * a_dim1] + a[i1 + (i2 + 1) * a_dim1];
916	a[i1 + (i2 + 1) * a_dim1] = -a[i1 + i2 * a_dim1] + b1 * a[
917	i1 + (i2 + 1) * a_dim1];
918	a[i1 + i2 * a_dim1] = u;
919	/* L470: */
920	}
921
922	i1 = j + m1;
923	if (i1 > *n) {
924	goto L480;
925	}
926	g = a[i1 + a_dim1];
927	a[i1 + a_dim1] = b1 * a[i1 + a_dim1];
928	L480:
929	if (! (*matz)) {
930	goto L500;
931	}
932
933	i_5 = *n;
934	for (l = 1; l <= i_5; ++l) {
935	u = b2 * z[l + j1 * z_dim1] + z[l + j * z_dim1];
936	z[l + j * z_dim1] = -z[l + j1 * z_dim1] + b1 * z[l + j *
937	z_dim1];
938	z[l + j1 * z_dim1] = u;
939	/* L490: */
940	}
941
942	L500:
943	;
944	}
945
946	L600:
947	;
948	}
949
950	if (k % 64 != 0) {
951	goto L700;
952	}
953	/* .......... RESCALE TO AVOID UNDERFLOW OR OVERFLOW .......... */
954	i_2 = *n;
955	for (j = k; j <= i_2; ++j) {
956	if (d[j] >= dmin_) {
957	goto L650;
958	}
959	/* Computing MAX */
960	i_4 = 1, i_3 = *mb + 1 - j;
961	maxl = max(i_4,i_3);
962
963	i_4 = m1;
964	for (l = maxl; l <= i_4; ++l) {
965	/* L610: */
966	a[j + l * a_dim1] = dminrt * a[j + l * a_dim1];
967	}
968
969	if (j == *n) {
970	goto L630;
971	}
972	/* Computing MIN */
973	i_4 = m1, i_3 = *n - j;
974	maxl = min(i_4,i_3);
975
976	i_4 = maxl;
977	for (l = 1; l <= i_4; ++l) {
978	i1 = j + l;
979	i2 = *mb - l;
980	a[i1 + i2 * a_dim1] = dminrt * a[i1 + i2 * a_dim1];
981	/* L620: */
982	}
983
984	L630:
985	if (! (*matz)) {
986	goto L645;
987	}
988
989	i_4 = *n;
990	for (l = 1; l <= i_4; ++l) {
991	/* L640: */
992	z[l + j * z_dim1] = dminrt * z[l + j * z_dim1];
993	}
994
995	L645:
996	a[j + mb a_dim1] = dmin_ * a[j + mb a_dim1];
997	d[j] /= dmin_;
998	L650:
999	;
1000	}
1001
1002	L700:
1003	;
1004	}
1005	/* .......... FORM SQUARE ROOT OF SCALING MATRIX .......... */
1006	L800:
1007	i_1 = *n;
1008	for (j = 2; j <= i_1; ++j) {
1009	/* L810: */
1010	e[j] = sqrt(d[j]);
1011	}
1012
1013	if (! (*matz)) {
1014	goto L840;
1015	}
1016
1017	i_1 = *n;
1018	for (j = 1; j <= i_1; ++j) {
1019
1020	i_2 = *n;
1021	for (k = 2; k <= i_2; ++k) {
1022	/* L820: */
1023	z[j + k * z_dim1] = e[k] * z[j + k * z_dim1];
1024	}
1025
1026	/* L830: */
1027	}
1028
1029	L840:
1030	u = 1.;
1031
1032	i_1 = *n;
1033	for (j = 2; j <= i_1; ++j) {
1034	a[j + m1 * a_dim1] = u * e[j] * a[j + m1 * a_dim1];
1035	u = e[j];
1036	/* Computing 2nd power */
1037	d_1 = a[j + m1 * a_dim1];
1038	e2[j] = d_1 * d_1;
1039	a[j + mb a_dim1] = d[j] * a[j + mb a_dim1];
1040	d[j] = a[j + mb a_dim1];
1041	e[j] = a[j + m1 * a_dim1];
1042	/* L850: */
1043	}
1044
1045	d[1] = a[mb a_dim1 + 1];
1046	e[1] = 0.;
1047	e2[1] = 0.;
1048	goto L1001;
1049
1050	L900:
1051	i_1 = *n;
1052	for (j = 1; j <= i_1; ++j) {
1053	d[j] = a[j + mb a_dim1];
1054	e[j] = 0.;
1055	e2[j] = 0.;
1056	/* L950: */
1057	}
1058
1059	L1001:
1060	return 0;
1061	} /* bandr_ */
1062
1063	/* Subroutine / int bandv_(integer nm, integer n, integer mbw, doublereal
1064	a, doublereal e21, integer m, doublereal w, doublereal *z,
1065	integer ierr, integer /nv/, doublereal rv, doublereal rv6)
1066	{
1067	/* System generated locals */
1068	integer a_dim1, a_offset, z_dim1, z_offset, i_1, i_2, i_3, i_4, i_5;
1069	doublereal d_1;
1070
1071	/* Builtin functions */
1072	double sqrt(doublereal), d_sign(doublereal , doublereal );
1073
1074	/* Local variables */
1075	static integer maxj, maxk;
1076	static doublereal norm;
1077	static integer i, j, k, r;
1078	static doublereal u, v, order;
1079	static integer group, m1;
1080	static doublereal x0, x1;
1081	static integer mb, m21, ii, ij, jj, kj;
1082	static doublereal uk, xu;
1083	extern doublereal pythag_(doublereal , doublereal ), epslon_(doublereal
1084	*);
1085	static integer ij1, kj1, its;
1086	static doublereal eps2, eps3, eps4;
1087
1088
1089
1090	/* THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A REAL SYMMETRIC */
1091	/* BAND MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES, USING INVERSE
1092	*/
1093	/* ITERATION. THE SUBROUTINE MAY ALSO BE USED TO SOLVE SYSTEMS */
1094	/* OF LINEAR EQUATIONS WITH A SYMMETRIC OR NON-SYMMETRIC BAND */
1095	/* COEFFICIENT MATRIX. */
1096
1097	/* ON INPUT */
1098
1099	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
1100	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
1101	/* DIMENSION STATEMENT. */
1102
1103	/* N IS THE ORDER OF THE MATRIX. */
1104
1105	/* MBW IS THE NUMBER OF COLUMNS OF THE ARRAY A USED TO STORE THE */
1106	/* BAND MATRIX. IF THE MATRIX IS SYMMETRIC, MBW IS ITS (HALF) */
1107	/* BAND WIDTH, DENOTED MB AND DEFINED AS THE NUMBER OF ADJACENT
1108	*/
1109	/* DIAGONALS, INCLUDING THE PRINCIPAL DIAGONAL, REQUIRED TO */
1110	/* SPECIFY THE NON-ZERO PORTION OF THE LOWER TRIANGLE OF THE */
1111	/* MATRIX. IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS */
1112	/* OF LINEAR EQUATIONS AND THE COEFFICIENT MATRIX IS NOT */
1113	/* SYMMETRIC, IT MUST HOWEVER HAVE THE SAME NUMBER OF ADJACENT */
1114	/* DIAGONALS ABOVE THE MAIN DIAGONAL AS BELOW, AND IN THIS */
1115	/* CASE, MBW=2MB-1. /
1116
1117	/* A CONTAINS THE LOWER TRIANGLE OF THE SYMMETRIC BAND INPUT */
1118	/* MATRIX STORED AS AN N BY MB ARRAY. ITS LOWEST SUBDIAGONAL */
1119	/* IS STORED IN THE LAST N+1-MB POSITIONS OF THE FIRST COLUMN, */
1120	/* ITS NEXT SUBDIAGONAL IN THE LAST N+2-MB POSITIONS OF THE */
1121	/* SECOND COLUMN, FURTHER SUBDIAGONALS SIMILARLY, AND FINALLY */
1122	/* ITS PRINCIPAL DIAGONAL IN THE N POSITIONS OF COLUMN MB. */
1123	/* IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS OF LINEAR */
1124	/* EQUATIONS AND THE COEFFICIENT MATRIX IS NOT SYMMETRIC, A IS */
1125	/* N BY 2MB-1 INSTEAD WITH LOWER TRIANGLE AS ABOVE AND WITH /
1126	/* ITS FIRST SUPERDIAGONAL STORED IN THE FIRST N-1 POSITIONS OF
1127	*/
1128	/* COLUMN MB+1, ITS SECOND SUPERDIAGONAL IN THE FIRST N-2 */
1129	/* POSITIONS OF COLUMN MB+2, FURTHER SUPERDIAGONALS SIMILARLY, */
1130	/* AND FINALLY ITS HIGHEST SUPERDIAGONAL IN THE FIRST N+1-MB */
1131	/* POSITIONS OF THE LAST COLUMN. */
1132	/* CONTENTS OF STORAGES NOT PART OF THE MATRIX ARE ARBITRARY. */
1133
1134	/* E21 SPECIFIES THE ORDERING OF THE EIGENVALUES AND CONTAINS */
1135	/* 0.0D0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, OR */
1136	/* 2.0D0 IF THE EIGENVALUES ARE IN DESCENDING ORDER. */
1137	/* IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS OF LINEAR */
1138	/* EQUATIONS, E21 SHOULD BE SET TO 1.0D0 IF THE COEFFICIENT */
1139	/* MATRIX IS SYMMETRIC AND TO -1.0D0 IF NOT. */
1140
1141	/* M IS THE NUMBER OF SPECIFIED EIGENVALUES OR THE NUMBER OF */
1142	/* SYSTEMS OF LINEAR EQUATIONS. */
1143
1144	/* W CONTAINS THE M EIGENVALUES IN ASCENDING OR DESCENDING ORDER.
1145	*/
1146	/* IF THE SUBROUTINE IS BEING USED TO SOLVE SYSTEMS OF LINEAR */
1147	/* EQUATIONS (A-W(R)I)X(R)=B(R), WHERE I IS THE IDENTITY */
1148	/* MATRIX, W(R) SHOULD BE SET ACCORDINGLY, FOR R=1,2,...,M. */
1149
1150	/* Z CONTAINS THE CONSTANT MATRIX COLUMNS (B(R),R=1,2,...,M), IF */
1151	/* THE SUBROUTINE IS USED TO SOLVE SYSTEMS OF LINEAR EQUATIONS.
1152	*/
1153
1154	/* NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER RV */
1155	/* AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT. */
1156
1157	/* ON OUTPUT */
1158
1159	/* A AND W ARE UNALTERED. */
1160
1161	/* Z CONTAINS THE ASSOCIATED SET OF ORTHOGONAL EIGENVECTORS. */
1162	/* ANY VECTOR WHICH FAILS TO CONVERGE IS SET TO ZERO. IF THE */
1163	/* SUBROUTINE IS USED TO SOLVE SYSTEMS OF LINEAR EQUATIONS, */
1164	/* Z CONTAINS THE SOLUTION MATRIX COLUMNS (X(R),R=1,2,...,M). */
1165
1166	/* IERR IS SET TO */
1167	/* ZERO FOR NORMAL RETURN, */
1168	/* -R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH */
1169	/* EIGENVALUE FAILS TO CONVERGE, OR IF THE R-TH */
1170	/* SYSTEM OF LINEAR EQUATIONS IS NEARLY SINGULAR. */
1171
1172	/* RV AND RV6 ARE TEMPORARY STORAGE ARRAYS. NOTE THAT RV IS */
1173	/* OF DIMENSION AT LEAST N(2MB-1). IF THE SUBROUTINE */
1174	/* IS BEING USED TO SOLVE SYSTEMS OF LINEAR EQUATIONS, THE */
1175	/* DETERMINANT (UP TO SIGN) OF A-W(M)I IS AVAILABLE, UPON /
1176	/* RETURN, AS THE PRODUCT OF THE FIRST N ELEMENTS OF RV. */
1177
1178	/* CALLS PYTHAG FOR DSQRT(AA + BB) . */
1179
1180	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
1181	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
1182	*/
1183
1184	/* THIS VERSION DATED AUGUST 1983. */
1185
1186	/* ------------------------------------------------------------------
1187	*/
1188
1189	/* Parameter adjustments */
1190	--rv6;
1191	a_dim1 = *nm;
1192	a_offset = a_dim1 + 1;
1193	a -= a_offset;
1194	z_dim1 = *nm;
1195	z_offset = z_dim1 + 1;
1196	z -= z_offset;
1197	--w;
1198	--rv;
1199
1200	/* Function Body */
1201	*ierr = 0;
1202	if (*m == 0) {
1203	goto L1001;
1204	}
1205	mb = *mbw;
1206	if (*e21 < 0.) {
1207	mb = (*mbw + 1) / 2;
1208	}
1209	m1 = mb - 1;
1210	m21 = m1 + mb;
1211	order = 1. - abs(*e21);
1212	/* .......... FIND VECTORS BY INVERSE ITERATION .......... */
1213	i_1 = *m;
1214	for (r = 1; r <= i_1; ++r) {
1215	its = 1;
1216	x1 = w[r];
1217	if (r != 1) {
1218	goto L100;
1219	}
1220	/* .......... COMPUTE NORM OF MATRIX .......... */
1221	norm = 0.;
1222
1223	i_2 = mb;
1224	for (j = 1; j <= i_2; ++j) {
1225	jj = mb + 1 - j;
1226	kj = jj + m1;
1227	ij = 1;
1228	v = 0.;
1229
1230	i_3 = *n;
1231	for (i = jj; i <= i_3; ++i) {
1232	v += (d_1 = a[i + j * a_dim1], abs(d_1));
1233	if (*e21 >= 0.) {
1234	goto L40;
1235	}
1236	v += (d_1 = a[ij + kj * a_dim1], abs(d_1));
1237	++ij;
1238	L40:
1239	;
1240	}
1241
1242	norm = max(norm,v);
1243	/* L60: */
1244	}
1245
1246	if (*e21 < 0.) {
1247	norm *= .5;
1248	}
1249	/* .......... EPS2 IS THE CRITERION FOR GROUPING, */
1250	/* EPS3 REPLACES ZERO PIVOTS AND EQUAL */
1251	/* ROOTS ARE MODIFIED BY EPS3, */
1252	/* EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW .........
1253	. */
1254	if (norm == 0.) {
1255	norm = 1.;
1256	}
1257	eps2 = norm * .001 * abs(order);
1258	eps3 = epslon_(&norm);
1259	uk = (doublereal) (*n);
1260	uk = sqrt(uk);
1261	eps4 = uk * eps3;
1262	L80:
1263	group = 0;
1264	goto L120;
1265	/* .......... LOOK FOR CLOSE OR COINCIDENT ROOTS .......... */
1266	L100:
1267	if ((d_1 = x1 - x0, abs(d_1)) >= eps2) {
1268	goto L80;
1269	}
1270	++group;
1271	if (order * (x1 - x0) <= 0.) {
1272	x1 = x0 + order * eps3;
1273	}
1274	/* .......... EXPAND MATRIX, SUBTRACT EIGENVALUE, */
1275	/* AND INITIALIZE VECTOR .......... */
1276	L120:
1277	i_2 = *n;
1278	for (i = 1; i <= i_2; ++i) {
1279	/* Computing MIN */
1280	i_3 = 0, i_4 = i - m1;
1281	ij = i + min(i_3,i_4) * *n;
1282	kj = ij + mb * *n;
1283	ij1 = kj + m1 * *n;
1284	if (m1 == 0) {
1285	goto L180;
1286	}
1287
1288	i_3 = m1;
1289	for (j = 1; j <= i_3; ++j) {
1290	if (ij > m1) {
1291	goto L125;
1292	}
1293	if (ij > 0) {
1294	goto L130;
1295	}
1296	rv[ij1] = 0.;
1297	ij1 += *n;
1298	goto L130;
1299	L125:
1300	rv[ij] = a[i + j * a_dim1];
1301	L130:
1302	ij += *n;
1303	ii = i + j;
1304	if (ii > *n) {
1305	goto L150;
1306	}
1307	jj = mb - j;
1308	if (*e21 >= 0.) {
1309	goto L140;
1310	}
1311	ii = i;
1312	jj = mb + j;
1313	L140:
1314	rv[kj] = a[ii + jj * a_dim1];
1315	kj += *n;
1316	L150:
1317	;
1318	}
1319
1320	L180:
1321	rv[ij] = a[i + mb * a_dim1] - x1;
1322	rv6[i] = eps4;
1323	if (order == 0.) {
1324	rv6[i] = z[i + r * z_dim1];
1325	}
1326	/* L200: */
1327	}
1328
1329	if (m1 == 0) {
1330	goto L600;
1331	}
1332	/* .......... ELIMINATION WITH INTERCHANGES .......... */
1333	i_2 = *n;
1334	for (i = 1; i <= i_2; ++i) {
1335	ii = i + 1;
1336	/* Computing MIN */
1337	i_3 = i + m1 - 1;
1338	maxk = min(i_3,*n);
1339	/* Computing MIN */
1340	i_3 = *n - i, i_4 = m21 - 2;
1341	maxj = min(i_3,i_4) * *n;
1342
1343	i_3 = maxk;
1344	for (k = i; k <= i_3; ++k) {
1345	kj1 = k;
1346	j = kj1 + *n;
1347	jj = j + maxj;
1348
1349	i_4 = jj;
1350	i_5 = *n;
1351	for (kj = j; i_5 < 0 ? kj >= i_4 : kj <= i_4; kj += i_5) {
1352	rv[kj1] = rv[kj];
1353	kj1 = kj;
1354	/* L340: */
1355	}
1356
1357	rv[kj1] = 0.;
1358	/* L360: */
1359	}
1360
1361	if (i == *n) {
1362	goto L580;
1363	}
1364	u = 0.;
1365	/* Computing MIN */
1366	i_3 = i + m1;
1367	maxk = min(i_3,*n);
1368	/* Computing MIN */
1369	i_3 = *n - ii, i_5 = m21 - 2;
1370	maxj = min(i_3,i_5) * *n;
1371
1372	i_3 = maxk;
1373	for (j = i; j <= i_3; ++j) {
1374	if ((d_1 = rv[j], abs(d_1)) < abs(u)) {
1375	goto L450;
1376	}
1377	u = rv[j];
1378	k = j;
1379	L450:
1380	;
1381	}
1382
1383	j = i + *n;
1384	jj = j + maxj;
1385	if (k == i) {
1386	goto L520;
1387	}
1388	kj = k;
1389
1390	i_3 = jj;
1391	i_5 = *n;
1392	for (ij = i; i_5 < 0 ? ij >= i_3 : ij <= i_3; ij += i_5) {
1393	v = rv[ij];
1394	rv[ij] = rv[kj];
1395	rv[kj] = v;
1396	kj += *n;
1397	/* L500: */
1398	}
1399
1400	if (order != 0.) {
1401	goto L520;
1402	}
1403	v = rv6[i];
1404	rv6[i] = rv6[k];
1405	rv6[k] = v;
1406	L520:
1407	if (u == 0.) {
1408	goto L580;
1409	}
1410
1411	i_5 = maxk;
1412	for (k = ii; k <= i_5; ++k) {
1413	v = rv[k] / u;
1414	kj = k;
1415
1416	i_3 = jj;
1417	i_4 = *n;
1418	for (ij = j; i_4 < 0 ? ij >= i_3 : ij <= i_3; ij += i_4) {
1419	kj += *n;
1420	rv[kj] -= v * rv[ij];
1421	/* L540: */
1422	}
1423
1424	if (order == 0.) {
1425	rv6[k] -= v * rv6[i];
1426	}
1427	/* L560: */
1428	}
1429
1430	L580:
1431	;
1432	}
1433	/* .......... BACK SUBSTITUTION */
1434	/* FOR I=N STEP -1 UNTIL 1 DO -- .......... */
1435	L600:
1436	i_2 = *n;
1437	for (ii = 1; ii <= i_2; ++ii) {
1438	i = *n + 1 - ii;
1439	maxj = min(ii,m21);
1440	if (maxj == 1) {
1441	goto L620;
1442	}
1443	ij1 = i;
1444	j = ij1 + *n;
1445	jj = j + (maxj - 2) * *n;
1446
1447	i_5 = jj;
1448	i_4 = *n;
1449	for (ij = j; i_4 < 0 ? ij >= i_5 : ij <= i_5; ij += i_4) {
1450	++ij1;
1451	rv6[i] -= rv[ij] * rv6[ij1];
1452	/* L610: */
1453	}
1454
1455	L620:
1456	v = rv[i];
1457	if (abs(v) >= eps3) {
1458	goto L625;
1459	}
1460	/* .......... SET ERROR -- NEARLY SINGULAR LINEAR SYSTEM .....
1461	..... */
1462	if (order == 0.) {
1463	*ierr = -r;
1464	}
1465	v = d_sign(&eps3, &v);
1466	L625:
1467	rv6[i] /= v;
1468	/* L630: */
1469	}
1470
1471	xu = 1.;
1472	if (order == 0.) {
1473	goto L870;
1474	}
1475	/* .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS */
1476	/* MEMBERS OF GROUP .......... */
1477	if (group == 0) {
1478	goto L700;
1479	}
1480
1481	i_2 = group;
1482	for (jj = 1; jj <= i_2; ++jj) {
1483	j = r - group - 1 + jj;
1484	xu = 0.;
1485
1486	i_4 = *n;
1487	for (i = 1; i <= i_4; ++i) {
1488	/* L640: */
1489	xu += rv6[i] * z[i + j * z_dim1];
1490	}
1491
1492	i_4 = *n;
1493	for (i = 1; i <= i_4; ++i) {
1494	/* L660: */
1495	rv6[i] -= xu * z[i + j * z_dim1];
1496	}
1497
1498	/* L680: */
1499	}
1500
1501	L700:
1502	norm = 0.;
1503
1504	i_2 = *n;
1505	for (i = 1; i <= i_2; ++i) {
1506	/* L720: */
1507	norm += (d_1 = rv6[i], abs(d_1));
1508	}
1509
1510	if (norm >= .1) {
1511	goto L840;
1512	}
1513	/* .......... IN-LINE PROCEDURE FOR CHOOSING */
1514	/* A NEW STARTING VECTOR .......... */
1515	if (its >= *n) {
1516	goto L830;
1517	}
1518	++its;
1519	xu = eps4 / (uk + 1.);
1520	rv6[1] = eps4;
1521
1522	i_2 = *n;
1523	for (i = 2; i <= i_2; ++i) {
1524	/* L760: */
1525	rv6[i] = xu;
1526	}
1527
1528	rv6[its] -= eps4 * uk;
1529	goto L600;
1530	/* .......... SET ERROR -- NON-CONVERGED EIGENVECTOR .......... */
1531	L830:
1532	*ierr = -r;
1533	xu = 0.;
1534	goto L870;
1535	/* .......... NORMALIZE SO THAT SUM OF SQUARES IS */
1536	/* 1 AND EXPAND TO FULL ORDER .......... */
1537	L840:
1538	u = 0.;
1539
1540	i_2 = *n;
1541	for (i = 1; i <= i_2; ++i) {
1542	/* L860: */
1543	u = pythag_(&u, &rv6[i]);
1544	}
1545
1546	xu = 1. / u;
1547
1548	L870:
1549	i_2 = *n;
1550	for (i = 1; i <= i_2; ++i) {
1551	/* L900: */
1552	z[i + r * z_dim1] = rv6[i] * xu;
1553	}
1554
1555	x0 = x1;
1556	/* L920: */
1557	}
1558
1559	L1001:
1560	return 0;
1561	} /* bandv_ */
1562
1563	/* Subroutine / int bisect_(integer n, doublereal eps1, doublereal d,
1564	doublereal e, doublereal e2, doublereal lb, doublereal ub,
1565	integer mm, integer m, doublereal w, integer ind, integer *ierr,
1566	doublereal rv4, doublereal rv5)
1567	{
1568	/* System generated locals */
1569	integer i_1, i_2;
1570	doublereal d_1, d_2, d_3;
1571
1572	/* Local variables */
1573	static integer i, j, k, l, p, q, r, s;
1574	static doublereal u, v;
1575	static integer m1, m2;
1576	static doublereal t1, t2, x0, x1;
1577	static integer ii;
1578	static doublereal xu;
1579	extern doublereal epslon_(doublereal *);
1580	static integer isturm, tag;
1581	static doublereal tst1, tst2;
1582
1583
1584
1585	/* THIS SUBROUTINE IS A TRANSLATION OF THE BISECTION TECHNIQUE */
1586	/* IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON. */
1587	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). */
1588
1589	/* THIS SUBROUTINE FINDS THOSE EIGENVALUES OF A TRIDIAGONAL */
1590	/* SYMMETRIC MATRIX WHICH LIE IN A SPECIFIED INTERVAL, */
1591	/* USING BISECTION. */
1592
1593	/* ON INPUT */
1594
1595	/* N IS THE ORDER OF THE MATRIX. */
1596
1597	/* EPS1 IS AN ABSOLUTE ERROR TOLERANCE FOR THE COMPUTED */
1598	/* EIGENVALUES. IF THE INPUT EPS1 IS NON-POSITIVE, */
1599	/* IT IS RESET FOR EACH SUBMATRIX TO A DEFAULT VALUE, */
1600	/* NAMELY, MINUS THE PRODUCT OF THE RELATIVE MACHINE */
1601	/* PRECISION AND THE 1-NORM OF THE SUBMATRIX. */
1602
1603	/* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */
1604
1605	/* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */
1606	/* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */
1607
1608	/* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */
1609	/* E2(1) IS ARBITRARY. */
1610
1611	/* LB AND UB DEFINE THE INTERVAL TO BE SEARCHED FOR EIGENVALUES. */
1612	/* IF LB IS NOT LESS THAN UB, NO EIGENVALUES WILL BE FOUND. */
1613
1614	/* MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF */
1615	/* EIGENVALUES IN THE INTERVAL. WARNING. IF MORE THAN */
1616	/* MM EIGENVALUES ARE DETERMINED TO LIE IN THE INTERVAL, */
1617	/* AN ERROR RETURN IS MADE WITH NO EIGENVALUES FOUND. */
1618
1619	/* ON OUTPUT */
1620
1621	/* EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS */
1622	/* (LAST) DEFAULT VALUE. */
1623
1624	/* D AND E ARE UNALTERED. */
1625
1626	/* ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED */
1627	/* AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE */
1628	/* MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES. */
1629	/* E2(1) IS ALSO SET TO ZERO. */
1630
1631	/* M IS THE NUMBER OF EIGENVALUES DETERMINED TO LIE IN (LB,UB). */
1632
1633	/* W CONTAINS THE M EIGENVALUES IN ASCENDING ORDER. */
1634
1635	/* IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES */
1636	/* ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W -- */
1637	/* 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM */
1638	/* THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC..
1639	*/
1640
1641	/* IERR IS SET TO */
1642	/* ZERO FOR NORMAL RETURN, */
1643	/* 3N+1 IF M EXCEEDS MM. /
1644
1645	/* RV4 AND RV5 ARE TEMPORARY STORAGE ARRAYS. */
1646
1647	/* THE ALGOL PROCEDURE STURMCNT CONTAINED IN TRISTURM */
1648	/* APPEARS IN BISECT IN-LINE. */
1649
1650	/* NOTE THAT SUBROUTINE TQL1 OR IMTQL1 IS GENERALLY FASTER THAN */
1651	/* BISECT, IF MORE THAN N/4 EIGENVALUES ARE TO BE FOUND. */
1652
1653	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
1654	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
1655	*/
1656
1657	/* THIS VERSION DATED AUGUST 1983. */
1658
1659	/* ------------------------------------------------------------------
1660	*/
1661
1662	/* Parameter adjustments */
1663	--rv5;
1664	--rv4;
1665	--e2;
1666	--e;
1667	--d;
1668	--ind;
1669	--w;
1670
1671	/* Function Body */
1672	*ierr = 0;
1673	tag = 0;
1674	t1 = *lb;
1675	t2 = *ub;
1676	/* .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES .......... */
1677	i_1 = *n;
1678	for (i = 1; i <= i_1; ++i) {
1679	if (i == 1) {
1680	goto L20;
1681	}
1682	tst1 = (d_1 = d[i], abs(d_1)) + (d_2 = d[i - 1], abs(d_2));
1683	tst2 = tst1 + (d_1 = e[i], abs(d_1));
1684	if (tst2 > tst1) {
1685	goto L40;
1686	}
1687	L20:
1688	e2[i] = 0.;
1689	L40:
1690	;
1691	}
1692	/* .......... DETERMINE THE NUMBER OF EIGENVALUES */
1693	/* IN THE INTERVAL .......... */
1694	p = 1;
1695	q = *n;
1696	x1 = *ub;
1697	isturm = 1;
1698	goto L320;
1699	L60:
1700	*m = s;
1701	x1 = *lb;
1702	isturm = 2;
1703	goto L320;
1704	L80:
1705	*m -= s;
1706	if (m > mm) {
1707	goto L980;
1708	}
1709	q = 0;
1710	r = 0;
1711	/* .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING */
1712	/* INTERVAL BY THE GERSCHGORIN BOUNDS .......... */
1713	L100:
1714	if (r == *m) {
1715	goto L1001;
1716	}
1717	++tag;
1718	p = q + 1;
1719	xu = d[p];
1720	x0 = d[p];
1721	u = 0.;
1722
1723	i_1 = *n;
1724	for (q = p; q <= i_1; ++q) {
1725	x1 = u;
1726	u = 0.;
1727	v = 0.;
1728	if (q == *n) {
1729	goto L110;
1730	}
1731	u = (d_1 = e[q + 1], abs(d_1));
1732	v = e2[q + 1];
1733	L110:
1734	/* Computing MIN */
1735	d_1 = d[q] - (x1 + u);
1736	xu = min(d_1,xu);
1737	/* Computing MAX */
1738	d_1 = d[q] + (x1 + u);
1739	x0 = max(d_1,x0);
1740	if (v == 0.) {
1741	goto L140;
1742	}
1743	/* L120: */
1744	}
1745
1746	L140:
1747	/* Computing MAX */
1748	d_2 = abs(xu), d_3 = abs(x0);
1749	d_1 = max(d_2,d_3);
1750	x1 = epslon_(&d_1);
1751	if (*eps1 <= 0.) {
1752	*eps1 = -x1;
1753	}
1754	if (p != q) {
1755	goto L180;
1756	}
1757	/* .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL .......... */
1758	if (t1 > d[p] \|\| d[p] >= t2) {
1759	goto L940;
1760	}
1761	m1 = p;
1762	m2 = p;
1763	rv5[p] = d[p];
1764	goto L900;
1765	L180:
1766	x1 *= q - p + 1;
1767	/* Computing MAX */
1768	d_1 = t1, d_2 = xu - x1;
1769	*lb = max(d_1,d_2);
1770	/* Computing MIN */
1771	d_1 = t2, d_2 = x0 + x1;
1772	*ub = min(d_1,d_2);
1773	x1 = *lb;
1774	isturm = 3;
1775	goto L320;
1776	L200:
1777	m1 = s + 1;
1778	x1 = *ub;
1779	isturm = 4;
1780	goto L320;
1781	L220:
1782	m2 = s;
1783	if (m1 > m2) {
1784	goto L940;
1785	}
1786	/* .......... FIND ROOTS BY BISECTION .......... */
1787	x0 = *ub;
1788	isturm = 5;
1789
1790	i_1 = m2;
1791	for (i = m1; i <= i_1; ++i) {
1792	rv5[i] = *ub;
1793	rv4[i] = *lb;
1794	/* L240: */
1795	}
1796	/* .......... LOOP FOR K-TH EIGENVALUE */
1797	/* FOR K=M2 STEP -1 UNTIL M1 DO -- */
1798	/* (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) ..........
1799	*/
1800	k = m2;
1801	L250:
1802	xu = *lb;
1803	/* .......... FOR I=K STEP -1 UNTIL M1 DO -- .......... */
1804	i_1 = k;
1805	for (ii = m1; ii <= i_1; ++ii) {
1806	i = m1 + k - ii;
1807	if (xu >= rv4[i]) {
1808	goto L260;
1809	}
1810	xu = rv4[i];
1811	goto L280;
1812	L260:
1813	;
1814	}
1815
1816	L280:
1817	if (x0 > rv5[k]) {
1818	x0 = rv5[k];
1819	}
1820	/* .......... NEXT BISECTION STEP .......... */
1821	L300:
1822	x1 = (xu + x0) * .5;
1823	if (x0 - xu <= abs(*eps1)) {
1824	goto L420;
1825	}
1826	tst1 = (abs(xu) + abs(x0)) * 2.;
1827	tst2 = tst1 + (x0 - xu);
1828	if (tst2 == tst1) {
1829	goto L420;
1830	}
1831	/* .......... IN-LINE PROCEDURE FOR STURM SEQUENCE .......... */
1832	L320:
1833	s = p - 1;
1834	u = 1.;
1835
1836	i_1 = q;
1837	for (i = p; i <= i_1; ++i) {
1838	if (u != 0.) {
1839	goto L325;
1840	}
1841	v = (d_1 = e[i], abs(d_1)) / epslon_(&c_b141);
1842	if (e2[i] == 0.) {
1843	v = 0.;
1844	}
1845	goto L330;
1846	L325:
1847	v = e2[i] / u;
1848	L330:
1849	u = d[i] - x1 - v;
1850	if (u < 0.) {
1851	++s;
1852	}
1853	/* L340: */
1854	}
1855
1856	switch (isturm) {
1857	case 1: goto L60;
1858	case 2: goto L80;
1859	case 3: goto L200;
1860	case 4: goto L220;
1861	case 5: goto L360;
1862	}
1863	/* .......... REFINE INTERVALS .......... */
1864	L360:
1865	if (s >= k) {
1866	goto L400;
1867	}
1868	xu = x1;
1869	if (s >= m1) {
1870	goto L380;
1871	}
1872	rv4[m1] = x1;
1873	goto L300;
1874	L380:
1875	rv4[s + 1] = x1;
1876	if (rv5[s] > x1) {
1877	rv5[s] = x1;
1878	}
1879	goto L300;
1880	L400:
1881	x0 = x1;
1882	goto L300;
1883	/* .......... K-TH EIGENVALUE FOUND .......... */
1884	L420:
1885	rv5[k] = x1;
1886	--k;
1887	if (k >= m1) {
1888	goto L250;
1889	}
1890	/* .......... ORDER EIGENVALUES TAGGED WITH THEIR */
1891	/* SUBMATRIX ASSOCIATIONS .......... */
1892	L900:
1893	s = r;
1894	r = r + m2 - m1 + 1;
1895	j = 1;
1896	k = m1;
1897
1898	i_1 = r;
1899	for (l = 1; l <= i_1; ++l) {
1900	if (j > s) {
1901	goto L910;
1902	}
1903	if (k > m2) {
1904	goto L940;
1905	}
1906	if (rv5[k] >= w[l]) {
1907	goto L915;
1908	}
1909
1910	i_2 = s;
1911	for (ii = j; ii <= i_2; ++ii) {
1912	i = l + s - ii;
1913	w[i + 1] = w[i];
1914	ind[i + 1] = ind[i];
1915	/* L905: */
1916	}
1917
1918	L910:
1919	w[l] = rv5[k];
1920	ind[l] = tag;
1921	++k;
1922	goto L920;
1923	L915:
1924	++j;
1925	L920:
1926	;
1927	}
1928
1929	L940:
1930	if (q < *n) {
1931	goto L100;
1932	}
1933	goto L1001;
1934	/* .......... SET ERROR -- UNDERESTIMATE OF NUMBER OF */
1935	/* EIGENVALUES IN INTERVAL .......... */
1936	L980:
1937	ierr = n * 3 + 1;
1938	L1001:
1939	*lb = t1;
1940	*ub = t2;
1941	return 0;
1942	} /* bisect_ */
1943
1944	/* Subroutine / int bqr_(integer nm, integer n, integer mb, doublereal *a,
1945	doublereal t, doublereal r, integer ierr, integer /nv/, doublereal
1946	*rv)
1947	{
1948	/* System generated locals */
1949	integer a_dim1, a_offset, i_1, i_2, i_3;
1950	doublereal d_1;
1951
1952	/* Builtin functions */
1953	double d_sign(doublereal , doublereal ), sqrt(doublereal);
1954
1955	/* Local variables */
1956	static doublereal f, g;
1957	static integer i, j, k, l, m;
1958	static doublereal q, s, scale;
1959	static integer imult, m1, m2, m3, m4, m21, m31, ii, ik, jk, kj, jm, kk,
1960	km, ll, mk, mn, ni, mz;
1961	extern doublereal pythag_(doublereal , doublereal );
1962	static integer kj1, its;
1963	static doublereal tst1, tst2;
1964
1965
1966
1967	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BQR, */
1968	/* NUM. MATH. 16, 85-92(1970) BY MARTIN, REINSCH, AND WILKINSON. */
1969	/* HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 266-272(1971). */
1970
1971	/* THIS SUBROUTINE FINDS THE EIGENVALUE OF SMALLEST (USUALLY) */
1972	/* MAGNITUDE OF A REAL SYMMETRIC BAND MATRIX USING THE */
1973	/* QR ALGORITHM WITH SHIFTS OF ORIGIN. CONSECUTIVE CALLS */
1974	/* CAN BE MADE TO FIND FURTHER EIGENVALUES. */
1975
1976	/* ON INPUT */
1977
1978	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
1979	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
1980	/* DIMENSION STATEMENT. */
1981
1982	/* N IS THE ORDER OF THE MATRIX. */
1983
1984	/* MB IS THE (HALF) BAND WIDTH OF THE MATRIX, DEFINED AS THE */
1985	/* NUMBER OF ADJACENT DIAGONALS, INCLUDING THE PRINCIPAL */
1986	/* DIAGONAL, REQUIRED TO SPECIFY THE NON-ZERO PORTION OF THE */
1987	/* LOWER TRIANGLE OF THE MATRIX. */
1988
1989	/* A CONTAINS THE LOWER TRIANGLE OF THE SYMMETRIC BAND INPUT */
1990	/* MATRIX STORED AS AN N BY MB ARRAY. ITS LOWEST SUBDIAGONAL */
1991	/* IS STORED IN THE LAST N+1-MB POSITIONS OF THE FIRST COLUMN, */
1992	/* ITS NEXT SUBDIAGONAL IN THE LAST N+2-MB POSITIONS OF THE */
1993	/* SECOND COLUMN, FURTHER SUBDIAGONALS SIMILARLY, AND FINALLY */
1994	/* ITS PRINCIPAL DIAGONAL IN THE N POSITIONS OF THE LAST COLUMN.
1995	*/
1996	/* CONTENTS OF STORAGES NOT PART OF THE MATRIX ARE ARBITRARY. */
1997	/* ON A SUBSEQUENT CALL, ITS OUTPUT CONTENTS FROM THE PREVIOUS */
1998	/* CALL SHOULD BE PASSED. */
1999
2000	/* T SPECIFIES THE SHIFT (OF EIGENVALUES) APPLIED TO THE DIAGONAL
2001	*/
2002	/* OF A IN FORMING THE INPUT MATRIX. WHAT IS ACTUALLY DETERMINED
2003	*/
2004	/* IS THE EIGENVALUE OF A+TI (I IS THE IDENTITY MATRIX) NEAREST
2005	*/
2006	/* TO T. ON A SUBSEQUENT CALL, THE OUTPUT VALUE OF T FROM THE */
2007	/* PREVIOUS CALL SHOULD BE PASSED IF THE NEXT NEAREST EIGENVALUE
2008	*/
2009	/* IS SOUGHT. */
2010
2011	/* R SHOULD BE SPECIFIED AS ZERO ON THE FIRST CALL, AND AS ITS */
2012	/* OUTPUT VALUE FROM THE PREVIOUS CALL ON A SUBSEQUENT CALL. */
2013	/* IT IS USED TO DETERMINE WHEN THE LAST ROW AND COLUMN OF */
2014	/* THE TRANSFORMED BAND MATRIX CAN BE REGARDED AS NEGLIGIBLE. */
2015
2016	/* NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER RV */
2017	/* AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT. */
2018
2019	/* ON OUTPUT */
2020
2021	/* A CONTAINS THE TRANSFORMED BAND MATRIX. THE MATRIX A+TI */
2022	/* DERIVED FROM THE OUTPUT PARAMETERS IS SIMILAR TO THE */
2023	/* INPUT A+TI TO WITHIN ROUNDING ERRORS. ITS LAST ROW AND */
2024	/* COLUMN ARE NULL (IF IERR IS ZERO). */
2025
2026	/* T CONTAINS THE COMPUTED EIGENVALUE OF A+TI (IF IERR IS ZERO). */
2027
2028	/* R CONTAINS THE MAXIMUM OF ITS INPUT VALUE AND THE NORM OF THE */
2029	/* LAST COLUMN OF THE INPUT MATRIX A. */
2030
2031	/* IERR IS SET TO */
2032	/* ZERO FOR NORMAL RETURN, */
2033	/* N IF THE EIGENVALUE HAS NOT BEEN */
2034	/* DETERMINED AFTER 30 ITERATIONS. */
2035
2036	/* RV IS A TEMPORARY STORAGE ARRAY OF DIMENSION AT LEAST */
2037	/* (2MB2+4MB-3). THE FIRST (3MB-2) LOCATIONS CORRESPOND /
2038	/* TO THE ALGOL ARRAY B, THE NEXT (2*MB-1) LOCATIONS CORRESPOND
2039	*/
2040	/* TO THE ALGOL ARRAY H, AND THE FINAL (2MB2-MB) LOCATIONS /
2041	/* CORRESPOND TO THE MB BY (2MB-1) ALGOL ARRAY U. /
2042
2043	/* NOTE. FOR A SUBSEQUENT CALL, N SHOULD BE REPLACED BY N-1, BUT */
2044	/* MB SHOULD NOT BE ALTERED EVEN WHEN IT EXCEEDS THE CURRENT N. */
2045
2046	/* CALLS PYTHAG FOR DSQRT(AA + BB) . */
2047
2048	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
2049	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
2050	*/
2051
2052	/* THIS VERSION DATED AUGUST 1983. */
2053
2054	/* ------------------------------------------------------------------
2055	*/
2056
2057	/* Parameter adjustments */
2058	a_dim1 = *nm;
2059	a_offset = a_dim1 + 1;
2060	a -= a_offset;
2061	--rv;
2062
2063	/* Function Body */
2064	*ierr = 0;
2065	m1 = min(mb,n);
2066	m = m1 - 1;
2067	m2 = m + m;
2068	m21 = m2 + 1;
2069	m3 = m21 + m;
2070	m31 = m3 + 1;
2071	m4 = m31 + m2;
2072	mn = m + *n;
2073	mz = *mb - m1;
2074	its = 0;
2075	/* .......... TEST FOR CONVERGENCE .......... */
2076	L40:
2077	g = a[n + mb * a_dim1];
2078	if (m == 0) {
2079	goto L360;
2080	}
2081	f = 0.;
2082
2083	i_1 = m;
2084	for (k = 1; k <= i_1; ++k) {
2085	mk = k + mz;
2086	f += (d_1 = a[n + mk a_dim1], abs(d_1));
2087	/* L50: */
2088	}
2089
2090	if (its == 0 && f > *r) {
2091	*r = f;
2092	}
2093	tst1 = *r;
2094	tst2 = tst1 + f;
2095	if (tst2 <= tst1) {
2096	goto L360;
2097	}
2098	if (its == 30) {
2099	goto L1000;
2100	}
2101	++its;
2102	/* .......... FORM SHIFT FROM BOTTOM 2 BY 2 MINOR .......... */
2103	if (f > r .25 && its < 5) {
2104	goto L90;
2105	}
2106	f = a[n + (mb - 1) * a_dim1];
2107	if (f == 0.) {
2108	goto L70;
2109	}
2110	q = (a[n - 1 + mb * a_dim1] - g) / (f * 2.);
2111	s = pythag_(&q, &c_b141);
2112	g -= f / (q + d_sign(&s, &q));
2113	L70:
2114	*t += g;
2115
2116	i_1 = *n;
2117	for (i = 1; i <= i_1; ++i) {
2118	/* L80: */
2119	a[i + mb a_dim1] -= g;
2120	}
2121
2122	L90:
2123	i_1 = m4;
2124	for (k = m31; k <= i_1; ++k) {
2125	/* L100: */
2126	rv[k] = 0.;
2127	}
2128
2129	i_1 = mn;
2130	for (ii = 1; ii <= i_1; ++ii) {
2131	i = ii - m;
2132	ni = *n - ii;
2133	if (ni < 0) {
2134	goto L230;
2135	}
2136	/* .......... FORM COLUMN OF SHIFTED MATRIX A-GI .......... /
2137	/* Computing MAX */
2138	i_2 = 1, i_3 = 2 - i;
2139	l = max(i_2,i_3);
2140
2141	i_2 = m3;
2142	for (k = 1; k <= i_2; ++k) {
2143	/* L110: */
2144	rv[k] = 0.;
2145	}
2146
2147	i_2 = m1;
2148	for (k = l; k <= i_2; ++k) {
2149	km = k + m;
2150	mk = k + mz;
2151	rv[km] = a[ii + mk * a_dim1];
2152	/* L120: */
2153	}
2154
2155	ll = min(m,ni);
2156	if (ll == 0) {
2157	goto L135;
2158	}
2159
2160	i_2 = ll;
2161	for (k = 1; k <= i_2; ++k) {
2162	km = k + m21;
2163	ik = ii + k;
2164	mk = *mb - k;
2165	rv[km] = a[ik + mk * a_dim1];
2166	/* L130: */
2167	}
2168	/* .......... PRE-MULTIPLY WITH HOUSEHOLDER REFLECTIONS ..........
2169	*/
2170	L135:
2171	ll = m2;
2172	imult = 0;
2173	/* .......... MULTIPLICATION PROCEDURE .......... */
2174	L140:
2175	kj = m4 - m1;
2176
2177	i_2 = ll;
2178	for (j = 1; j <= i_2; ++j) {
2179	kj += m1;
2180	jm = j + m3;
2181	if (rv[jm] == 0.) {
2182	goto L170;
2183	}
2184	f = 0.;
2185
2186	i_3 = m1;
2187	for (k = 1; k <= i_3; ++k) {
2188	++kj;
2189	jk = j + k - 1;
2190	f += rv[kj] * rv[jk];
2191	/* L150: */
2192	}
2193
2194	f /= rv[jm];
2195	kj -= m1;
2196
2197	i_3 = m1;
2198	for (k = 1; k <= i_3; ++k) {
2199	++kj;
2200	jk = j + k - 1;
2201	rv[jk] -= rv[kj] * f;
2202	/* L160: */
2203	}
2204
2205	kj -= m1;
2206	L170:
2207	;
2208	}
2209
2210	if (imult != 0) {
2211	goto L280;
2212	}
2213	/* .......... HOUSEHOLDER REFLECTION .......... */
2214	f = rv[m21];
2215	s = 0.;
2216	rv[m4] = 0.;
2217	scale = 0.;
2218
2219	i_2 = m3;
2220	for (k = m21; k <= i_2; ++k) {
2221	/* L180: */
2222	scale += (d_1 = rv[k], abs(d_1));
2223	}
2224
2225	if (scale == 0.) {
2226	goto L210;
2227	}
2228
2229	i_2 = m3;
2230	for (k = m21; k <= i_2; ++k) {
2231	/* L190: */
2232	/* Computing 2nd power */
2233	d_1 = rv[k] / scale;
2234	s += d_1 * d_1;
2235	}
2236
2237	s = scale * scale * s;
2238	d_1 = sqrt(s);
2239	g = -d_sign(&d_1, &f);
2240	rv[m21] = g;
2241	rv[m4] = s - f * g;
2242	kj = m4 + m2 * m1 + 1;
2243	rv[kj] = f - g;
2244
2245	i_2 = m1;
2246	for (k = 2; k <= i_2; ++k) {
2247	++kj;
2248	km = k + m2;
2249	rv[kj] = rv[km];
2250	/* L200: */
2251	}
2252	/* .......... SAVE COLUMN OF TRIANGULAR FACTOR R .......... */
2253	L210:
2254	i_2 = m1;
2255	for (k = l; k <= i_2; ++k) {
2256	km = k + m;
2257	mk = k + mz;
2258	a[ii + mk * a_dim1] = rv[km];
2259	/* L220: */
2260	}
2261
2262	L230:
2263	/* Computing MAX */
2264	i_2 = 1, i_3 = m1 + 1 - i;
2265	l = max(i_2,i_3);
2266	if (i <= 0) {
2267	goto L300;
2268	}
2269	/* .......... PERFORM ADDITIONAL STEPS .......... */
2270	i_2 = m21;
2271	for (k = 1; k <= i_2; ++k) {
2272	/* L240: */
2273	rv[k] = 0.;
2274	}
2275
2276	/* Computing MIN */
2277	i_2 = m1, i_3 = ni + m1;
2278	ll = min(i_2,i_3);
2279	/* .......... GET ROW OF TRIANGULAR FACTOR R .......... */
2280	i_2 = ll;
2281	for (kk = 1; kk <= i_2; ++kk) {
2282	k = kk - 1;
2283	km = k + m1;
2284	ik = i + k;
2285	mk = *mb - k;
2286	rv[km] = a[ik + mk * a_dim1];
2287	/* L250: */
2288	}
2289	/* .......... POST-MULTIPLY WITH HOUSEHOLDER REFLECTIONS .........
2290	. */
2291	ll = m1;
2292	imult = 1;
2293	goto L140;
2294	/* .......... STORE COLUMN OF NEW A MATRIX .......... */
2295	L280:
2296	i_2 = m1;
2297	for (k = l; k <= i_2; ++k) {
2298	mk = k + mz;
2299	a[i + mk * a_dim1] = rv[k];
2300	/* L290: */
2301	}
2302	/* .......... UPDATE HOUSEHOLDER REFLECTIONS .......... */
2303	L300:
2304	if (l > 1) {
2305	--l;
2306	}
2307	kj1 = m4 + l * m1;
2308
2309	i_2 = m2;
2310	for (j = l; j <= i_2; ++j) {
2311	jm = j + m3;
2312	rv[jm] = rv[jm + 1];
2313
2314	i_3 = m1;
2315	for (k = 1; k <= i_3; ++k) {
2316	++kj1;
2317	kj = kj1 - m1;
2318	rv[kj] = rv[kj1];
2319	/* L320: */
2320	}
2321	}
2322
2323	/* L350: */
2324	}
2325
2326	goto L40;
2327	/* .......... CONVERGENCE .......... */
2328	L360:
2329	*t += g;
2330
2331	i_1 = *n;
2332	for (i = 1; i <= i_1; ++i) {
2333	/* L380: */
2334	a[i + mb a_dim1] -= g;
2335	}
2336
2337	i_1 = m1;
2338	for (k = 1; k <= i_1; ++k) {
2339	mk = k + mz;
2340	a[n + mk a_dim1] = 0.;
2341	/* L400: */
2342	}
2343
2344	goto L1001;
2345	/* .......... SET ERROR -- NO CONVERGENCE TO */
2346	/* EIGENVALUE AFTER 30 ITERATIONS .......... */
2347	L1000:
2348	ierr = n;
2349	L1001:
2350	return 0;
2351	} /* bqr_ */
2352
2353	/* Subroutine / int cbabk2_(integer nm, integer n, integer low, integer *
2354	igh, doublereal scale, integer m, doublereal zr, doublereal zi)
2355	{
2356	/* System generated locals */
2357	integer zr_dim1, zr_offset, zi_dim1, zi_offset, i_1, i_2;
2358
2359	/* Local variables */
2360	static integer i, j, k;
2361	static doublereal s;
2362	static integer ii;
2363
2364
2365
2366	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE */
2367	/* CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK, */
2368	/* NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. */
2369	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). */
2370
2371	/* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL */
2372	/* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */
2373	/* BALANCED MATRIX DETERMINED BY CBAL. */
2374
2375	/* ON INPUT */
2376
2377	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
2378	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
2379	/* DIMENSION STATEMENT. */
2380
2381	/* N IS THE ORDER OF THE MATRIX. */
2382
2383	/* LOW AND IGH ARE INTEGERS DETERMINED BY CBAL. */
2384
2385	/* SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS */
2386	/* AND SCALING FACTORS USED BY CBAL. */
2387
2388	/* M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. */
2389
2390	/* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */
2391	/* RESPECTIVELY, OF THE EIGENVECTORS TO BE */
2392	/* BACK TRANSFORMED IN THEIR FIRST M COLUMNS. */
2393
2394	/* ON OUTPUT */
2395
2396	/* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */
2397	/* RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS */
2398	/* IN THEIR FIRST M COLUMNS. */
2399
2400	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
2401	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
2402	*/
2403
2404	/* THIS VERSION DATED AUGUST 1983. */
2405
2406	/* ------------------------------------------------------------------
2407	*/
2408
2409	/* Parameter adjustments */
2410	--scale;
2411	zi_dim1 = *nm;
2412	zi_offset = zi_dim1 + 1;
2413	zi -= zi_offset;
2414	zr_dim1 = *nm;
2415	zr_offset = zr_dim1 + 1;
2416	zr -= zr_offset;
2417
2418	/* Function Body */
2419	if (*m == 0) {
2420	goto L200;
2421	}
2422	if (igh == low) {
2423	goto L120;
2424	}
2425
2426	i_1 = *igh;
2427	for (i = *low; i <= i_1; ++i) {
2428	s = scale[i];
2429	/* .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED */
2430	/* IF THE FOREGOING STATEMENT IS REPLACED BY */
2431	/* S=1.0D0/SCALE(I). .......... */
2432	i_2 = *m;
2433	for (j = 1; j <= i_2; ++j) {
2434	zr[i + j * zr_dim1] *= s;
2435	zi[i + j * zi_dim1] *= s;
2436	/* L100: */
2437	}
2438
2439	/* L110: */
2440	}
2441	/* .......... FOR I=LOW-1 STEP -1 UNTIL 1, */
2442	/* IGH+1 STEP 1 UNTIL N DO -- .......... */
2443	L120:
2444	i_1 = *n;
2445	for (ii = 1; ii <= i_1; ++ii) {
2446	i = ii;
2447	if (i >= low && i <= igh) {
2448	goto L140;
2449	}
2450	if (i < *low) {
2451	i = *low - ii;
2452	}
2453	k = (integer) scale[i];
2454	if (k == i) {
2455	goto L140;
2456	}
2457
2458	i_2 = *m;
2459	for (j = 1; j <= i_2; ++j) {
2460	s = zr[i + j * zr_dim1];
2461	zr[i + j * zr_dim1] = zr[k + j * zr_dim1];
2462	zr[k + j * zr_dim1] = s;
2463	s = zi[i + j * zi_dim1];
2464	zi[i + j * zi_dim1] = zi[k + j * zi_dim1];
2465	zi[k + j * zi_dim1] = s;
2466	/* L130: */
2467	}
2468
2469	L140:
2470	;
2471	}
2472
2473	L200:
2474	return 0;
2475	} /* cbabk2_ */
2476
2477	/* Subroutine / int cbal_(integer nm, integer n, doublereal ar,
2478	doublereal ai, integer low, integer igh, doublereal scale)
2479	{
2480	/* System generated locals */
2481	integer ar_dim1, ar_offset, ai_dim1, ai_offset, i_1, i_2;
2482	doublereal d_1, d_2;
2483
2484	/* Local variables */
2485	static integer iexc;
2486	static doublereal c, f, g;
2487	static integer i, j, k, l, m;
2488	static doublereal r, s, radix, b2;
2489	static integer jj;
2490	static logical noconv;
2491
2492
2493
2494	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE */
2495	/* CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE, */
2496	/* NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. */
2497	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). */
2498
2499	/* THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES */
2500	/* EIGENVALUES WHENEVER POSSIBLE. */
2501
2502	/* ON INPUT */
2503
2504	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
2505	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
2506	/* DIMENSION STATEMENT. */
2507
2508	/* N IS THE ORDER OF THE MATRIX. */
2509
2510	/* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */
2511	/* RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED. */
2512
2513	/* ON OUTPUT */
2514
2515	/* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */
2516	/* RESPECTIVELY, OF THE BALANCED MATRIX. */
2517
2518	/* LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J) */
2519	/* ARE EQUAL TO ZERO IF */
2520	/* (1) I IS GREATER THAN J AND */
2521	/* (2) J=1,...,LOW-1 OR I=IGH+1,...,N. */
2522
2523	/* SCALE CONTAINS INFORMATION DETERMINING THE */
2524	/* PERMUTATIONS AND SCALING FACTORS USED. */
2525
2526	/* SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH */
2527	/* HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED */
2528	/* WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS */
2529	/* OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN */
2530	/* SCALE(J) = P(J), FOR J = 1,...,LOW-1 */
2531	/* = D(J,J) J = LOW,...,IGH */
2532	/* = P(J) J = IGH+1,...,N. */
2533	/* THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1, */
2534	/* THEN 1 TO LOW-1. */
2535
2536	/* NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY. */
2537
2538	/* THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN */
2539	/* CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS */
2540	/* K,L HAVE BEEN REVERSED.) */
2541
2542	/* ARITHMETIC IS REAL THROUGHOUT. */
2543
2544	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
2545	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
2546	*/
2547
2548	/* THIS VERSION DATED AUGUST 1983. */
2549
2550	/* ------------------------------------------------------------------
2551	*/
2552
2553	/* Parameter adjustments */
2554	--scale;
2555	ai_dim1 = *nm;
2556	ai_offset = ai_dim1 + 1;
2557	ai -= ai_offset;
2558	ar_dim1 = *nm;
2559	ar_offset = ar_dim1 + 1;
2560	ar -= ar_offset;
2561
2562	/* Function Body */
2563	radix = 16.;
2564
2565	b2 = radix * radix;
2566	k = 1;
2567	l = *n;
2568	goto L100;
2569	/* .......... IN-LINE PROCEDURE FOR ROW AND */
2570	/* COLUMN EXCHANGE .......... */
2571	L20:
2572	scale[m] = (doublereal) j;
2573	if (j == m) {
2574	goto L50;
2575	}
2576
2577	i_1 = l;
2578	for (i = 1; i <= i_1; ++i) {
2579	f = ar[i + j * ar_dim1];
2580	ar[i + j * ar_dim1] = ar[i + m * ar_dim1];
2581	ar[i + m * ar_dim1] = f;
2582	f = ai[i + j * ai_dim1];
2583	ai[i + j * ai_dim1] = ai[i + m * ai_dim1];
2584	ai[i + m * ai_dim1] = f;
2585	/* L30: */
2586	}
2587
2588	i_1 = *n;
2589	for (i = k; i <= i_1; ++i) {
2590	f = ar[j + i * ar_dim1];
2591	ar[j + i * ar_dim1] = ar[m + i * ar_dim1];
2592	ar[m + i * ar_dim1] = f;
2593	f = ai[j + i * ai_dim1];
2594	ai[j + i * ai_dim1] = ai[m + i * ai_dim1];
2595	ai[m + i * ai_dim1] = f;
2596	/* L40: */
2597	}
2598
2599	L50:
2600	switch (iexc) {
2601	case 1: goto L80;
2602	case 2: goto L130;
2603	}
2604	/* .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE */
2605	/* AND PUSH THEM DOWN .......... */
2606	L80:
2607	if (l == 1) {
2608	goto L280;
2609	}
2610	--l;
2611	/* .......... FOR J=L STEP -1 UNTIL 1 DO -- .......... */
2612	L100:
2613	i_1 = l;
2614	for (jj = 1; jj <= i_1; ++jj) {
2615	j = l + 1 - jj;
2616
2617	i_2 = l;
2618	for (i = 1; i <= i_2; ++i) {
2619	if (i == j) {
2620	goto L110;
2621	}
2622	if (ar[j + i * ar_dim1] != 0. \|\| ai[j + i * ai_dim1] != 0.) {
2623	goto L120;
2624	}
2625	L110:
2626	;
2627	}
2628
2629	m = l;
2630	iexc = 1;
2631	goto L20;
2632	L120:
2633	;
2634	}
2635
2636	goto L140;
2637	/* .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE */
2638	/* AND PUSH THEM LEFT .......... */
2639	L130:
2640	++k;
2641
2642	L140:
2643	i_1 = l;
2644	for (j = k; j <= i_1; ++j) {
2645
2646	i_2 = l;
2647	for (i = k; i <= i_2; ++i) {
2648	if (i == j) {
2649	goto L150;
2650	}
2651	if (ar[i + j * ar_dim1] != 0. \|\| ai[i + j * ai_dim1] != 0.) {
2652	goto L170;
2653	}
2654	L150:
2655	;
2656	}
2657
2658	m = k;
2659	iexc = 2;
2660	goto L20;
2661	L170:
2662	;
2663	}
2664	/* .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L .......... */
2665	i_1 = l;
2666	for (i = k; i <= i_1; ++i) {
2667	/* L180: */
2668	scale[i] = 1.;
2669	}
2670	/* .......... ITERATIVE LOOP FOR NORM REDUCTION .......... */
2671	L190:
2672	noconv = FALSE_;
2673
2674	i_1 = l;
2675	for (i = k; i <= i_1; ++i) {
2676	c = 0.;
2677	r = 0.;
2678
2679	i_2 = l;
2680	for (j = k; j <= i_2; ++j) {
2681	if (j == i) {
2682	goto L200;
2683	}
2684	c = c + (d_1 = ar[j + i * ar_dim1], abs(d_1)) + (d_2 = ai[j +
2685	i * ai_dim1], abs(d_2));
2686	r = r + (d_1 = ar[i + j * ar_dim1], abs(d_1)) + (d_2 = ai[i +
2687	j * ai_dim1], abs(d_2));
2688	L200:
2689	;
2690	}
2691	/* .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW .........
2692	. */
2693	if (c == 0. \|\| r == 0.) {
2694	goto L270;
2695	}
2696	g = r / radix;
2697	f = 1.;
2698	s = c + r;
2699	L210:
2700	if (c >= g) {
2701	goto L220;
2702	}
2703	f *= radix;
2704	c *= b2;
2705	goto L210;
2706	L220:
2707	g = r * radix;
2708	L230:
2709	if (c < g) {
2710	goto L240;
2711	}
2712	f /= radix;
2713	c /= b2;
2714	goto L230;
2715	/* .......... NOW BALANCE .......... */
2716	L240:
2717	if ((c + r) / f >= s * .95) {
2718	goto L270;
2719	}
2720	g = 1. / f;
2721	scale[i] *= f;
2722	noconv = TRUE_;
2723
2724	i_2 = *n;
2725	for (j = k; j <= i_2; ++j) {
2726	ar[i + j * ar_dim1] *= g;
2727	ai[i + j * ai_dim1] *= g;
2728	/* L250: */
2729	}
2730
2731	i_2 = l;
2732	for (j = 1; j <= i_2; ++j) {
2733	ar[j + i * ar_dim1] *= f;
2734	ai[j + i * ai_dim1] *= f;
2735	/* L260: */
2736	}
2737
2738	L270:
2739	;
2740	}
2741
2742	if (noconv) {
2743	goto L190;
2744	}
2745
2746	L280:
2747	*low = k;
2748	*igh = l;
2749	return 0;
2750	} /* cbal_ */
2751
2752	/* Subroutine / int cg_(integer nm, integer n, doublereal ar, doublereal *
2753	ai, doublereal wr, doublereal wi, integer matz, doublereal zr,
2754	doublereal zi, doublereal fv1, doublereal fv2, doublereal fv3,
2755	integer *ierr)
2756	{
2757	/* System generated locals */
2758	integer ar_dim1, ar_offset, ai_dim1, ai_offset, zr_dim1, zr_offset,
2759	zi_dim1, zi_offset;
2760
2761	/* Local variables */
2762	extern /* Subroutine / int cbal_(integer , integer , doublereal ,
2763	doublereal , integer , integer , doublereal ), corth_(integer
2764	, integer , integer , integer , doublereal , doublereal ,
2765	doublereal , doublereal ), comqr_(integer , integer , integer
2766	, integer , doublereal , doublereal , doublereal *,
2767	doublereal , integer ), cbabk2_(integer , integer , integer *,
2768	integer , doublereal , integer , doublereal , doublereal *),
2769	comqr2_(integer , integer , integer , integer , doublereal *,
2770	doublereal , doublereal , doublereal , doublereal ,
2771	doublereal , doublereal , doublereal , integer );
2772	static integer is1, is2;
2773
2774
2775
2776	/* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */
2777	/* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */
2778	/* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */
2779	/* OF A COMPLEX GENERAL MATRIX. */
2780
2781	/* ON INPUT */
2782
2783	/* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */
2784	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
2785	/* DIMENSION STATEMENT. */
2786
2787	/* N IS THE ORDER OF THE MATRIX A=(AR,AI). */
2788
2789	/* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */
2790	/* RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX. */
2791
2792	/* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */
2793	/* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */
2794	/* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */
2795
2796	/* ON OUTPUT */
2797
2798	/* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, */
2799	/* RESPECTIVELY, OF THE EIGENVALUES. */
2800
2801	/* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */
2802	/* RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO. */
2803
2804	/* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */
2805	/* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR */
2806	/* AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO. */
2807
2808	/* FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS. */
2809
2810	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
2811	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
2812	*/
2813
2814	/* THIS VERSION DATED AUGUST 1983. */
2815
2816	/* ------------------------------------------------------------------
2817	*/
2818
2819	/* Parameter adjustments */
2820	--fv3;
2821	--fv2;
2822	--fv1;
2823	zi_dim1 = *nm;
2824	zi_offset = zi_dim1 + 1;
2825	zi -= zi_offset;
2826	zr_dim1 = *nm;
2827	zr_offset = zr_dim1 + 1;
2828	zr -= zr_offset;
2829	--wi;
2830	--wr;
2831	ai_dim1 = *nm;
2832	ai_offset = ai_dim1 + 1;
2833	ai -= ai_offset;
2834	ar_dim1 = *nm;
2835	ar_offset = ar_dim1 + 1;
2836	ar -= ar_offset;
2837
2838	/* Function Body */
2839	if (n <= nm) {
2840	goto L10;
2841	}
2842	ierr = n * 10;
2843	goto L50;
2844
2845	L10:
2846	cbal_(nm, n, &ar[ar_offset], &ai[ai_offset], &is1, &is2, &fv1[1]);
2847	corth_(nm, n, &is1, &is2, &ar[ar_offset], &ai[ai_offset], &fv2[1], &fv3[1]
2848	);
2849	if (*matz != 0) {
2850	goto L20;
2851	}
2852	/* .......... FIND EIGENVALUES ONLY .......... */
2853	comqr_(nm, n, &is1, &is2, &ar[ar_offset], &ai[ai_offset], &wr[1], &wi[1],
2854	ierr);
2855	goto L50;
2856	/* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */
2857	L20:
2858	comqr2_(nm, n, &is1, &is2, &fv2[1], &fv3[1], &ar[ar_offset], &ai[
2859	ai_offset], &wr[1], &wi[1], &zr[zr_offset], &zi[zi_offset], ierr);
2860	if (*ierr != 0) {
2861	goto L50;
2862	}
2863	cbabk2_(nm, n, &is1, &is2, &fv1[1], n, &zr[zr_offset], &zi[zi_offset]);
2864	L50:
2865	return 0;
2866	} /* cg_ */
2867
2868	/* Subroutine / int ch_(integer nm, integer n, doublereal ar, doublereal *
2869	ai, doublereal w, integer matz, doublereal zr, doublereal zi,
2870	doublereal fv1, doublereal fv2, doublereal fm1, integer ierr)
2871	{
2872	/* System generated locals */
2873	integer ar_dim1, ar_offset, ai_dim1, ai_offset, zr_dim1, zr_offset,
2874	zi_dim1, zi_offset, i_1, i_2;
2875
2876	/* Local variables */
2877	static integer i, j;
2878	extern /* Subroutine / int htridi_(integer , integer , doublereal ,
2879	doublereal , doublereal , doublereal , doublereal ,
2880	doublereal ), htribk_(integer , integer , doublereal ,
2881	doublereal , doublereal , integer , doublereal , doublereal *)
2882	, tqlrat_(integer , doublereal , doublereal , integer ),
2883	tql2_(integer , integer , doublereal , doublereal ,
2884	doublereal , integer );
2885
2886
2887
2888	/* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */
2889	/* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */
2890	/* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */
2891	/* OF A COMPLEX HERMITIAN MATRIX. */
2892
2893	/* ON INPUT */
2894
2895	/* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */
2896	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
2897	/* DIMENSION STATEMENT. */
2898
2899	/* N IS THE ORDER OF THE MATRIX A=(AR,AI). */
2900
2901	/* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */
2902	/* RESPECTIVELY, OF THE COMPLEX HERMITIAN MATRIX. */
2903
2904	/* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */
2905	/* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */
2906	/* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */
2907
2908	/* ON OUTPUT */
2909
2910	/* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */
2911
2912	/* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */
2913	/* RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO. */
2914
2915	/* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */
2916	/* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT */
2917	/* AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. */
2918
2919	/* FV1, FV2, AND FM1 ARE TEMPORARY STORAGE ARRAYS. */
2920
2921	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
2922	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
2923	*/
2924
2925	/* THIS VERSION DATED AUGUST 1983. */
2926
2927	/* ------------------------------------------------------------------
2928	*/
2929
2930	/* Parameter adjustments */
2931	fm1 -= 3;
2932	--fv2;
2933	--fv1;
2934	zi_dim1 = *nm;
2935	zi_offset = zi_dim1 + 1;
2936	zi -= zi_offset;
2937	zr_dim1 = *nm;
2938	zr_offset = zr_dim1 + 1;
2939	zr -= zr_offset;
2940	--w;
2941	ai_dim1 = *nm;
2942	ai_offset = ai_dim1 + 1;
2943	ai -= ai_offset;
2944	ar_dim1 = *nm;
2945	ar_offset = ar_dim1 + 1;
2946	ar -= ar_offset;
2947
2948	/* Function Body */
2949	if (n <= nm) {
2950	goto L10;
2951	}
2952	ierr = n * 10;
2953	goto L50;
2954
2955	L10:
2956	htridi_(nm, n, &ar[ar_offset], &ai[ai_offset], &w[1], &fv1[1], &fv2[1], &
2957	fm1[3]);
2958	if (*matz != 0) {
2959	goto L20;
2960	}
2961	/* .......... FIND EIGENVALUES ONLY .......... */
2962	tqlrat_(n, &w[1], &fv2[1], ierr);
2963	goto L50;
2964	/* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */
2965	L20:
2966	i_1 = *n;
2967	for (i = 1; i <= i_1; ++i) {
2968
2969	i_2 = *n;
2970	for (j = 1; j <= i_2; ++j) {
2971	zr[j + i * zr_dim1] = 0.;
2972	/* L30: */
2973	}
2974
2975	zr[i + i * zr_dim1] = 1.;
2976	/* L40: */
2977	}
2978
2979	tql2_(nm, n, &w[1], &fv1[1], &zr[zr_offset], ierr);
2980	if (*ierr != 0) {
2981	goto L50;
2982	}
2983	htribk_(nm, n, &ar[ar_offset], &ai[ai_offset], &fm1[3], n, &zr[zr_offset],
2984	&zi[zi_offset]);
2985	L50:
2986	return 0;
2987	} /* ch_ */
2988
2989	/* Subroutine / int cinvit_(integer nm, integer n, doublereal ar,
2990	doublereal ai, doublereal wr, doublereal wi, logical select,
2991	integer mm, integer m, doublereal zr, doublereal zi, integer *
2992	ierr, doublereal rm1, doublereal rm2, doublereal rv1, doublereal
2993	rv2)
2994	{
2995	/* System generated locals */
2996	integer ar_dim1, ar_offset, ai_dim1, ai_offset, zr_dim1, zr_offset,
2997	zi_dim1, zi_offset, rm1_dim1, rm1_offset, rm2_dim1, rm2_offset,
2998	i_1, i_2, i_3;
2999	doublereal d_1, d_2;
3000
3001	/* Builtin functions */
3002	double sqrt(doublereal);
3003
3004	/* Local variables */
3005	extern /* Subroutine / int cdiv_(doublereal , doublereal , doublereal
3006	, doublereal , doublereal , doublereal *);
3007	static doublereal norm;
3008	static integer i, j, k, s;
3009	static doublereal x, y, normv;
3010	static integer ii;
3011	static doublereal ilambd;
3012	static integer mp, uk;
3013	static doublereal rlambd;
3014	extern doublereal pythag_(doublereal , doublereal ), epslon_(doublereal
3015	*);
3016	static integer km1, ip1;
3017	static doublereal growto, ukroot;
3018	static integer its;
3019	static doublereal eps3;
3020
3021
3022
3023	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE CX INVIT */
3024	/* BY PETERS AND WILKINSON. */
3025	/* HANDBOOK FOR AUTO. COMP. VOL.II-LINEAR ALGEBRA, 418-439(1971). */
3026
3027	/* THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A COMPLEX UPPER */
3028	/* HESSENBERG MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES, */
3029	/* USING INVERSE ITERATION. */
3030
3031	/* ON INPUT */
3032
3033	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
3034	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
3035	/* DIMENSION STATEMENT. */
3036
3037	/* N IS THE ORDER OF THE MATRIX. */
3038
3039	/* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */
3040	/* RESPECTIVELY, OF THE HESSENBERG MATRIX. */
3041
3042	/* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, RESPECTIVELY, */
3043	/* OF THE EIGENVALUES OF THE MATRIX. THE EIGENVALUES MUST BE */
3044	/* STORED IN A MANNER IDENTICAL TO THAT OF SUBROUTINE COMLR, */
3045	/* WHICH RECOGNIZES POSSIBLE SPLITTING OF THE MATRIX. */
3046
3047	/* SELECT SPECIFIES THE EIGENVECTORS TO BE FOUND. THE */
3048	/* EIGENVECTOR CORRESPONDING TO THE J-TH EIGENVALUE IS */
3049	/* SPECIFIED BY SETTING SELECT(J) TO .TRUE.. */
3050
3051	/* MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF */
3052	/* EIGENVECTORS TO BE FOUND. */
3053
3054	/* ON OUTPUT */
3055
3056	/* AR, AI, WI, AND SELECT ARE UNALTERED. */
3057
3058	/* WR MAY HAVE BEEN ALTERED SINCE CLOSE EIGENVALUES ARE PERTURBED
3059	*/
3060	/* SLIGHTLY IN SEARCHING FOR INDEPENDENT EIGENVECTORS. */
3061
3062	/* M IS THE NUMBER OF EIGENVECTORS ACTUALLY FOUND. */
3063
3064	/* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, RESPECTIVELY, */
3065	/* OF THE EIGENVECTORS. THE EIGENVECTORS ARE NORMALIZED */
3066	/* SO THAT THE COMPONENT OF LARGEST MAGNITUDE IS 1. */
3067	/* ANY VECTOR WHICH FAILS THE ACCEPTANCE TEST IS SET TO ZERO. */
3068
3069	/* IERR IS SET TO */
3070	/* ZERO FOR NORMAL RETURN, */
3071	/* -(2*N+1) IF MORE THAN MM EIGENVECTORS HAVE BEEN SPECIFIED,
3072	*/
3073	/* -K IF THE ITERATION CORRESPONDING TO THE K-TH */
3074	/* VALUE FAILS, */
3075	/* -(N+K) IF BOTH ERROR SITUATIONS OCCUR. */
3076
3077	/* RM1, RM2, RV1, AND RV2 ARE TEMPORARY STORAGE ARRAYS. */
3078
3079	/* THE ALGOL PROCEDURE GUESSVEC APPEARS IN CINVIT IN LINE. */
3080
3081	/* CALLS CDIV FOR COMPLEX DIVISION. */
3082	/* CALLS PYTHAG FOR DSQRT(AA + BB) . */
3083
3084	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
3085	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
3086	*/
3087
3088	/* THIS VERSION DATED AUGUST 1983. */
3089
3090	/* ------------------------------------------------------------------
3091	*/
3092
3093	/* Parameter adjustments */
3094	--rv2;
3095	--rv1;
3096	rm2_dim1 = *n;
3097	rm2_offset = rm2_dim1 + 1;
3098	rm2 -= rm2_offset;
3099	rm1_dim1 = *n;
3100	rm1_offset = rm1_dim1 + 1;
3101	rm1 -= rm1_offset;
3102	--select;
3103	--wi;
3104	--wr;
3105	ai_dim1 = *nm;
3106	ai_offset = ai_dim1 + 1;
3107	ai -= ai_offset;
3108	ar_dim1 = *nm;
3109	ar_offset = ar_dim1 + 1;
3110	ar -= ar_offset;
3111	zi_dim1 = *nm;
3112	zi_offset = zi_dim1 + 1;
3113	zi -= zi_offset;
3114	zr_dim1 = *nm;
3115	zr_offset = zr_dim1 + 1;
3116	zr -= zr_offset;
3117
3118	/* Function Body */
3119	*ierr = 0;
3120	uk = 0;
3121	s = 1;
3122
3123	i_1 = *n;
3124	for (k = 1; k <= i_1; ++k) {
3125	if (! select[k]) {
3126	goto L980;
3127	}
3128	if (s > *mm) {
3129	goto L1000;
3130	}
3131	if (uk >= k) {
3132	goto L200;
3133	}
3134	/* .......... CHECK FOR POSSIBLE SPLITTING .......... */
3135	i_2 = *n;
3136	for (uk = k; uk <= i_2; ++uk) {
3137	if (uk == *n) {
3138	goto L140;
3139	}
3140	if (ar[uk + 1 + uk * ar_dim1] == 0. && ai[uk + 1 + uk * ai_dim1]
3141	== 0.) {
3142	goto L140;
3143	}
3144	/* L120: */
3145	}
3146	/* .......... COMPUTE INFINITY NORM OF LEADING UK BY UK */
3147	/* (HESSENBERG) MATRIX .......... */
3148	L140:
3149	norm = 0.;
3150	mp = 1;
3151
3152	i_2 = uk;
3153	for (i = 1; i <= i_2; ++i) {
3154	x = 0.;
3155
3156	i_3 = uk;
3157	for (j = mp; j <= i_3; ++j) {
3158	/* L160: */
3159	x += pythag_(&ar[i + j * ar_dim1], &ai[i + j * ai_dim1]);
3160	}
3161
3162	if (x > norm) {
3163	norm = x;
3164	}
3165	mp = i;
3166	/* L180: */
3167	}
3168	/* .......... EPS3 REPLACES ZERO PIVOT IN DECOMPOSITION */
3169	/* AND CLOSE ROOTS ARE MODIFIED BY EPS3 .......... */
3170	if (norm == 0.) {
3171	norm = 1.;
3172	}
3173	eps3 = epslon_(&norm);
3174	/* .......... GROWTO IS THE CRITERION FOR GROWTH .......... */
3175	ukroot = (doublereal) uk;
3176	ukroot = sqrt(ukroot);
3177	growto = .1 / ukroot;
3178	L200:
3179	rlambd = wr[k];
3180	ilambd = wi[k];
3181	if (k == 1) {
3182	goto L280;
3183	}
3184	km1 = k - 1;
3185	goto L240;
3186	/* .......... PERTURB EIGENVALUE IF IT IS CLOSE */
3187	/* TO ANY PREVIOUS EIGENVALUE .......... */
3188	L220:
3189	rlambd += eps3;
3190	/* .......... FOR I=K-1 STEP -1 UNTIL 1 DO -- .......... */
3191	L240:
3192	i_2 = km1;
3193	for (ii = 1; ii <= i_2; ++ii) {
3194	i = k - ii;
3195	if (select[i] && (d_1 = wr[i] - rlambd, abs(d_1)) < eps3 && (
3196	d_2 = wi[i] - ilambd, abs(d_2)) < eps3) {
3197	goto L220;
3198	}
3199	/* L260: */
3200	}
3201
3202	wr[k] = rlambd;
3203	/* .......... FORM UPPER HESSENBERG (AR,AI)-(RLAMBD,ILAMBD)I /
3204	/* AND INITIAL COMPLEX VECTOR .......... */
3205	L280:
3206	mp = 1;
3207
3208	i_2 = uk;
3209	for (i = 1; i <= i_2; ++i) {
3210
3211	i_3 = uk;
3212	for (j = mp; j <= i_3; ++j) {
3213	rm1[i + j * rm1_dim1] = ar[i + j * ar_dim1];
3214	rm2[i + j * rm2_dim1] = ai[i + j * ai_dim1];
3215	/* L300: */
3216	}
3217
3218	rm1[i + i * rm1_dim1] -= rlambd;
3219	rm2[i + i * rm2_dim1] -= ilambd;
3220	mp = i;
3221	rv1[i] = eps3;
3222	/* L320: */
3223	}
3224	/* .......... TRIANGULAR DECOMPOSITION WITH INTERCHANGES, */
3225	/* REPLACING ZERO PIVOTS BY EPS3 .......... */
3226	if (uk == 1) {
3227	goto L420;
3228	}
3229
3230	i_2 = uk;
3231	for (i = 2; i <= i_2; ++i) {
3232	mp = i - 1;
3233	if (pythag_(&rm1[i + mp * rm1_dim1], &rm2[i + mp * rm2_dim1]) <=
3234	pythag_(&rm1[mp + mp * rm1_dim1], &rm2[mp + mp * rm2_dim1]
3235	)) {
3236	goto L360;
3237	}
3238
3239	i_3 = uk;
3240	for (j = mp; j <= i_3; ++j) {
3241	y = rm1[i + j * rm1_dim1];
3242	rm1[i + j * rm1_dim1] = rm1[mp + j * rm1_dim1];
3243	rm1[mp + j * rm1_dim1] = y;
3244	y = rm2[i + j * rm2_dim1];
3245	rm2[i + j * rm2_dim1] = rm2[mp + j * rm2_dim1];
3246	rm2[mp + j * rm2_dim1] = y;
3247	/* L340: */
3248	}
3249
3250	L360:
3251	if (rm1[mp + mp * rm1_dim1] == 0. && rm2[mp + mp * rm2_dim1] ==
3252	0.) {
3253	rm1[mp + mp * rm1_dim1] = eps3;
3254	}
3255	cdiv_(&rm1[i + mp * rm1_dim1], &rm2[i + mp * rm2_dim1], &rm1[mp +
3256	mp * rm1_dim1], &rm2[mp + mp * rm2_dim1], &x, &y);
3257	if (x == 0. && y == 0.) {
3258	goto L400;
3259	}
3260
3261	i_3 = uk;
3262	for (j = i; j <= i_3; ++j) {
3263	rm1[i + j * rm1_dim1] = rm1[i + j * rm1_dim1] - x * rm1[mp +
3264	j * rm1_dim1] + y * rm2[mp + j * rm2_dim1];
3265	rm2[i + j * rm2_dim1] = rm2[i + j * rm2_dim1] - x * rm2[mp +
3266	j * rm2_dim1] - y * rm1[mp + j * rm1_dim1];
3267	/* L380: */
3268	}
3269
3270	L400:
3271	;
3272	}
3273
3274	L420:
3275	if (rm1[uk + uk * rm1_dim1] == 0. && rm2[uk + uk * rm2_dim1] == 0.) {
3276	rm1[uk + uk * rm1_dim1] = eps3;
3277	}
3278	its = 0;
3279	/* .......... BACK SUBSTITUTION */
3280	/* FOR I=UK STEP -1 UNTIL 1 DO -- .......... */
3281	L660:
3282	i_2 = uk;
3283	for (ii = 1; ii <= i_2; ++ii) {
3284	i = uk + 1 - ii;
3285	x = rv1[i];
3286	y = 0.;
3287	if (i == uk) {
3288	goto L700;
3289	}
3290	ip1 = i + 1;
3291
3292	i_3 = uk;
3293	for (j = ip1; j <= i_3; ++j) {
3294	x = x - rm1[i + j * rm1_dim1] * rv1[j] + rm2[i + j * rm2_dim1]
3295	* rv2[j];
3296	y = y - rm1[i + j * rm1_dim1] * rv2[j] - rm2[i + j * rm2_dim1]
3297	* rv1[j];
3298	/* L680: */
3299	}
3300
3301	L700:
3302	cdiv_(&x, &y, &rm1[i + i * rm1_dim1], &rm2[i + i * rm2_dim1], &
3303	rv1[i], &rv2[i]);
3304	/* L720: */
3305	}
3306	/* .......... ACCEPTANCE TEST FOR EIGENVECTOR */
3307	/* AND NORMALIZATION .......... */
3308	++its;
3309	norm = 0.;
3310	normv = 0.;
3311
3312	i_2 = uk;
3313	for (i = 1; i <= i_2; ++i) {
3314	x = pythag_(&rv1[i], &rv2[i]);
3315	if (normv >= x) {
3316	goto L760;
3317	}
3318	normv = x;
3319	j = i;
3320	L760:
3321	norm += x;
3322	/* L780: */
3323	}
3324
3325	if (norm < growto) {
3326	goto L840;
3327	}
3328	/* .......... ACCEPT VECTOR .......... */
3329	x = rv1[j];
3330	y = rv2[j];
3331
3332	i_2 = uk;
3333	for (i = 1; i <= i_2; ++i) {
3334	cdiv_(&rv1[i], &rv2[i], &x, &y, &zr[i + s * zr_dim1], &zi[i + s *
3335	zi_dim1]);
3336	/* L820: */
3337	}
3338
3339	if (uk == *n) {
3340	goto L940;
3341	}
3342	j = uk + 1;
3343	goto L900;
3344	/* .......... IN-LINE PROCEDURE FOR CHOOSING */
3345	/* A NEW STARTING VECTOR .......... */
3346	L840:
3347	if (its >= uk) {
3348	goto L880;
3349	}
3350	x = ukroot;
3351	y = eps3 / (x + 1.);
3352	rv1[1] = eps3;
3353
3354	i_2 = uk;
3355	for (i = 2; i <= i_2; ++i) {
3356	/* L860: */
3357	rv1[i] = y;
3358	}
3359
3360	j = uk - its + 1;
3361	rv1[j] -= eps3 * x;
3362	goto L660;
3363	/* .......... SET ERROR -- UNACCEPTED EIGENVECTOR .......... */
3364	L880:
3365	j = 1;
3366	*ierr = -k;
3367	/* .......... SET REMAINING VECTOR COMPONENTS TO ZERO ..........
3368	*/
3369	L900:
3370	i_2 = *n;
3371	for (i = j; i <= i_2; ++i) {
3372	zr[i + s * zr_dim1] = 0.;
3373	zi[i + s * zi_dim1] = 0.;
3374	/* L920: */
3375	}
3376
3377	L940:
3378	++s;
3379	L980:
3380	;
3381	}
3382
3383	goto L1001;
3384	/* .......... SET ERROR -- UNDERESTIMATE OF EIGENVECTOR */
3385	/* SPACE REQUIRED .......... */
3386	L1000:
3387	if (*ierr != 0) {
3388	ierr -= n;
3389	}
3390	if (*ierr == 0) {
3391	ierr = -((n << 1) + 1);
3392	}
3393	L1001:
3394	*m = s - 1;
3395	return 0;
3396	} /* cinvit_ */
3397
3398	/* Subroutine / int combak_(integer nm, integer low, integer igh,
3399	doublereal ar, doublereal ai, integer int_, integer m,
3400	doublereal zr, doublereal zi)
3401	{
3402	/* System generated locals */
3403	integer ar_dim1, ar_offset, ai_dim1, ai_offset, zr_dim1, zr_offset,
3404	zi_dim1, zi_offset, i_1, i_2, i_3;
3405
3406	/* Local variables */
3407	static integer i, j, la, mm, mp;
3408	static doublereal xi, xr;
3409	static integer kp1, mp1;
3410
3411
3412
3413	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMBAK, */
3414	/* NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. */
3415	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). */
3416
3417	/* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL */
3418	/* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */
3419	/* UPPER HESSENBERG MATRIX DETERMINED BY COMHES. */
3420
3421	/* ON INPUT */
3422
3423	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
3424	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
3425	/* DIMENSION STATEMENT. */
3426
3427	/* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
3428	/* SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, */
3429	/* SET LOW=1 AND IGH EQUAL TO THE ORDER OF THE MATRIX. */
3430
3431	/* AR AND AI CONTAIN THE MULTIPLIERS WHICH WERE USED IN THE */
3432	/* REDUCTION BY COMHES IN THEIR LOWER TRIANGLES */
3433	/* BELOW THE SUBDIAGONAL. */
3434
3435	/* INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS */
3436	/* INTERCHANGED IN THE REDUCTION BY COMHES. */
3437	/* ONLY ELEMENTS LOW THROUGH IGH ARE USED. */
3438
3439	/* M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. */
3440
3441	/* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */
3442	/* RESPECTIVELY, OF THE EIGENVECTORS TO BE */
3443	/* BACK TRANSFORMED IN THEIR FIRST M COLUMNS. */
3444
3445	/* ON OUTPUT */
3446
3447	/* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */
3448	/* RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS */
3449	/* IN THEIR FIRST M COLUMNS. */
3450
3451	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
3452	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
3453	*/
3454
3455	/* THIS VERSION DATED AUGUST 1983. */
3456
3457	/* ------------------------------------------------------------------
3458	*/
3459
3460	/* Parameter adjustments */
3461	--int_;
3462	ai_dim1 = *nm;
3463	ai_offset = ai_dim1 + 1;
3464	ai -= ai_offset;
3465	ar_dim1 = *nm;
3466	ar_offset = ar_dim1 + 1;
3467	ar -= ar_offset;
3468	zi_dim1 = *nm;
3469	zi_offset = zi_dim1 + 1;
3470	zi -= zi_offset;
3471	zr_dim1 = *nm;
3472	zr_offset = zr_dim1 + 1;
3473	zr -= zr_offset;
3474
3475	/* Function Body */
3476	if (*m == 0) {
3477	goto L200;
3478	}
3479	la = *igh - 1;
3480	kp1 = *low + 1;
3481	if (la < kp1) {
3482	goto L200;
3483	}
3484	/* .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... */
3485	i_1 = la;
3486	for (mm = kp1; mm <= i_1; ++mm) {
3487	mp = low + igh - mm;
3488	mp1 = mp + 1;
3489
3490	i_2 = *igh;
3491	for (i = mp1; i <= i_2; ++i) {
3492	xr = ar[i + (mp - 1) * ar_dim1];
3493	xi = ai[i + (mp - 1) * ai_dim1];
3494	if (xr == 0. && xi == 0.) {
3495	goto L110;
3496	}
3497
3498	i_3 = *m;
3499	for (j = 1; j <= i_3; ++j) {
3500	zr[i + j * zr_dim1] = zr[i + j * zr_dim1] + xr * zr[mp + j *
3501	zr_dim1] - xi * zi[mp + j * zi_dim1];
3502	zi[i + j * zi_dim1] = zi[i + j * zi_dim1] + xr * zi[mp + j *
3503	zi_dim1] + xi * zr[mp + j * zr_dim1];
3504	/* L100: */
3505	}
3506
3507	L110:
3508	;
3509	}
3510
3511	i = int_[mp];
3512	if (i == mp) {
3513	goto L140;
3514	}
3515
3516	i_2 = *m;
3517	for (j = 1; j <= i_2; ++j) {
3518	xr = zr[i + j * zr_dim1];
3519	zr[i + j * zr_dim1] = zr[mp + j * zr_dim1];
3520	zr[mp + j * zr_dim1] = xr;
3521	xi = zi[i + j * zi_dim1];
3522	zi[i + j * zi_dim1] = zi[mp + j * zi_dim1];
3523	zi[mp + j * zi_dim1] = xi;
3524	/* L130: */
3525	}
3526
3527	L140:
3528	;
3529	}
3530
3531	L200:
3532	return 0;
3533	} /* combak_ */
3534
3535	/* Subroutine / int comhes_(integer nm, integer n, integer low, integer *
3536	igh, doublereal ar, doublereal ai, integer *int_)
3537	{
3538	/* System generated locals */
3539	integer ar_dim1, ar_offset, ai_dim1, ai_offset, i_1, i_2, i_3;
3540	doublereal d_1, d_2;
3541
3542	/* Local variables */
3543	extern /* Subroutine / int cdiv_(doublereal , doublereal , doublereal
3544	, doublereal , doublereal , doublereal *);
3545	static integer i, j, m, la;
3546	static doublereal xi, yi, xr, yr;
3547	static integer mm1, kp1, mp1;
3548
3549
3550
3551	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMHES, */
3552	/* NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. */
3553	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). */
3554
3555	/* GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE */
3556	/* REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS */
3557	/* LOW THROUGH IGH TO UPPER HESSENBERG FORM BY */
3558	/* STABILIZED ELEMENTARY SIMILARITY TRANSFORMATIONS. */
3559
3560	/* ON INPUT */
3561
3562	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
3563	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
3564	/* DIMENSION STATEMENT. */
3565
3566	/* N IS THE ORDER OF THE MATRIX. */
3567
3568	/* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
3569	/* SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, */
3570	/* SET LOW=1, IGH=N. */
3571
3572	/* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */
3573	/* RESPECTIVELY, OF THE COMPLEX INPUT MATRIX. */
3574
3575	/* ON OUTPUT */
3576
3577	/* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */
3578	/* RESPECTIVELY, OF THE HESSENBERG MATRIX. THE */
3579	/* MULTIPLIERS WHICH WERE USED IN THE REDUCTION */
3580	/* ARE STORED IN THE REMAINING TRIANGLES UNDER THE */
3581	/* HESSENBERG MATRIX. */
3582
3583	/* INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS */
3584	/* INTERCHANGED IN THE REDUCTION. */
3585	/* ONLY ELEMENTS LOW THROUGH IGH ARE USED. */
3586
3587	/* CALLS CDIV FOR COMPLEX DIVISION. */
3588
3589	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
3590	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
3591	*/
3592
3593	/* THIS VERSION DATED AUGUST 1983. */
3594
3595	/* ------------------------------------------------------------------
3596	*/
3597
3598	/* Parameter adjustments */
3599	ai_dim1 = *nm;
3600	ai_offset = ai_dim1 + 1;
3601	ai -= ai_offset;
3602	ar_dim1 = *nm;
3603	ar_offset = ar_dim1 + 1;
3604	ar -= ar_offset;
3605	--int_;
3606
3607	/* Function Body */
3608	la = *igh - 1;
3609	kp1 = *low + 1;
3610	if (la < kp1) {
3611	goto L200;
3612	}
3613
3614	i_1 = la;
3615	for (m = kp1; m <= i_1; ++m) {
3616	mm1 = m - 1;
3617	xr = 0.;
3618	xi = 0.;
3619	i = m;
3620
3621	i_2 = *igh;
3622	for (j = m; j <= i_2; ++j) {
3623	if ((d_1 = ar[j + mm1 * ar_dim1], abs(d_1)) + (d_2 = ai[j +
3624	mm1 * ai_dim1], abs(d_2)) <= abs(xr) + abs(xi)) {
3625	goto L100;
3626	}
3627	xr = ar[j + mm1 * ar_dim1];
3628	xi = ai[j + mm1 * ai_dim1];
3629	i = j;
3630	L100:
3631	;
3632	}
3633
3634	int_[m] = i;
3635	if (i == m) {
3636	goto L130;
3637	}
3638	/* .......... INTERCHANGE ROWS AND COLUMNS OF AR AND AI ..........
3639	*/
3640	i_2 = *n;
3641	for (j = mm1; j <= i_2; ++j) {
3642	yr = ar[i + j * ar_dim1];
3643	ar[i + j * ar_dim1] = ar[m + j * ar_dim1];
3644	ar[m + j * ar_dim1] = yr;
3645	yi = ai[i + j * ai_dim1];
3646	ai[i + j * ai_dim1] = ai[m + j * ai_dim1];
3647	ai[m + j * ai_dim1] = yi;
3648	/* L110: */
3649	}
3650
3651	i_2 = *igh;
3652	for (j = 1; j <= i_2; ++j) {
3653	yr = ar[j + i * ar_dim1];
3654	ar[j + i * ar_dim1] = ar[j + m * ar_dim1];
3655	ar[j + m * ar_dim1] = yr;
3656	yi = ai[j + i * ai_dim1];
3657	ai[j + i * ai_dim1] = ai[j + m * ai_dim1];
3658	ai[j + m * ai_dim1] = yi;
3659	/* L120: */
3660	}
3661	/* .......... END INTERCHANGE .......... */
3662	L130:
3663	if (xr == 0. && xi == 0.) {
3664	goto L180;
3665	}
3666	mp1 = m + 1;
3667
3668	i_2 = *igh;
3669	for (i = mp1; i <= i_2; ++i) {
3670	yr = ar[i + mm1 * ar_dim1];
3671	yi = ai[i + mm1 * ai_dim1];
3672	if (yr == 0. && yi == 0.) {
3673	goto L160;
3674	}
3675	cdiv_(&yr, &yi, &xr, &xi, &yr, &yi);
3676	ar[i + mm1 * ar_dim1] = yr;
3677	ai[i + mm1 * ai_dim1] = yi;
3678
3679	i_3 = *n;
3680	for (j = m; j <= i_3; ++j) {
3681	ar[i + j * ar_dim1] = ar[i + j * ar_dim1] - yr * ar[m + j *
3682	ar_dim1] + yi * ai[m + j * ai_dim1];
3683	ai[i + j * ai_dim1] = ai[i + j * ai_dim1] - yr * ai[m + j *
3684	ai_dim1] - yi * ar[m + j * ar_dim1];
3685	/* L140: */
3686	}
3687
3688	i_3 = *igh;
3689	for (j = 1; j <= i_3; ++j) {
3690	ar[j + m * ar_dim1] = ar[j + m * ar_dim1] + yr * ar[j + i *
3691	ar_dim1] - yi * ai[j + i * ai_dim1];
3692	ai[j + m * ai_dim1] = ai[j + m * ai_dim1] + yr * ai[j + i *
3693	ai_dim1] + yi * ar[j + i * ar_dim1];
3694	/* L150: */
3695	}
3696
3697	L160:
3698	;
3699	}
3700
3701	L180:
3702	;
3703	}
3704
3705	L200:
3706	return 0;
3707	} /* comhes_ */
3708
3709	/* Subroutine / int comlr_(integer nm, integer n, integer low, integer *
3710	igh, doublereal hr, doublereal hi, doublereal wr, doublereal wi,
3711	integer *ierr)
3712	{
3713	/* System generated locals */
3714	integer hr_dim1, hr_offset, hi_dim1, hi_offset, i_1, i_2;
3715	doublereal d_1, d_2, d_3, d_4;
3716
3717	/* Local variables */
3718	extern /* Subroutine / int cdiv_(doublereal , doublereal , doublereal
3719	, doublereal , doublereal , doublereal *);
3720	static integer i, j, l, m, en, ll, mm;
3721	static doublereal si, ti, xi, yi, sr, tr, xr, yr;
3722	static integer im1;
3723	extern /* Subroutine / int csroot_(doublereal , doublereal *,
3724	doublereal , doublereal );
3725	static integer mp1, itn, its;
3726	static doublereal zzi, zzr;
3727	static integer enm1;
3728	static doublereal tst1, tst2;
3729
3730
3731
3732	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMLR, */
3733	/* NUM. MATH. 12, 369-376(1968) BY MARTIN AND WILKINSON. */
3734	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971). */
3735
3736	/* THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX */
3737	/* UPPER HESSENBERG MATRIX BY THE MODIFIED LR METHOD. */
3738
3739	/* ON INPUT */
3740
3741	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
3742	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
3743	/* DIMENSION STATEMENT. */
3744
3745	/* N IS THE ORDER OF THE MATRIX. */
3746
3747	/* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
3748	/* SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, */
3749	/* SET LOW=1, IGH=N. */
3750
3751	/* HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, */
3752	/* RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. */
3753	/* THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN THE */
3754	/* MULTIPLIERS WHICH WERE USED IN THE REDUCTION BY COMHES, */
3755	/* IF PERFORMED. */
3756
3757	/* ON OUTPUT */
3758
3759	/* THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN */
3760	/* DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE */
3761	/* CALLING COMLR IF SUBSEQUENT CALCULATION OF */
3762	/* EIGENVECTORS IS TO BE PERFORMED. */
3763
3764	/* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, */
3765	/* RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR */
3766	/* EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT */
3767	/* FOR INDICES IERR+1,...,N. */
3768
3769	/* IERR IS SET TO */
3770	/* ZERO FOR NORMAL RETURN, */
3771	/* J IF THE LIMIT OF 30N ITERATIONS IS EXHAUSTED /
3772	/* WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. */
3773
3774	/* CALLS CDIV FOR COMPLEX DIVISION. */
3775	/* CALLS CSROOT FOR COMPLEX SQUARE ROOT. */
3776
3777	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
3778	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
3779	*/
3780
3781	/* THIS VERSION DATED AUGUST 1983. */
3782
3783	/* ------------------------------------------------------------------
3784	*/
3785
3786	/* Parameter adjustments */
3787	--wi;
3788	--wr;
3789	hi_dim1 = *nm;
3790	hi_offset = hi_dim1 + 1;
3791	hi -= hi_offset;
3792	hr_dim1 = *nm;
3793	hr_offset = hr_dim1 + 1;
3794	hr -= hr_offset;
3795
3796	/* Function Body */
3797	*ierr = 0;
3798	/* .......... STORE ROOTS ISOLATED BY CBAL .......... */
3799	i_1 = *n;
3800	for (i = 1; i <= i_1; ++i) {
3801	if (i >= low && i <= igh) {
3802	goto L200;
3803	}
3804	wr[i] = hr[i + i * hr_dim1];
3805	wi[i] = hi[i + i * hi_dim1];
3806	L200:
3807	;
3808	}
3809
3810	en = *igh;
3811	tr = 0.;
3812	ti = 0.;
3813	itn = n 30;
3814	/* .......... SEARCH FOR NEXT EIGENVALUE .......... */
3815	L220:
3816	if (en < *low) {
3817	goto L1001;
3818	}
3819	its = 0;
3820	enm1 = en - 1;
3821	/* .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT */
3822	/* FOR L=EN STEP -1 UNTIL LOW D0 -- .......... */
3823	L240:
3824	i_1 = en;
3825	for (ll = *low; ll <= i_1; ++ll) {
3826	l = en + *low - ll;
3827	if (l == *low) {
3828	goto L300;
3829	}
3830	tst1 = (d_1 = hr[l - 1 + (l - 1) * hr_dim1], abs(d_1)) + (d_2 = hi[
3831	l - 1 + (l - 1) * hi_dim1], abs(d_2)) + (d_3 = hr[l + l *
3832	hr_dim1], abs(d_3)) + (d_4 = hi[l + l * hi_dim1], abs(d_4))
3833	;
3834	tst2 = tst1 + (d_1 = hr[l + (l - 1) * hr_dim1], abs(d_1)) + (d_2 =
3835	hi[l + (l - 1) * hi_dim1], abs(d_2));
3836	if (tst2 == tst1) {
3837	goto L300;
3838	}
3839	/* L260: */
3840	}
3841	/* .......... FORM SHIFT .......... */
3842	L300:
3843	if (l == en) {
3844	goto L660;
3845	}
3846	if (itn == 0) {
3847	goto L1000;
3848	}
3849	if (its == 10 \|\| its == 20) {
3850	goto L320;
3851	}
3852	sr = hr[en + en * hr_dim1];
3853	si = hi[en + en * hi_dim1];
3854	xr = hr[enm1 + en * hr_dim1] * hr[en + enm1 * hr_dim1] - hi[enm1 + en *
3855	hi_dim1] * hi[en + enm1 * hi_dim1];
3856	xi = hr[enm1 + en * hr_dim1] * hi[en + enm1 * hi_dim1] + hi[enm1 + en *
3857	hi_dim1] * hr[en + enm1 * hr_dim1];
3858	if (xr == 0. && xi == 0.) {
3859	goto L340;
3860	}
3861	yr = (hr[enm1 + enm1 * hr_dim1] - sr) / 2.;
3862	yi = (hi[enm1 + enm1 * hi_dim1] - si) / 2.;
3863	/* Computing 2nd power */
3864	d_2 = yr;
3865	/* Computing 2nd power */
3866	d_3 = yi;
3867	d_1 = d_2 * d_2 - d_3 * d_3 + xr;
3868	d_4 = yr * 2. * yi + xi;
3869	csroot_(&d_1, &d_4, &zzr, &zzi);
3870	if (yr * zzr + yi * zzi >= 0.) {
3871	goto L310;
3872	}
3873	zzr = -zzr;
3874	zzi = -zzi;
3875	L310:
3876	d_1 = yr + zzr;
3877	d_2 = yi + zzi;
3878	cdiv_(&xr, &xi, &d_1, &d_2, &xr, &xi);
3879	sr -= xr;
3880	si -= xi;
3881	goto L340;
3882	/* .......... FORM EXCEPTIONAL SHIFT .......... */
3883	L320:
3884	sr = (d_1 = hr[en + enm1 * hr_dim1], abs(d_1)) + (d_2 = hr[enm1 + (en
3885	- 2) * hr_dim1], abs(d_2));
3886	si = (d_1 = hi[en + enm1 * hi_dim1], abs(d_1)) + (d_2 = hi[enm1 + (en
3887	- 2) * hi_dim1], abs(d_2));
3888
3889	L340:
3890	i_1 = en;
3891	for (i = *low; i <= i_1; ++i) {
3892	hr[i + i * hr_dim1] -= sr;
3893	hi[i + i * hi_dim1] -= si;
3894	/* L360: */
3895	}
3896
3897	tr += sr;
3898	ti += si;
3899	++its;
3900	--itn;
3901	/* .......... LOOK FOR TWO CONSECUTIVE SMALL */
3902	/* SUB-DIAGONAL ELEMENTS .......... */
3903	xr = (d_1 = hr[enm1 + enm1 * hr_dim1], abs(d_1)) + (d_2 = hi[enm1 +
3904	enm1 * hi_dim1], abs(d_2));
3905	yr = (d_1 = hr[en + enm1 * hr_dim1], abs(d_1)) + (d_2 = hi[en + enm1 *
3906	hi_dim1], abs(d_2));
3907	zzr = (d_1 = hr[en + en * hr_dim1], abs(d_1)) + (d_2 = hi[en + en *
3908	hi_dim1], abs(d_2));
3909	/* .......... FOR M=EN-1 STEP -1 UNTIL L DO -- .......... */
3910	i_1 = enm1;
3911	for (mm = l; mm <= i_1; ++mm) {
3912	m = enm1 + l - mm;
3913	if (m == l) {
3914	goto L420;
3915	}
3916	yi = yr;
3917	yr = (d_1 = hr[m + (m - 1) * hr_dim1], abs(d_1)) + (d_2 = hi[m + (
3918	m - 1) * hi_dim1], abs(d_2));
3919	xi = zzr;
3920	zzr = xr;
3921	xr = (d_1 = hr[m - 1 + (m - 1) * hr_dim1], abs(d_1)) + (d_2 = hi[m
3922	- 1 + (m - 1) * hi_dim1], abs(d_2));
3923	tst1 = zzr / yi * (zzr + xr + xi);
3924	tst2 = tst1 + yr;
3925	if (tst2 == tst1) {
3926	goto L420;
3927	}
3928	/* L380: */
3929	}
3930	/* .......... TRIANGULAR DECOMPOSITION H=LR .......... /
3931	L420:
3932	mp1 = m + 1;
3933
3934	i_1 = en;
3935	for (i = mp1; i <= i_1; ++i) {
3936	im1 = i - 1;
3937	xr = hr[im1 + im1 * hr_dim1];
3938	xi = hi[im1 + im1 * hi_dim1];
3939	yr = hr[i + im1 * hr_dim1];
3940	yi = hi[i + im1 * hi_dim1];
3941	if (abs(xr) + abs(xi) >= abs(yr) + abs(yi)) {
3942	goto L460;
3943	}
3944	/* .......... INTERCHANGE ROWS OF HR AND HI .......... */
3945	i_2 = en;
3946	for (j = im1; j <= i_2; ++j) {
3947	zzr = hr[im1 + j * hr_dim1];
3948	hr[im1 + j * hr_dim1] = hr[i + j * hr_dim1];
3949	hr[i + j * hr_dim1] = zzr;
3950	zzi = hi[im1 + j * hi_dim1];
3951	hi[im1 + j * hi_dim1] = hi[i + j * hi_dim1];
3952	hi[i + j * hi_dim1] = zzi;
3953	/* L440: */
3954	}
3955
3956	cdiv_(&xr, &xi, &yr, &yi, &zzr, &zzi);
3957	wr[i] = 1.;
3958	goto L480;
3959	L460:
3960	cdiv_(&yr, &yi, &xr, &xi, &zzr, &zzi);
3961	wr[i] = -1.;
3962	L480:
3963	hr[i + im1 * hr_dim1] = zzr;
3964	hi[i + im1 * hi_dim1] = zzi;
3965
3966	i_2 = en;
3967	for (j = i; j <= i_2; ++j) {
3968	hr[i + j * hr_dim1] = hr[i + j * hr_dim1] - zzr * hr[im1 + j *
3969	hr_dim1] + zzi * hi[im1 + j * hi_dim1];
3970	hi[i + j * hi_dim1] = hi[i + j * hi_dim1] - zzr * hi[im1 + j *
3971	hi_dim1] - zzi * hr[im1 + j * hr_dim1];
3972	/* L500: */
3973	}
3974
3975	/* L520: */
3976	}
3977	/* .......... COMPOSITION RL=H .......... /
3978	i_1 = en;
3979	for (j = mp1; j <= i_1; ++j) {
3980	xr = hr[j + (j - 1) * hr_dim1];
3981	xi = hi[j + (j - 1) * hi_dim1];
3982	hr[j + (j - 1) * hr_dim1] = 0.;
3983	hi[j + (j - 1) * hi_dim1] = 0.;
3984	/* .......... INTERCHANGE COLUMNS OF HR AND HI, */
3985	/* IF NECESSARY .......... */
3986	if (wr[j] <= 0.) {
3987	goto L580;
3988	}
3989
3990	i_2 = j;
3991	for (i = l; i <= i_2; ++i) {
3992	zzr = hr[i + (j - 1) * hr_dim1];
3993	hr[i + (j - 1) * hr_dim1] = hr[i + j * hr_dim1];
3994	hr[i + j * hr_dim1] = zzr;
3995	zzi = hi[i + (j - 1) * hi_dim1];
3996	hi[i + (j - 1) * hi_dim1] = hi[i + j * hi_dim1];
3997	hi[i + j * hi_dim1] = zzi;
3998	/* L540: */
3999	}
4000
4001	L580:
4002	i_2 = j;
4003	for (i = l; i <= i_2; ++i) {
4004	hr[i + (j - 1) * hr_dim1] = hr[i + (j - 1) * hr_dim1] + xr * hr[i
4005	+ j * hr_dim1] - xi * hi[i + j * hi_dim1];
4006	hi[i + (j - 1) * hi_dim1] = hi[i + (j - 1) * hi_dim1] + xr * hi[i
4007	+ j * hi_dim1] + xi * hr[i + j * hr_dim1];
4008	/* L600: */
4009	}
4010
4011	/* L640: */
4012	}
4013
4014	goto L240;
4015	/* .......... A ROOT FOUND .......... */
4016	L660:
4017	wr[en] = hr[en + en * hr_dim1] + tr;
4018	wi[en] = hi[en + en * hi_dim1] + ti;
4019	en = enm1;
4020	goto L220;
4021	/* .......... SET ERROR -- ALL EIGENVALUES HAVE NOT */
4022	/* CONVERGED AFTER 30N ITERATIONS .......... /
4023	L1000:
4024	*ierr = en;
4025	L1001:
4026	return 0;
4027	} /* comlr_ */
4028
4029	/* Subroutine / int comlr2_(integer nm, integer n, integer low, integer *
4030	igh, integer int_, doublereal hr, doublereal hi, doublereal wr,
4031	doublereal wi, doublereal zr, doublereal zi, integer ierr)
4032	{
4033	/* System generated locals */
4034	integer hr_dim1, hr_offset, hi_dim1, hi_offset, zr_dim1, zr_offset,
4035	zi_dim1, zi_offset, i_1, i_2, i_3;
4036	doublereal d_1, d_2, d_3, d_4;
4037
4038	/* Local variables */
4039	static integer iend;
4040	extern /* Subroutine / int cdiv_(doublereal , doublereal , doublereal
4041	, doublereal , doublereal , doublereal *);
4042	static doublereal norm;
4043	static integer i, j, k, l, m, ii, en, jj, ll, mm, nn;
4044	static doublereal si, ti, xi, yi, sr, tr, xr, yr;
4045	static integer im1;
4046	extern /* Subroutine / int csroot_(doublereal , doublereal *,
4047	doublereal , doublereal );
4048	static integer ip1, mp1, itn, its;
4049	static doublereal zzi, zzr;
4050	static integer enm1;
4051	static doublereal tst1, tst2;
4052
4053
4054
4055	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE COMLR2, */
4056	/* NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. */
4057	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). */
4058
4059	/* THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS */
4060	/* OF A COMPLEX UPPER HESSENBERG MATRIX BY THE MODIFIED LR */
4061	/* METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX */
4062	/* CAN ALSO BE FOUND IF COMHES HAS BEEN USED TO REDUCE */
4063	/* THIS GENERAL MATRIX TO HESSENBERG FORM. */
4064
4065	/* ON INPUT */
4066
4067	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
4068	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
4069	/* DIMENSION STATEMENT. */
4070
4071	/* N IS THE ORDER OF THE MATRIX. */
4072
4073	/* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
4074	/* SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, */
4075	/* SET LOW=1, IGH=N. */
4076
4077	/* INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS INTERCHANGED */
4078	/* IN THE REDUCTION BY COMHES, IF PERFORMED. ONLY ELEMENTS */
4079	/* LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS OF THE HESSEN-
4080	*/
4081	/* BERG MATRIX ARE DESIRED, SET INT(J)=J FOR THESE ELEMENTS. */
4082
4083	/* HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, */
4084	/* RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. */
4085	/* THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN THE */
4086	/* MULTIPLIERS WHICH WERE USED IN THE REDUCTION BY COMHES, */
4087	/* IF PERFORMED. IF THE EIGENVECTORS OF THE HESSENBERG */
4088	/* MATRIX ARE DESIRED, THESE ELEMENTS MUST BE SET TO ZERO. */
4089
4090	/* ON OUTPUT */
4091
4092	/* THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN */
4093	/* DESTROYED, BUT THE LOCATION HR(1,1) CONTAINS THE NORM */
4094	/* OF THE TRIANGULARIZED MATRIX. */
4095
4096	/* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, */
4097	/* RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR */
4098	/* EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT */
4099	/* FOR INDICES IERR+1,...,N. */
4100
4101	/* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */
4102	/* RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS */
4103	/* ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF */
4104	/* THE EIGENVECTORS HAS BEEN FOUND. */
4105
4106	/* IERR IS SET TO */
4107	/* ZERO FOR NORMAL RETURN, */
4108	/* J IF THE LIMIT OF 30N ITERATIONS IS EXHAUSTED /
4109	/* WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. */
4110
4111
4112	/* CALLS CDIV FOR COMPLEX DIVISION. */
4113	/* CALLS CSROOT FOR COMPLEX SQUARE ROOT. */
4114
4115	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
4116	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
4117	*/
4118
4119	/* THIS VERSION DATED AUGUST 1983. */
4120
4121	/* ------------------------------------------------------------------
4122	*/
4123
4124	/* Parameter adjustments */
4125	zi_dim1 = *nm;
4126	zi_offset = zi_dim1 + 1;
4127	zi -= zi_offset;
4128	zr_dim1 = *nm;
4129	zr_offset = zr_dim1 + 1;
4130	zr -= zr_offset;
4131	--wi;
4132	--wr;
4133	hi_dim1 = *nm;
4134	hi_offset = hi_dim1 + 1;
4135	hi -= hi_offset;
4136	hr_dim1 = *nm;
4137	hr_offset = hr_dim1 + 1;
4138	hr -= hr_offset;
4139	--int_;
4140
4141	/* Function Body */
4142	*ierr = 0;
4143	/* .......... INITIALIZE EIGENVECTOR MATRIX .......... */
4144	i_1 = *n;
4145	for (i = 1; i <= i_1; ++i) {
4146
4147	i_2 = *n;
4148	for (j = 1; j <= i_2; ++j) {
4149	zr[i + j * zr_dim1] = 0.;
4150	zi[i + j * zi_dim1] = 0.;
4151	if (i == j) {
4152	zr[i + j * zr_dim1] = 1.;
4153	}
4154	/* L100: */
4155	}
4156	}
4157	/* .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS */
4158	/* FROM THE INFORMATION LEFT BY COMHES .......... */
4159	iend = igh - low - 1;
4160	if (iend <= 0) {
4161	goto L180;
4162	}
4163	/* .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... */
4164	i_2 = iend;
4165	for (ii = 1; ii <= i_2; ++ii) {
4166	i = *igh - ii;
4167	ip1 = i + 1;
4168
4169	i_1 = *igh;
4170	for (k = ip1; k <= i_1; ++k) {
4171	zr[k + i * zr_dim1] = hr[k + (i - 1) * hr_dim1];
4172	zi[k + i * zi_dim1] = hi[k + (i - 1) * hi_dim1];
4173	/* L120: */
4174	}
4175
4176	j = int_[i];
4177	if (i == j) {
4178	goto L160;
4179	}
4180
4181	i_1 = *igh;
4182	for (k = i; k <= i_1; ++k) {
4183	zr[i + k * zr_dim1] = zr[j + k * zr_dim1];
4184	zi[i + k * zi_dim1] = zi[j + k * zi_dim1];
4185	zr[j + k * zr_dim1] = 0.;
4186	zi[j + k * zi_dim1] = 0.;
4187	/* L140: */
4188	}
4189
4190	zr[j + i * zr_dim1] = 1.;
4191	L160:
4192	;
4193	}
4194	/* .......... STORE ROOTS ISOLATED BY CBAL .......... */
4195	L180:
4196	i_2 = *n;
4197	for (i = 1; i <= i_2; ++i) {
4198	if (i >= low && i <= igh) {
4199	goto L200;
4200	}
4201	wr[i] = hr[i + i * hr_dim1];
4202	wi[i] = hi[i + i * hi_dim1];
4203	L200:
4204	;
4205	}
4206
4207	en = *igh;
4208	tr = 0.;
4209	ti = 0.;
4210	itn = n 30;
4211	/* .......... SEARCH FOR NEXT EIGENVALUE .......... */
4212	L220:
4213	if (en < *low) {
4214	goto L680;
4215	}
4216	its = 0;
4217	enm1 = en - 1;
4218	/* .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT */
4219	/* FOR L=EN STEP -1 UNTIL LOW DO -- .......... */
4220	L240:
4221	i_2 = en;
4222	for (ll = *low; ll <= i_2; ++ll) {
4223	l = en + *low - ll;
4224	if (l == *low) {
4225	goto L300;
4226	}
4227	tst1 = (d_1 = hr[l - 1 + (l - 1) * hr_dim1], abs(d_1)) + (d_2 = hi[
4228	l - 1 + (l - 1) * hi_dim1], abs(d_2)) + (d_3 = hr[l + l *
4229	hr_dim1], abs(d_3)) + (d_4 = hi[l + l * hi_dim1], abs(d_4))
4230	;
4231	tst2 = tst1 + (d_1 = hr[l + (l - 1) * hr_dim1], abs(d_1)) + (d_2 =
4232	hi[l + (l - 1) * hi_dim1], abs(d_2));
4233	if (tst2 == tst1) {
4234	goto L300;
4235	}
4236	/* L260: */
4237	}
4238	/* .......... FORM SHIFT .......... */
4239	L300:
4240	if (l == en) {
4241	goto L660;
4242	}
4243	if (itn == 0) {
4244	goto L1000;
4245	}
4246	if (its == 10 \|\| its == 20) {
4247	goto L320;
4248	}
4249	sr = hr[en + en * hr_dim1];
4250	si = hi[en + en * hi_dim1];
4251	xr = hr[enm1 + en * hr_dim1] * hr[en + enm1 * hr_dim1] - hi[enm1 + en *
4252	hi_dim1] * hi[en + enm1 * hi_dim1];
4253	xi = hr[enm1 + en * hr_dim1] * hi[en + enm1 * hi_dim1] + hi[enm1 + en *
4254	hi_dim1] * hr[en + enm1 * hr_dim1];
4255	if (xr == 0. && xi == 0.) {
4256	goto L340;
4257	}
4258	yr = (hr[enm1 + enm1 * hr_dim1] - sr) / 2.;
4259	yi = (hi[enm1 + enm1 * hi_dim1] - si) / 2.;
4260	/* Computing 2nd power */
4261	d_2 = yr;
4262	/* Computing 2nd power */
4263	d_3 = yi;
4264	d_1 = d_2 * d_2 - d_3 * d_3 + xr;
4265	d_4 = yr * 2. * yi + xi;
4266	csroot_(&d_1, &d_4, &zzr, &zzi);
4267	if (yr * zzr + yi * zzi >= 0.) {
4268	goto L310;
4269	}
4270	zzr = -zzr;
4271	zzi = -zzi;
4272	L310:
4273	d_1 = yr + zzr;
4274	d_2 = yi + zzi;
4275	cdiv_(&xr, &xi, &d_1, &d_2, &xr, &xi);
4276	sr -= xr;
4277	si -= xi;
4278	goto L340;
4279	/* .......... FORM EXCEPTIONAL SHIFT .......... */
4280	L320:
4281	sr = (d_1 = hr[en + enm1 * hr_dim1], abs(d_1)) + (d_2 = hr[enm1 + (en
4282	- 2) * hr_dim1], abs(d_2));
4283	si = (d_1 = hi[en + enm1 * hi_dim1], abs(d_1)) + (d_2 = hi[enm1 + (en
4284	- 2) * hi_dim1], abs(d_2));
4285
4286	L340:
4287	i_2 = en;
4288	for (i = *low; i <= i_2; ++i) {
4289	hr[i + i * hr_dim1] -= sr;
4290	hi[i + i * hi_dim1] -= si;
4291	/* L360: */
4292	}
4293
4294	tr += sr;
4295	ti += si;
4296	++its;
4297	--itn;
4298	/* .......... LOOK FOR TWO CONSECUTIVE SMALL */
4299	/* SUB-DIAGONAL ELEMENTS .......... */
4300	xr = (d_1 = hr[enm1 + enm1 * hr_dim1], abs(d_1)) + (d_2 = hi[enm1 +
4301	enm1 * hi_dim1], abs(d_2));
4302	yr = (d_1 = hr[en + enm1 * hr_dim1], abs(d_1)) + (d_2 = hi[en + enm1 *
4303	hi_dim1], abs(d_2));
4304	zzr = (d_1 = hr[en + en * hr_dim1], abs(d_1)) + (d_2 = hi[en + en *
4305	hi_dim1], abs(d_2));
4306	/* .......... FOR M=EN-1 STEP -1 UNTIL L DO -- .......... */
4307	i_2 = enm1;
4308	for (mm = l; mm <= i_2; ++mm) {
4309	m = enm1 + l - mm;
4310	if (m == l) {
4311	goto L420;
4312	}
4313	yi = yr;
4314	yr = (d_1 = hr[m + (m - 1) * hr_dim1], abs(d_1)) + (d_2 = hi[m + (
4315	m - 1) * hi_dim1], abs(d_2));
4316	xi = zzr;
4317	zzr = xr;
4318	xr = (d_1 = hr[m - 1 + (m - 1) * hr_dim1], abs(d_1)) + (d_2 = hi[m
4319	- 1 + (m - 1) * hi_dim1], abs(d_2));
4320	tst1 = zzr / yi * (zzr + xr + xi);
4321	tst2 = tst1 + yr;
4322	if (tst2 == tst1) {
4323	goto L420;
4324	}
4325	/* L380: */
4326	}
4327	/* .......... TRIANGULAR DECOMPOSITION H=LR .......... /
4328	L420:
4329	mp1 = m + 1;
4330
4331	i_2 = en;
4332	for (i = mp1; i <= i_2; ++i) {
4333	im1 = i - 1;
4334	xr = hr[im1 + im1 * hr_dim1];
4335	xi = hi[im1 + im1 * hi_dim1];
4336	yr = hr[i + im1 * hr_dim1];
4337	yi = hi[i + im1 * hi_dim1];
4338	if (abs(xr) + abs(xi) >= abs(yr) + abs(yi)) {
4339	goto L460;
4340	}
4341	/* .......... INTERCHANGE ROWS OF HR AND HI .......... */
4342	i_1 = *n;
4343	for (j = im1; j <= i_1; ++j) {
4344	zzr = hr[im1 + j * hr_dim1];
4345	hr[im1 + j * hr_dim1] = hr[i + j * hr_dim1];
4346	hr[i + j * hr_dim1] = zzr;
4347	zzi = hi[im1 + j * hi_dim1];
4348	hi[im1 + j * hi_dim1] = hi[i + j * hi_dim1];
4349	hi[i + j * hi_dim1] = zzi;
4350	/* L440: */
4351	}
4352
4353	cdiv_(&xr, &xi, &yr, &yi, &zzr, &zzi);
4354	wr[i] = 1.;
4355	goto L480;
4356	L460:
4357	cdiv_(&yr, &yi, &xr, &xi, &zzr, &zzi);
4358	wr[i] = -1.;
4359	L480:
4360	hr[i + im1 * hr_dim1] = zzr;
4361	hi[i + im1 * hi_dim1] = zzi;
4362
4363	i_1 = *n;
4364	for (j = i; j <= i_1; ++j) {
4365	hr[i + j * hr_dim1] = hr[i + j * hr_dim1] - zzr * hr[im1 + j *
4366	hr_dim1] + zzi * hi[im1 + j * hi_dim1];
4367	hi[i + j * hi_dim1] = hi[i + j * hi_dim1] - zzr * hi[im1 + j *
4368	hi_dim1] - zzi * hr[im1 + j * hr_dim1];
4369	/* L500: */
4370	}
4371
4372	/* L520: */
4373	}
4374	/* .......... COMPOSITION RL=H .......... /
4375	i_2 = en;
4376	for (j = mp1; j <= i_2; ++j) {
4377	xr = hr[j + (j - 1) * hr_dim1];
4378	xi = hi[j + (j - 1) * hi_dim1];
4379	hr[j + (j - 1) * hr_dim1] = 0.;
4380	hi[j + (j - 1) * hi_dim1] = 0.;
4381	/* .......... INTERCHANGE COLUMNS OF HR, HI, ZR, AND ZI, */
4382	/* IF NECESSARY .......... */
4383	if (wr[j] <= 0.) {
4384	goto L580;
4385	}
4386
4387	i_1 = j;
4388	for (i = 1; i <= i_1; ++i) {
4389	zzr = hr[i + (j - 1) * hr_dim1];
4390	hr[i + (j - 1) * hr_dim1] = hr[i + j * hr_dim1];
4391	hr[i + j * hr_dim1] = zzr;
4392	zzi = hi[i + (j - 1) * hi_dim1];
4393	hi[i + (j - 1) * hi_dim1] = hi[i + j * hi_dim1];
4394	hi[i + j * hi_dim1] = zzi;
4395	/* L540: */
4396	}
4397
4398	i_1 = *igh;
4399	for (i = *low; i <= i_1; ++i) {
4400	zzr = zr[i + (j - 1) * zr_dim1];
4401	zr[i + (j - 1) * zr_dim1] = zr[i + j * zr_dim1];
4402	zr[i + j * zr_dim1] = zzr;
4403	zzi = zi[i + (j - 1) * zi_dim1];
4404	zi[i + (j - 1) * zi_dim1] = zi[i + j * zi_dim1];
4405	zi[i + j * zi_dim1] = zzi;
4406	/* L560: */
4407	}
4408
4409	L580:
4410	i_1 = j;
4411	for (i = 1; i <= i_1; ++i) {
4412	hr[i + (j - 1) * hr_dim1] = hr[i + (j - 1) * hr_dim1] + xr * hr[i
4413	+ j * hr_dim1] - xi * hi[i + j * hi_dim1];
4414	hi[i + (j - 1) * hi_dim1] = hi[i + (j - 1) * hi_dim1] + xr * hi[i
4415	+ j * hi_dim1] + xi * hr[i + j * hr_dim1];
4416	/* L600: */
4417	}
4418	/* .......... ACCUMULATE TRANSFORMATIONS .......... */
4419	i_1 = *igh;
4420	for (i = *low; i <= i_1; ++i) {
4421	zr[i + (j - 1) * zr_dim1] = zr[i + (j - 1) * zr_dim1] + xr * zr[i
4422	+ j * zr_dim1] - xi * zi[i + j * zi_dim1];
4423	zi[i + (j - 1) * zi_dim1] = zi[i + (j - 1) * zi_dim1] + xr * zi[i
4424	+ j * zi_dim1] + xi * zr[i + j * zr_dim1];
4425	/* L620: */
4426	}
4427
4428	/* L640: */
4429	}
4430
4431	goto L240;
4432	/* .......... A ROOT FOUND .......... */
4433	L660:
4434	hr[en + en * hr_dim1] += tr;
4435	wr[en] = hr[en + en * hr_dim1];
4436	hi[en + en * hi_dim1] += ti;
4437	wi[en] = hi[en + en * hi_dim1];
4438	en = enm1;
4439	goto L220;
4440	/* .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND */
4441	/* VECTORS OF UPPER TRIANGULAR FORM .......... */
4442	L680:
4443	norm = 0.;
4444
4445	i_2 = *n;
4446	for (i = 1; i <= i_2; ++i) {
4447
4448	i_1 = *n;
4449	for (j = i; j <= i_1; ++j) {
4450	tr = (d_1 = hr[i + j * hr_dim1], abs(d_1)) + (d_2 = hi[i + j *
4451	hi_dim1], abs(d_2));
4452	if (tr > norm) {
4453	norm = tr;
4454	}
4455	/* L720: */
4456	}
4457	}
4458
4459	hr[hr_dim1 + 1] = norm;
4460	if (*n == 1 \|\| norm == 0.) {
4461	goto L1001;
4462	}
4463	/* .......... FOR EN=N STEP -1 UNTIL 2 DO -- .......... */
4464	i_1 = *n;
4465	for (nn = 2; nn <= i_1; ++nn) {
4466	en = *n + 2 - nn;
4467	xr = wr[en];
4468	xi = wi[en];
4469	hr[en + en * hr_dim1] = 1.;
4470	hi[en + en * hi_dim1] = 0.;
4471	enm1 = en - 1;
4472	/* .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... */
4473	i_2 = enm1;
4474	for (ii = 1; ii <= i_2; ++ii) {
4475	i = en - ii;
4476	zzr = 0.;
4477	zzi = 0.;
4478	ip1 = i + 1;
4479
4480	i_3 = en;
4481	for (j = ip1; j <= i_3; ++j) {
4482	zzr = zzr + hr[i + j * hr_dim1] * hr[j + en * hr_dim1] - hi[i
4483	+ j * hi_dim1] * hi[j + en * hi_dim1];
4484	zzi = zzi + hr[i + j * hr_dim1] * hi[j + en * hi_dim1] + hi[i
4485	+ j * hi_dim1] * hr[j + en * hr_dim1];
4486	/* L740: */
4487	}
4488
4489	yr = xr - wr[i];
4490	yi = xi - wi[i];
4491	if (yr != 0. \|\| yi != 0.) {
4492	goto L765;
4493	}
4494	tst1 = norm;
4495	yr = tst1;
4496	L760:
4497	yr *= .01;
4498	tst2 = norm + yr;
4499	if (tst2 > tst1) {
4500	goto L760;
4501	}
4502	L765:
4503	cdiv_(&zzr, &zzi, &yr, &yi, &hr[i + en * hr_dim1], &hi[i + en *
4504	hi_dim1]);
4505	/* .......... OVERFLOW CONTROL .......... */
4506	tr = (d_1 = hr[i + en * hr_dim1], abs(d_1)) + (d_2 = hi[i + en
4507	* hi_dim1], abs(d_2));
4508	if (tr == 0.) {
4509	goto L780;
4510	}
4511	tst1 = tr;
4512	tst2 = tst1 + 1. / tst1;
4513	if (tst2 > tst1) {
4514	goto L780;
4515	}
4516	i_3 = en;
4517	for (j = i; j <= i_3; ++j) {
4518	hr[j + en * hr_dim1] /= tr;
4519	hi[j + en * hi_dim1] /= tr;
4520	/* L770: */
4521	}
4522
4523	L780:
4524	;
4525	}
4526
4527	/* L800: */
4528	}
4529	/* .......... END BACKSUBSTITUTION .......... */
4530	enm1 = *n - 1;
4531	/* .......... VECTORS OF ISOLATED ROOTS .......... */
4532	i_1 = enm1;
4533	for (i = 1; i <= i_1; ++i) {
4534	if (i >= low && i <= igh) {
4535	goto L840;
4536	}
4537	ip1 = i + 1;
4538
4539	i_2 = *n;
4540	for (j = ip1; j <= i_2; ++j) {
4541	zr[i + j * zr_dim1] = hr[i + j * hr_dim1];
4542	zi[i + j * zi_dim1] = hi[i + j * hi_dim1];
4543	/* L820: */
4544	}
4545
4546	L840:
4547	;
4548	}
4549	/* .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE */
4550	/* VECTORS OF ORIGINAL FULL MATRIX. */
4551	/* FOR J=N STEP -1 UNTIL LOW+1 DO -- .......... */
4552	i_1 = enm1;
4553	for (jj = *low; jj <= i_1; ++jj) {
4554	j = n + low - jj;
4555	m = min(j,*igh);
4556
4557	i_2 = *igh;
4558	for (i = *low; i <= i_2; ++i) {
4559	zzr = 0.;
4560	zzi = 0.;
4561
4562	i_3 = m;
4563	for (k = *low; k <= i_3; ++k) {
4564	zzr = zzr + zr[i + k * zr_dim1] * hr[k + j * hr_dim1] - zi[i
4565	+ k * zi_dim1] * hi[k + j * hi_dim1];
4566	zzi = zzi + zr[i + k * zr_dim1] * hi[k + j * hi_dim1] + zi[i
4567	+ k * zi_dim1] * hr[k + j * hr_dim1];
4568	/* L860: */
4569	}
4570
4571	zr[i + j * zr_dim1] = zzr;
4572	zi[i + j * zi_dim1] = zzi;
4573	/* L880: */
4574	}
4575	}
4576
4577	goto L1001;
4578	/* .......... SET ERROR -- ALL EIGENVALUES HAVE NOT */
4579	/* CONVERGED AFTER 30N ITERATIONS .......... /
4580	L1000:
4581	*ierr = en;
4582	L1001:
4583	return 0;
4584	} /* comlr2_ */
4585
4586	/* Subroutine / int comqr_(integer nm, integer n, integer low, integer *
4587	igh, doublereal hr, doublereal hi, doublereal wr, doublereal wi,
4588	integer *ierr)
4589	{
4590	/* System generated locals */
4591	integer hr_dim1, hr_offset, hi_dim1, hi_offset, i_1, i_2;
4592	doublereal d_1, d_2, d_3, d_4;
4593
4594	/* Local variables */
4595	extern /* Subroutine / int cdiv_(doublereal , doublereal , doublereal
4596	, doublereal , doublereal , doublereal *);
4597	static doublereal norm;
4598	static integer i, j, l, en, ll;
4599	static doublereal si, ti, xi, yi, sr, tr, xr, yr;
4600	extern doublereal pythag_(doublereal , doublereal );
4601	extern /* Subroutine / int csroot_(doublereal , doublereal *,
4602	doublereal , doublereal );
4603	static integer lp1, itn, its;
4604	static doublereal zzi, zzr;
4605	static integer enm1;
4606	static doublereal tst1, tst2;
4607
4608
4609
4610	/* THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE */
4611	/* ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN */
4612	/* AND WILKINSON. */
4613	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971). */
4614	/* THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS */
4615	/* (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM. */
4616
4617	/* THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX */
4618	/* UPPER HESSENBERG MATRIX BY THE QR METHOD. */
4619
4620	/* ON INPUT */
4621
4622	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
4623	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
4624	/* DIMENSION STATEMENT. */
4625
4626	/* N IS THE ORDER OF THE MATRIX. */
4627
4628	/* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
4629	/* SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, */
4630	/* SET LOW=1, IGH=N. */
4631
4632	/* HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, */
4633	/* RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. */
4634	/* THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN */
4635	/* INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN */
4636	/* THE REDUCTION BY CORTH, IF PERFORMED. */
4637
4638	/* ON OUTPUT */
4639
4640	/* THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN */
4641	/* DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE */
4642	/* CALLING COMQR IF SUBSEQUENT CALCULATION OF */
4643	/* EIGENVECTORS IS TO BE PERFORMED. */
4644
4645	/* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, */
4646	/* RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR */
4647	/* EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT */
4648	/* FOR INDICES IERR+1,...,N. */
4649
4650	/* IERR IS SET TO */
4651	/* ZERO FOR NORMAL RETURN, */
4652	/* J IF THE LIMIT OF 30N ITERATIONS IS EXHAUSTED /
4653	/* WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. */
4654
4655	/* CALLS CDIV FOR COMPLEX DIVISION. */
4656	/* CALLS CSROOT FOR COMPLEX SQUARE ROOT. */
4657	/* CALLS PYTHAG FOR DSQRT(AA + BB) . */
4658
4659	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
4660	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
4661	*/
4662
4663	/* THIS VERSION DATED AUGUST 1983. */
4664
4665	/* ------------------------------------------------------------------
4666	*/
4667
4668	/* Parameter adjustments */
4669	--wi;
4670	--wr;
4671	hi_dim1 = *nm;
4672	hi_offset = hi_dim1 + 1;
4673	hi -= hi_offset;
4674	hr_dim1 = *nm;
4675	hr_offset = hr_dim1 + 1;
4676	hr -= hr_offset;
4677
4678	/* Function Body */
4679	*ierr = 0;
4680	if (low == igh) {
4681	goto L180;
4682	}
4683	/* .......... CREATE REAL SUBDIAGONAL ELEMENTS .......... */
4684	l = *low + 1;
4685
4686	i_1 = *igh;
4687	for (i = l; i <= i_1; ++i) {
4688	/* Computing MIN */
4689	i_2 = i + 1;
4690	ll = min(i_2,*igh);
4691	if (hi[i + (i - 1) * hi_dim1] == 0.) {
4692	goto L170;
4693	}
4694	norm = pythag_(&hr[i + (i - 1) * hr_dim1], &hi[i + (i - 1) * hi_dim1])
4695	;
4696	yr = hr[i + (i - 1) * hr_dim1] / norm;
4697	yi = hi[i + (i - 1) * hi_dim1] / norm;
4698	hr[i + (i - 1) * hr_dim1] = norm;
4699	hi[i + (i - 1) * hi_dim1] = 0.;
4700
4701	i_2 = *igh;
4702	for (j = i; j <= i_2; ++j) {
4703	si = yr * hi[i + j * hi_dim1] - yi * hr[i + j * hr_dim1];
4704	hr[i + j * hr_dim1] = yr * hr[i + j * hr_dim1] + yi * hi[i + j *
4705	hi_dim1];
4706	hi[i + j * hi_dim1] = si;
4707	/* L155: */
4708	}
4709
4710	i_2 = ll;
4711	for (j = *low; j <= i_2; ++j) {
4712	si = yr * hi[j + i * hi_dim1] + yi * hr[j + i * hr_dim1];
4713	hr[j + i * hr_dim1] = yr * hr[j + i * hr_dim1] - yi * hi[j + i *
4714	hi_dim1];
4715	hi[j + i * hi_dim1] = si;
4716	/* L160: */
4717	}
4718
4719	L170:
4720	;
4721	}
4722	/* .......... STORE ROOTS ISOLATED BY CBAL .......... */
4723	L180:
4724	i_1 = *n;
4725	for (i = 1; i <= i_1; ++i) {
4726	if (i >= low && i <= igh) {
4727	goto L200;
4728	}
4729	wr[i] = hr[i + i * hr_dim1];
4730	wi[i] = hi[i + i * hi_dim1];
4731	L200:
4732	;
4733	}
4734
4735	en = *igh;
4736	tr = 0.;
4737	ti = 0.;
4738	itn = n 30;
4739	/* .......... SEARCH FOR NEXT EIGENVALUE .......... */
4740	L220:
4741	if (en < *low) {
4742	goto L1001;
4743	}
4744	its = 0;
4745	enm1 = en - 1;
4746	/* .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT */
4747	/* FOR L=EN STEP -1 UNTIL LOW D0 -- .......... */
4748	L240:
4749	i_1 = en;
4750	for (ll = *low; ll <= i_1; ++ll) {
4751	l = en + *low - ll;
4752	if (l == *low) {
4753	goto L300;
4754	}
4755	tst1 = (d_1 = hr[l - 1 + (l - 1) * hr_dim1], abs(d_1)) + (d_2 = hi[
4756	l - 1 + (l - 1) * hi_dim1], abs(d_2)) + (d_3 = hr[l + l *
4757	hr_dim1], abs(d_3)) + (d_4 = hi[l + l * hi_dim1], abs(d_4))
4758	;
4759	tst2 = tst1 + (d_1 = hr[l + (l - 1) * hr_dim1], abs(d_1));
4760	if (tst2 == tst1) {
4761	goto L300;
4762	}
4763	/* L260: */
4764	}
4765	/* .......... FORM SHIFT .......... */
4766	L300:
4767	if (l == en) {
4768	goto L660;
4769	}
4770	if (itn == 0) {
4771	goto L1000;
4772	}
4773	if (its == 10 \|\| its == 20) {
4774	goto L320;
4775	}
4776	sr = hr[en + en * hr_dim1];
4777	si = hi[en + en * hi_dim1];
4778	xr = hr[enm1 + en * hr_dim1] * hr[en + enm1 * hr_dim1];
4779	xi = hi[enm1 + en * hi_dim1] * hr[en + enm1 * hr_dim1];
4780	if (xr == 0. && xi == 0.) {
4781	goto L340;
4782	}
4783	yr = (hr[enm1 + enm1 * hr_dim1] - sr) / 2.;
4784	yi = (hi[enm1 + enm1 * hi_dim1] - si) / 2.;
4785	/* Computing 2nd power */
4786	d_2 = yr;
4787	/* Computing 2nd power */
4788	d_3 = yi;
4789	d_1 = d_2 * d_2 - d_3 * d_3 + xr;
4790	d_4 = yr * 2. * yi + xi;
4791	csroot_(&d_1, &d_4, &zzr, &zzi);
4792	if (yr * zzr + yi * zzi >= 0.) {
4793	goto L310;
4794	}
4795	zzr = -zzr;
4796	zzi = -zzi;
4797	L310:
4798	d_1 = yr + zzr;
4799	d_2 = yi + zzi;
4800	cdiv_(&xr, &xi, &d_1, &d_2, &xr, &xi);
4801	sr -= xr;
4802	si -= xi;
4803	goto L340;
4804	/* .......... FORM EXCEPTIONAL SHIFT .......... */
4805	L320:
4806	sr = (d_1 = hr[en + enm1 * hr_dim1], abs(d_1)) + (d_2 = hr[enm1 + (en
4807	- 2) * hr_dim1], abs(d_2));
4808	si = 0.;
4809
4810	L340:
4811	i_1 = en;
4812	for (i = *low; i <= i_1; ++i) {
4813	hr[i + i * hr_dim1] -= sr;
4814	hi[i + i * hi_dim1] -= si;
4815	/* L360: */
4816	}
4817
4818	tr += sr;
4819	ti += si;
4820	++its;
4821	--itn;
4822	/* .......... REDUCE TO TRIANGLE (ROWS) .......... */
4823	lp1 = l + 1;
4824
4825	i_1 = en;
4826	for (i = lp1; i <= i_1; ++i) {
4827	sr = hr[i + (i - 1) * hr_dim1];
4828	hr[i + (i - 1) * hr_dim1] = 0.;
4829	d_1 = pythag_(&hr[i - 1 + (i - 1) * hr_dim1], &hi[i - 1 + (i - 1) *
4830	hi_dim1]);
4831	norm = pythag_(&d_1, &sr);
4832	xr = hr[i - 1 + (i - 1) * hr_dim1] / norm;
4833	wr[i - 1] = xr;
4834	xi = hi[i - 1 + (i - 1) * hi_dim1] / norm;
4835	wi[i - 1] = xi;
4836	hr[i - 1 + (i - 1) * hr_dim1] = norm;
4837	hi[i - 1 + (i - 1) * hi_dim1] = 0.;
4838	hi[i + (i - 1) * hi_dim1] = sr / norm;
4839
4840	i_2 = en;
4841	for (j = i; j <= i_2; ++j) {
4842	yr = hr[i - 1 + j * hr_dim1];
4843	yi = hi[i - 1 + j * hi_dim1];
4844	zzr = hr[i + j * hr_dim1];
4845	zzi = hi[i + j * hi_dim1];
4846	hr[i - 1 + j * hr_dim1] = xr * yr + xi * yi + hi[i + (i - 1) *
4847	hi_dim1] * zzr;
4848	hi[i - 1 + j * hi_dim1] = xr * yi - xi * yr + hi[i + (i - 1) *
4849	hi_dim1] * zzi;
4850	hr[i + j * hr_dim1] = xr * zzr - xi * zzi - hi[i + (i - 1) *
4851	hi_dim1] * yr;
4852	hi[i + j * hi_dim1] = xr * zzi + xi * zzr - hi[i + (i - 1) *
4853	hi_dim1] * yi;
4854	/* L490: */
4855	}
4856
4857	/* L500: */
4858	}
4859
4860	si = hi[en + en * hi_dim1];
4861	if (si == 0.) {
4862	goto L540;
4863	}
4864	norm = pythag_(&hr[en + en * hr_dim1], &si);
4865	sr = hr[en + en * hr_dim1] / norm;
4866	si /= norm;
4867	hr[en + en * hr_dim1] = norm;
4868	hi[en + en * hi_dim1] = 0.;
4869	/* .......... INVERSE OPERATION (COLUMNS) .......... */
4870	L540:
4871	i_1 = en;
4872	for (j = lp1; j <= i_1; ++j) {
4873	xr = wr[j - 1];
4874	xi = wi[j - 1];
4875
4876	i_2 = j;
4877	for (i = l; i <= i_2; ++i) {
4878	yr = hr[i + (j - 1) * hr_dim1];
4879	yi = 0.;
4880	zzr = hr[i + j * hr_dim1];
4881	zzi = hi[i + j * hi_dim1];
4882	if (i == j) {
4883	goto L560;
4884	}
4885	yi = hi[i + (j - 1) * hi_dim1];
4886	hi[i + (j - 1) * hi_dim1] = xr * yi + xi * yr + hi[j + (j - 1) *
4887	hi_dim1] * zzi;
4888	L560:
4889	hr[i + (j - 1) * hr_dim1] = xr * yr - xi * yi + hi[j + (j - 1) *
4890	hi_dim1] * zzr;
4891	hr[i + j * hr_dim1] = xr * zzr + xi * zzi - hi[j + (j - 1) *
4892	hi_dim1] * yr;
4893	hi[i + j * hi_dim1] = xr * zzi - xi * zzr - hi[j + (j - 1) *
4894	hi_dim1] * yi;
4895	/* L580: */
4896	}
4897
4898	/* L600: */
4899	}
4900
4901	if (si == 0.) {
4902	goto L240;
4903	}
4904
4905	i_1 = en;
4906	for (i = l; i <= i_1; ++i) {
4907	yr = hr[i + en * hr_dim1];
4908	yi = hi[i + en * hi_dim1];
4909	hr[i + en * hr_dim1] = sr * yr - si * yi;
4910	hi[i + en * hi_dim1] = sr * yi + si * yr;
4911	/* L630: */
4912	}
4913
4914	goto L240;
4915	/* .......... A ROOT FOUND .......... */
4916	L660:
4917	wr[en] = hr[en + en * hr_dim1] + tr;
4918	wi[en] = hi[en + en * hi_dim1] + ti;
4919	en = enm1;
4920	goto L220;
4921	/* .......... SET ERROR -- ALL EIGENVALUES HAVE NOT */
4922	/* CONVERGED AFTER 30N ITERATIONS .......... /
4923	L1000:
4924	*ierr = en;
4925	L1001:
4926	return 0;
4927	} /* comqr_ */
4928
4929	/* Subroutine / int comqr2_(integer nm, integer n, integer low, integer *
4930	igh, doublereal ortr, doublereal orti, doublereal hr, doublereal
4931	hi, doublereal wr, doublereal wi, doublereal zr, doublereal zi,
4932	integer *ierr)
4933	{
4934	/* System generated locals */
4935	integer hr_dim1, hr_offset, hi_dim1, hi_offset, zr_dim1, zr_offset,
4936	zi_dim1, zi_offset, i_1, i_2, i_3;
4937	doublereal d_1, d_2, d_3, d_4;
4938
4939	/* Local variables */
4940	static integer iend;
4941	extern /* Subroutine / int cdiv_(doublereal , doublereal , doublereal
4942	, doublereal , doublereal , doublereal *);
4943	static doublereal norm;
4944	static integer i, j, k, l, m, ii, en, jj, ll, nn;
4945	static doublereal si, ti, xi, yi, sr, tr, xr, yr;
4946	extern doublereal pythag_(doublereal , doublereal );
4947	extern /* Subroutine / int csroot_(doublereal , doublereal *,
4948	doublereal , doublereal );
4949	static integer ip1, lp1, itn, its;
4950	static doublereal zzi, zzr;
4951	static integer enm1;
4952	static doublereal tst1, tst2;
4953
4954
4955
4956	/* THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE */
4957	/* ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS */
4958	/* AND WILKINSON. */
4959	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). */
4960	/* THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS */
4961	/* (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM. */
4962
4963	/* THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS */
4964	/* OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR */
4965	/* METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX */
4966	/* CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE */
4967	/* THIS GENERAL MATRIX TO HESSENBERG FORM. */
4968
4969	/* ON INPUT */
4970
4971	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
4972	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
4973	/* DIMENSION STATEMENT. */
4974
4975	/* N IS THE ORDER OF THE MATRIX. */
4976
4977	/* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
4978	/* SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, */
4979	/* SET LOW=1, IGH=N. */
4980
4981	/* ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS- */
4982	/* FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED. */
4983	/* ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
4984	*/
4985	/* OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND */
4986	/* ORTI(J) TO 0.0D0 FOR THESE ELEMENTS. */
4987
4988	/* HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, */
4989	/* RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. */
4990	/* THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER */
4991	/* INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
4992	*/
4993	/* REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF */
4994	/* THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE */
4995	/* ARBITRARY. */
4996
4997	/* ON OUTPUT */
4998
4999	/* ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI */
5000	/* HAVE BEEN DESTROYED. */
5001
5002	/* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, */
5003	/* RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR */
5004	/* EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT */
5005	/* FOR INDICES IERR+1,...,N. */
5006
5007	/* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */
5008	/* RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS */
5009	/* ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF */
5010	/* THE EIGENVECTORS HAS BEEN FOUND. */
5011
5012	/* IERR IS SET TO */
5013	/* ZERO FOR NORMAL RETURN, */
5014	/* J IF THE LIMIT OF 30N ITERATIONS IS EXHAUSTED /
5015	/* WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. */
5016
5017	/* CALLS CDIV FOR COMPLEX DIVISION. */
5018	/* CALLS CSROOT FOR COMPLEX SQUARE ROOT. */
5019	/* CALLS PYTHAG FOR DSQRT(AA + BB) . */
5020
5021	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
5022	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
5023	*/
5024
5025	/* THIS VERSION DATED AUGUST 1983. */
5026
5027	/* ------------------------------------------------------------------
5028	*/
5029
5030	/* Parameter adjustments */
5031	zi_dim1 = *nm;
5032	zi_offset = zi_dim1 + 1;
5033	zi -= zi_offset;
5034	zr_dim1 = *nm;
5035	zr_offset = zr_dim1 + 1;
5036	zr -= zr_offset;
5037	--wi;
5038	--wr;
5039	hi_dim1 = *nm;
5040	hi_offset = hi_dim1 + 1;
5041	hi -= hi_offset;
5042	hr_dim1 = *nm;
5043	hr_offset = hr_dim1 + 1;
5044	hr -= hr_offset;
5045	--orti;
5046	--ortr;
5047
5048	/* Function Body */
5049	*ierr = 0;
5050	/* .......... INITIALIZE EIGENVECTOR MATRIX .......... */
5051	i_1 = *n;
5052	for (j = 1; j <= i_1; ++j) {
5053
5054	i_2 = *n;
5055	for (i = 1; i <= i_2; ++i) {
5056	zr[i + j * zr_dim1] = 0.;
5057	zi[i + j * zi_dim1] = 0.;
5058	/* L100: */
5059	}
5060	zr[j + j * zr_dim1] = 1.;
5061	/* L101: */
5062	}
5063	/* .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS */
5064	/* FROM THE INFORMATION LEFT BY CORTH .......... */
5065	iend = igh - low - 1;
5066	if (iend < 0) {
5067	goto L180;
5068	} else if (iend == 0) {
5069	goto L150;
5070	} else {
5071	goto L105;
5072	}
5073	/* .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... */
5074	L105:
5075	i_1 = iend;
5076	for (ii = 1; ii <= i_1; ++ii) {
5077	i = *igh - ii;
5078	if (ortr[i] == 0. && orti[i] == 0.) {
5079	goto L140;
5080	}
5081	if (hr[i + (i - 1) * hr_dim1] == 0. && hi[i + (i - 1) * hi_dim1] ==
5082	0.) {
5083	goto L140;
5084	}
5085	/* .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ........
5086	.. */
5087	norm = hr[i + (i - 1) * hr_dim1] * ortr[i] + hi[i + (i - 1) * hi_dim1]
5088	* orti[i];
5089	ip1 = i + 1;
5090
5091	i_2 = *igh;
5092	for (k = ip1; k <= i_2; ++k) {
5093	ortr[k] = hr[k + (i - 1) * hr_dim1];
5094	orti[k] = hi[k + (i - 1) * hi_dim1];
5095	/* L110: */
5096	}
5097
5098	i_2 = *igh;
5099	for (j = i; j <= i_2; ++j) {
5100	sr = 0.;
5101	si = 0.;
5102
5103	i_3 = *igh;
5104	for (k = i; k <= i_3; ++k) {
5105	sr = sr + ortr[k] * zr[k + j * zr_dim1] + orti[k] * zi[k + j *
5106	zi_dim1];
5107	si = si + ortr[k] * zi[k + j * zi_dim1] - orti[k] * zr[k + j *
5108	zr_dim1];
5109	/* L115: */
5110	}
5111
5112	sr /= norm;
5113	si /= norm;
5114
5115	i_3 = *igh;
5116	for (k = i; k <= i_3; ++k) {
5117	zr[k + j * zr_dim1] = zr[k + j * zr_dim1] + sr * ortr[k] - si
5118	* orti[k];
5119	zi[k + j * zi_dim1] = zi[k + j * zi_dim1] + sr * orti[k] + si
5120	* ortr[k];
5121	/* L120: */
5122	}
5123
5124	/* L130: */
5125	}
5126
5127	L140:
5128	;
5129	}
5130	/* .......... CREATE REAL SUBDIAGONAL ELEMENTS .......... */
5131	L150:
5132	l = *low + 1;
5133
5134	i_1 = *igh;
5135	for (i = l; i <= i_1; ++i) {
5136	/* Computing MIN */
5137	i_2 = i + 1;
5138	ll = min(i_2,*igh);
5139	if (hi[i + (i - 1) * hi_dim1] == 0.) {
5140	goto L170;
5141	}
5142	norm = pythag_(&hr[i + (i - 1) * hr_dim1], &hi[i + (i - 1) * hi_dim1])
5143	;
5144	yr = hr[i + (i - 1) * hr_dim1] / norm;
5145	yi = hi[i + (i - 1) * hi_dim1] / norm;
5146	hr[i + (i - 1) * hr_dim1] = norm;
5147	hi[i + (i - 1) * hi_dim1] = 0.;
5148
5149	i_2 = *n;
5150	for (j = i; j <= i_2; ++j) {
5151	si = yr * hi[i + j * hi_dim1] - yi * hr[i + j * hr_dim1];
5152	hr[i + j * hr_dim1] = yr * hr[i + j * hr_dim1] + yi * hi[i + j *
5153	hi_dim1];
5154	hi[i + j * hi_dim1] = si;
5155	/* L155: */
5156	}
5157
5158	i_2 = ll;
5159	for (j = 1; j <= i_2; ++j) {
5160	si = yr * hi[j + i * hi_dim1] + yi * hr[j + i * hr_dim1];
5161	hr[j + i * hr_dim1] = yr * hr[j + i * hr_dim1] - yi * hi[j + i *
5162	hi_dim1];
5163	hi[j + i * hi_dim1] = si;
5164	/* L160: */
5165	}
5166
5167	i_2 = *igh;
5168	for (j = *low; j <= i_2; ++j) {
5169	si = yr * zi[j + i * zi_dim1] + yi * zr[j + i * zr_dim1];
5170	zr[j + i * zr_dim1] = yr * zr[j + i * zr_dim1] - yi * zi[j + i *
5171	zi_dim1];
5172	zi[j + i * zi_dim1] = si;
5173	/* L165: */
5174	}
5175
5176	L170:
5177	;
5178	}
5179	/* .......... STORE ROOTS ISOLATED BY CBAL .......... */
5180	L180:
5181	i_1 = *n;
5182	for (i = 1; i <= i_1; ++i) {
5183	if (i >= low && i <= igh) {
5184	goto L200;
5185	}
5186	wr[i] = hr[i + i * hr_dim1];
5187	wi[i] = hi[i + i * hi_dim1];
5188	L200:
5189	;
5190	}
5191
5192	en = *igh;
5193	tr = 0.;
5194	ti = 0.;
5195	itn = n 30;
5196	/* .......... SEARCH FOR NEXT EIGENVALUE .......... */
5197	L220:
5198	if (en < *low) {
5199	goto L680;
5200	}
5201	its = 0;
5202	enm1 = en - 1;
5203	/* .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT */
5204	/* FOR L=EN STEP -1 UNTIL LOW DO -- .......... */
5205	L240:
5206	i_1 = en;
5207	for (ll = *low; ll <= i_1; ++ll) {
5208	l = en + *low - ll;
5209	if (l == *low) {
5210	goto L300;
5211	}
5212	tst1 = (d_1 = hr[l - 1 + (l - 1) * hr_dim1], abs(d_1)) + (d_2 = hi[
5213	l - 1 + (l - 1) * hi_dim1], abs(d_2)) + (d_3 = hr[l + l *
5214	hr_dim1], abs(d_3)) + (d_4 = hi[l + l * hi_dim1], abs(d_4))
5215	;
5216	tst2 = tst1 + (d_1 = hr[l + (l - 1) * hr_dim1], abs(d_1));
5217	if (tst2 == tst1) {
5218	goto L300;
5219	}
5220	/* L260: */
5221	}
5222	/* .......... FORM SHIFT .......... */
5223	L300:
5224	if (l == en) {
5225	goto L660;
5226	}
5227	if (itn == 0) {
5228	goto L1000;
5229	}
5230	if (its == 10 \|\| its == 20) {
5231	goto L320;
5232	}
5233	sr = hr[en + en * hr_dim1];
5234	si = hi[en + en * hi_dim1];
5235	xr = hr[enm1 + en * hr_dim1] * hr[en + enm1 * hr_dim1];
5236	xi = hi[enm1 + en * hi_dim1] * hr[en + enm1 * hr_dim1];
5237	if (xr == 0. && xi == 0.) {
5238	goto L340;
5239	}
5240	yr = (hr[enm1 + enm1 * hr_dim1] - sr) / 2.;
5241	yi = (hi[enm1 + enm1 * hi_dim1] - si) / 2.;
5242	/* Computing 2nd power */
5243	d_2 = yr;
5244	/* Computing 2nd power */
5245	d_3 = yi;
5246	d_1 = d_2 * d_2 - d_3 * d_3 + xr;
5247	d_4 = yr * 2. * yi + xi;
5248	csroot_(&d_1, &d_4, &zzr, &zzi);
5249	if (yr * zzr + yi * zzi >= 0.) {
5250	goto L310;
5251	}
5252	zzr = -zzr;
5253	zzi = -zzi;
5254	L310:
5255	d_1 = yr + zzr;
5256	d_2 = yi + zzi;
5257	cdiv_(&xr, &xi, &d_1, &d_2, &xr, &xi);
5258	sr -= xr;
5259	si -= xi;
5260	goto L340;
5261	/* .......... FORM EXCEPTIONAL SHIFT .......... */
5262	L320:
5263	sr = (d_1 = hr[en + enm1 * hr_dim1], abs(d_1)) + (d_2 = hr[enm1 + (en
5264	- 2) * hr_dim1], abs(d_2));
5265	si = 0.;
5266
5267	L340:
5268	i_1 = en;
5269	for (i = *low; i <= i_1; ++i) {
5270	hr[i + i * hr_dim1] -= sr;
5271	hi[i + i * hi_dim1] -= si;
5272	/* L360: */
5273	}
5274
5275	tr += sr;
5276	ti += si;
5277	++its;
5278	--itn;
5279	/* .......... REDUCE TO TRIANGLE (ROWS) .......... */
5280	lp1 = l + 1;
5281
5282	i_1 = en;
5283	for (i = lp1; i <= i_1; ++i) {
5284	sr = hr[i + (i - 1) * hr_dim1];
5285	hr[i + (i - 1) * hr_dim1] = 0.;
5286	d_1 = pythag_(&hr[i - 1 + (i - 1) * hr_dim1], &hi[i - 1 + (i - 1) *
5287	hi_dim1]);
5288	norm = pythag_(&d_1, &sr);
5289	xr = hr[i - 1 + (i - 1) * hr_dim1] / norm;
5290	wr[i - 1] = xr;
5291	xi = hi[i - 1 + (i - 1) * hi_dim1] / norm;
5292	wi[i - 1] = xi;
5293	hr[i - 1 + (i - 1) * hr_dim1] = norm;
5294	hi[i - 1 + (i - 1) * hi_dim1] = 0.;
5295	hi[i + (i - 1) * hi_dim1] = sr / norm;
5296
5297	i_2 = *n;
5298	for (j = i; j <= i_2; ++j) {
5299	yr = hr[i - 1 + j * hr_dim1];
5300	yi = hi[i - 1 + j * hi_dim1];
5301	zzr = hr[i + j * hr_dim1];
5302	zzi = hi[i + j * hi_dim1];
5303	hr[i - 1 + j * hr_dim1] = xr * yr + xi * yi + hi[i + (i - 1) *
5304	hi_dim1] * zzr;
5305	hi[i - 1 + j * hi_dim1] = xr * yi - xi * yr + hi[i + (i - 1) *
5306	hi_dim1] * zzi;
5307	hr[i + j * hr_dim1] = xr * zzr - xi * zzi - hi[i + (i - 1) *
5308	hi_dim1] * yr;
5309	hi[i + j * hi_dim1] = xr * zzi + xi * zzr - hi[i + (i - 1) *
5310	hi_dim1] * yi;
5311	/* L490: */
5312	}
5313
5314	/* L500: */
5315	}
5316
5317	si = hi[en + en * hi_dim1];
5318	if (si == 0.) {
5319	goto L540;
5320	}
5321	norm = pythag_(&hr[en + en * hr_dim1], &si);
5322	sr = hr[en + en * hr_dim1] / norm;
5323	si /= norm;
5324	hr[en + en * hr_dim1] = norm;
5325	hi[en + en * hi_dim1] = 0.;
5326	if (en == *n) {
5327	goto L540;
5328	}
5329	ip1 = en + 1;
5330
5331	i_1 = *n;
5332	for (j = ip1; j <= i_1; ++j) {
5333	yr = hr[en + j * hr_dim1];
5334	yi = hi[en + j * hi_dim1];
5335	hr[en + j * hr_dim1] = sr * yr + si * yi;
5336	hi[en + j * hi_dim1] = sr * yi - si * yr;
5337	/* L520: */
5338	}
5339	/* .......... INVERSE OPERATION (COLUMNS) .......... */
5340	L540:
5341	i_1 = en;
5342	for (j = lp1; j <= i_1; ++j) {
5343	xr = wr[j - 1];
5344	xi = wi[j - 1];
5345
5346	i_2 = j;
5347	for (i = 1; i <= i_2; ++i) {
5348	yr = hr[i + (j - 1) * hr_dim1];
5349	yi = 0.;
5350	zzr = hr[i + j * hr_dim1];
5351	zzi = hi[i + j * hi_dim1];
5352	if (i == j) {
5353	goto L560;
5354	}
5355	yi = hi[i + (j - 1) * hi_dim1];
5356	hi[i + (j - 1) * hi_dim1] = xr * yi + xi * yr + hi[j + (j - 1) *
5357	hi_dim1] * zzi;
5358	L560:
5359	hr[i + (j - 1) * hr_dim1] = xr * yr - xi * yi + hi[j + (j - 1) *
5360	hi_dim1] * zzr;
5361	hr[i + j * hr_dim1] = xr * zzr + xi * zzi - hi[j + (j - 1) *
5362	hi_dim1] * yr;
5363	hi[i + j * hi_dim1] = xr * zzi - xi * zzr - hi[j + (j - 1) *
5364	hi_dim1] * yi;
5365	/* L580: */
5366	}
5367
5368	i_2 = *igh;
5369	for (i = *low; i <= i_2; ++i) {
5370	yr = zr[i + (j - 1) * zr_dim1];
5371	yi = zi[i + (j - 1) * zi_dim1];
5372	zzr = zr[i + j * zr_dim1];
5373	zzi = zi[i + j * zi_dim1];
5374	zr[i + (j - 1) * zr_dim1] = xr * yr - xi * yi + hi[j + (j - 1) *
5375	hi_dim1] * zzr;
5376	zi[i + (j - 1) * zi_dim1] = xr * yi + xi * yr + hi[j + (j - 1) *
5377	hi_dim1] * zzi;
5378	zr[i + j * zr_dim1] = xr * zzr + xi * zzi - hi[j + (j - 1) *
5379	hi_dim1] * yr;
5380	zi[i + j * zi_dim1] = xr * zzi - xi * zzr - hi[j + (j - 1) *
5381	hi_dim1] * yi;
5382	/* L590: */
5383	}
5384
5385	/* L600: */
5386	}
5387
5388	if (si == 0.) {
5389	goto L240;
5390	}
5391
5392	i_1 = en;
5393	for (i = 1; i <= i_1; ++i) {
5394	yr = hr[i + en * hr_dim1];
5395	yi = hi[i + en * hi_dim1];
5396	hr[i + en * hr_dim1] = sr * yr - si * yi;
5397	hi[i + en * hi_dim1] = sr * yi + si * yr;
5398	/* L630: */
5399	}
5400
5401	i_1 = *igh;
5402	for (i = *low; i <= i_1; ++i) {
5403	yr = zr[i + en * zr_dim1];
5404	yi = zi[i + en * zi_dim1];
5405	zr[i + en * zr_dim1] = sr * yr - si * yi;
5406	zi[i + en * zi_dim1] = sr * yi + si * yr;
5407	/* L640: */
5408	}
5409
5410	goto L240;
5411	/* .......... A ROOT FOUND .......... */
5412	L660:
5413	hr[en + en * hr_dim1] += tr;
5414	wr[en] = hr[en + en * hr_dim1];
5415	hi[en + en * hi_dim1] += ti;
5416	wi[en] = hi[en + en * hi_dim1];
5417	en = enm1;
5418	goto L220;
5419	/* .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND */
5420	/* VECTORS OF UPPER TRIANGULAR FORM .......... */
5421	L680:
5422	norm = 0.;
5423
5424	i_1 = *n;
5425	for (i = 1; i <= i_1; ++i) {
5426
5427	i_2 = *n;
5428	for (j = i; j <= i_2; ++j) {
5429	tr = (d_1 = hr[i + j * hr_dim1], abs(d_1)) + (d_2 = hi[i + j *
5430	hi_dim1], abs(d_2));
5431	if (tr > norm) {
5432	norm = tr;
5433	}
5434	/* L720: */
5435	}
5436	}
5437
5438	if (*n == 1 \|\| norm == 0.) {
5439	goto L1001;
5440	}
5441	/* .......... FOR EN=N STEP -1 UNTIL 2 DO -- .......... */
5442	i_2 = *n;
5443	for (nn = 2; nn <= i_2; ++nn) {
5444	en = *n + 2 - nn;
5445	xr = wr[en];
5446	xi = wi[en];
5447	hr[en + en * hr_dim1] = 1.;
5448	hi[en + en * hi_dim1] = 0.;
5449	enm1 = en - 1;
5450	/* .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... */
5451	i_1 = enm1;
5452	for (ii = 1; ii <= i_1; ++ii) {
5453	i = en - ii;
5454	zzr = 0.;
5455	zzi = 0.;
5456	ip1 = i + 1;
5457
5458	i_3 = en;
5459	for (j = ip1; j <= i_3; ++j) {
5460	zzr = zzr + hr[i + j * hr_dim1] * hr[j + en * hr_dim1] - hi[i
5461	+ j * hi_dim1] * hi[j + en * hi_dim1];
5462	zzi = zzi + hr[i + j * hr_dim1] * hi[j + en * hi_dim1] + hi[i
5463	+ j * hi_dim1] * hr[j + en * hr_dim1];
5464	/* L740: */
5465	}
5466
5467	yr = xr - wr[i];
5468	yi = xi - wi[i];
5469	if (yr != 0. \|\| yi != 0.) {
5470	goto L765;
5471	}
5472	tst1 = norm;
5473	yr = tst1;
5474	L760:
5475	yr *= .01;
5476	tst2 = norm + yr;
5477	if (tst2 > tst1) {
5478	goto L760;
5479	}
5480	L765:
5481	cdiv_(&zzr, &zzi, &yr, &yi, &hr[i + en * hr_dim1], &hi[i + en *
5482	hi_dim1]);
5483	/* .......... OVERFLOW CONTROL .......... */
5484	tr = (d_1 = hr[i + en * hr_dim1], abs(d_1)) + (d_2 = hi[i + en
5485	* hi_dim1], abs(d_2));
5486	if (tr == 0.) {
5487	goto L780;
5488	}
5489	tst1 = tr;
5490	tst2 = tst1 + 1. / tst1;
5491	if (tst2 > tst1) {
5492	goto L780;
5493	}
5494	i_3 = en;
5495	for (j = i; j <= i_3; ++j) {
5496	hr[j + en * hr_dim1] /= tr;
5497	hi[j + en * hi_dim1] /= tr;
5498	/* L770: */
5499	}
5500
5501	L780:
5502	;
5503	}
5504
5505	/* L800: */
5506	}
5507	/* .......... END BACKSUBSTITUTION .......... */
5508	enm1 = *n - 1;
5509	/* .......... VECTORS OF ISOLATED ROOTS .......... */
5510	i_2 = enm1;
5511	for (i = 1; i <= i_2; ++i) {
5512	if (i >= low && i <= igh) {
5513	goto L840;
5514	}
5515	ip1 = i + 1;
5516
5517	i_1 = *n;
5518	for (j = ip1; j <= i_1; ++j) {
5519	zr[i + j * zr_dim1] = hr[i + j * hr_dim1];
5520	zi[i + j * zi_dim1] = hi[i + j * hi_dim1];
5521	/* L820: */
5522	}
5523
5524	L840:
5525	;
5526	}
5527	/* .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE */
5528	/* VECTORS OF ORIGINAL FULL MATRIX. */
5529	/* FOR J=N STEP -1 UNTIL LOW+1 DO -- .......... */
5530	i_2 = enm1;
5531	for (jj = *low; jj <= i_2; ++jj) {
5532	j = n + low - jj;
5533	m = min(j,*igh);
5534
5535	i_1 = *igh;
5536	for (i = *low; i <= i_1; ++i) {
5537	zzr = 0.;
5538	zzi = 0.;
5539
5540	i_3 = m;
5541	for (k = *low; k <= i_3; ++k) {
5542	zzr = zzr + zr[i + k * zr_dim1] * hr[k + j * hr_dim1] - zi[i
5543	+ k * zi_dim1] * hi[k + j * hi_dim1];
5544	zzi = zzi + zr[i + k * zr_dim1] * hi[k + j * hi_dim1] + zi[i
5545	+ k * zi_dim1] * hr[k + j * hr_dim1];
5546	/* L860: */
5547	}
5548
5549	zr[i + j * zr_dim1] = zzr;
5550	zi[i + j * zi_dim1] = zzi;
5551	/* L880: */
5552	}
5553	}
5554
5555	goto L1001;
5556	/* .......... SET ERROR -- ALL EIGENVALUES HAVE NOT */
5557	/* CONVERGED AFTER 30N ITERATIONS .......... /
5558	L1000:
5559	*ierr = en;
5560	L1001:
5561	return 0;
5562	} /* comqr2_ */
5563
5564	/* Subroutine / int cortb_(integer nm, integer low, integer igh,
5565	doublereal ar, doublereal ai, doublereal ortr, doublereal orti,
5566	integer m, doublereal zr, doublereal *zi)
5567	{
5568	/* System generated locals */
5569	integer ar_dim1, ar_offset, ai_dim1, ai_offset, zr_dim1, zr_offset,
5570	zi_dim1, zi_offset, i_1, i_2, i_3;
5571
5572	/* Local variables */
5573	static doublereal h;
5574	static integer i, j, la;
5575	static doublereal gi, gr;
5576	static integer mm, mp, kp1, mp1;
5577
5578
5579
5580	/* THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF */
5581	/* THE ALGOL PROCEDURE ORTBAK, NUM. MATH. 12, 349-368(1968) */
5582	/* BY MARTIN AND WILKINSON. */
5583	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). */
5584
5585	/* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL */
5586	/* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */
5587	/* UPPER HESSENBERG MATRIX DETERMINED BY CORTH. */
5588
5589	/* ON INPUT */
5590
5591	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
5592	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
5593	/* DIMENSION STATEMENT. */
5594
5595	/* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
5596	/* SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, */
5597	/* SET LOW=1 AND IGH EQUAL TO THE ORDER OF THE MATRIX. */
5598
5599	/* AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY */
5600	/* TRANSFORMATIONS USED IN THE REDUCTION BY CORTH */
5601	/* IN THEIR STRICT LOWER TRIANGLES. */
5602
5603	/* ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE */
5604	/* TRANSFORMATIONS USED IN THE REDUCTION BY CORTH. */
5605	/* ONLY ELEMENTS LOW THROUGH IGH ARE USED. */
5606
5607	/* M IS THE NUMBER OF COLUMNS OF ZR AND ZI TO BE BACK TRANSFORMED.
5608	*/
5609
5610	/* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */
5611	/* RESPECTIVELY, OF THE EIGENVECTORS TO BE */
5612	/* BACK TRANSFORMED IN THEIR FIRST M COLUMNS. */
5613
5614	/* ON OUTPUT */
5615
5616	/* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */
5617	/* RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS */
5618	/* IN THEIR FIRST M COLUMNS. */
5619
5620	/* ORTR AND ORTI HAVE BEEN ALTERED. */
5621
5622	/* NOTE THAT CORTB PRESERVES VECTOR EUCLIDEAN NORMS. */
5623
5624	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
5625	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
5626	*/
5627
5628	/* THIS VERSION DATED AUGUST 1983. */
5629
5630	/* ------------------------------------------------------------------
5631	*/
5632
5633	/* Parameter adjustments */
5634	--orti;
5635	--ortr;
5636	ai_dim1 = *nm;
5637	ai_offset = ai_dim1 + 1;
5638	ai -= ai_offset;
5639	ar_dim1 = *nm;
5640	ar_offset = ar_dim1 + 1;
5641	ar -= ar_offset;
5642	zi_dim1 = *nm;
5643	zi_offset = zi_dim1 + 1;
5644	zi -= zi_offset;
5645	zr_dim1 = *nm;
5646	zr_offset = zr_dim1 + 1;
5647	zr -= zr_offset;
5648
5649	/* Function Body */
5650	if (*m == 0) {
5651	goto L200;
5652	}
5653	la = *igh - 1;
5654	kp1 = *low + 1;
5655	if (la < kp1) {
5656	goto L200;
5657	}
5658	/* .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... */
5659	i_1 = la;
5660	for (mm = kp1; mm <= i_1; ++mm) {
5661	mp = low + igh - mm;
5662	if (ar[mp + (mp - 1) * ar_dim1] == 0. && ai[mp + (mp - 1) * ai_dim1]
5663	== 0.) {
5664	goto L140;
5665	}
5666	/* .......... H BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
5667	*/
5668	h = ar[mp + (mp - 1) * ar_dim1] * ortr[mp] + ai[mp + (mp - 1) *
5669	ai_dim1] * orti[mp];
5670	mp1 = mp + 1;
5671
5672	i_2 = *igh;
5673	for (i = mp1; i <= i_2; ++i) {
5674	ortr[i] = ar[i + (mp - 1) * ar_dim1];
5675	orti[i] = ai[i + (mp - 1) * ai_dim1];
5676	/* L100: */
5677	}
5678
5679	i_2 = *m;
5680	for (j = 1; j <= i_2; ++j) {
5681	gr = 0.;
5682	gi = 0.;
5683
5684	i_3 = *igh;
5685	for (i = mp; i <= i_3; ++i) {
5686	gr = gr + ortr[i] * zr[i + j * zr_dim1] + orti[i] * zi[i + j *
5687	zi_dim1];
5688	gi = gi + ortr[i] * zi[i + j * zi_dim1] - orti[i] * zr[i + j *
5689	zr_dim1];
5690	/* L110: */
5691	}
5692
5693	gr /= h;
5694	gi /= h;
5695
5696	i_3 = *igh;
5697	for (i = mp; i <= i_3; ++i) {
5698	zr[i + j * zr_dim1] = zr[i + j * zr_dim1] + gr * ortr[i] - gi
5699	* orti[i];
5700	zi[i + j * zi_dim1] = zi[i + j * zi_dim1] + gr * orti[i] + gi
5701	* ortr[i];
5702	/* L120: */
5703	}
5704
5705	/* L130: */
5706	}
5707
5708	L140:
5709	;
5710	}
5711
5712	L200:
5713	return 0;
5714	} /* cortb_ */
5715
5716	/* Subroutine / int corth_(integer nm, integer n, integer low, integer *
5717	igh, doublereal ar, doublereal ai, doublereal ortr, doublereal
5718	orti)
5719	{
5720	/* System generated locals */
5721	integer ar_dim1, ar_offset, ai_dim1, ai_offset, i_1, i_2, i_3;
5722	doublereal d_1, d_2;
5723
5724	/* Builtin functions */
5725	double sqrt(doublereal);
5726
5727	/* Local variables */
5728	static doublereal f, g, h;
5729	static integer i, j, m;
5730	static doublereal scale;
5731	static integer la;
5732	static doublereal fi;
5733	static integer ii, jj;
5734	static doublereal fr;
5735	static integer mp;
5736	extern doublereal pythag_(doublereal , doublereal );
5737	static integer kp1;
5738
5739
5740
5741	/* THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF */
5742	/* THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968) */
5743	/* BY MARTIN AND WILKINSON. */
5744	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). */
5745
5746	/* GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE */
5747	/* REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS */
5748	/* LOW THROUGH IGH TO UPPER HESSENBERG FORM BY */
5749	/* UNITARY SIMILARITY TRANSFORMATIONS. */
5750
5751	/* ON INPUT */
5752
5753	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
5754	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
5755	/* DIMENSION STATEMENT. */
5756
5757	/* N IS THE ORDER OF THE MATRIX. */
5758
5759	/* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
5760	/* SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, */
5761	/* SET LOW=1, IGH=N. */
5762
5763	/* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */
5764	/* RESPECTIVELY, OF THE COMPLEX INPUT MATRIX. */
5765
5766	/* ON OUTPUT */
5767
5768	/* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */
5769	/* RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION */
5770	/* ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION */
5771	/* IS STORED IN THE REMAINING TRIANGLES UNDER THE */
5772	/* HESSENBERG MATRIX. */
5773
5774	/* ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE */
5775	/* TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED. */
5776
5777	/* CALLS PYTHAG FOR DSQRT(AA + BB) . */
5778
5779	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
5780	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
5781	*/
5782
5783	/* THIS VERSION DATED AUGUST 1983. */
5784
5785	/* ------------------------------------------------------------------
5786	*/
5787
5788	/* Parameter adjustments */
5789	ai_dim1 = *nm;
5790	ai_offset = ai_dim1 + 1;
5791	ai -= ai_offset;
5792	ar_dim1 = *nm;
5793	ar_offset = ar_dim1 + 1;
5794	ar -= ar_offset;
5795	--orti;
5796	--ortr;
5797
5798	/* Function Body */
5799	la = *igh - 1;
5800	kp1 = *low + 1;
5801	if (la < kp1) {
5802	goto L200;
5803	}
5804
5805	i_1 = la;
5806	for (m = kp1; m <= i_1; ++m) {
5807	h = 0.;
5808	ortr[m] = 0.;
5809	orti[m] = 0.;
5810	scale = 0.;
5811	/* .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
5812	*/
5813	i_2 = *igh;
5814	for (i = m; i <= i_2; ++i) {
5815	/* L90: */
5816	scale = scale + (d_1 = ar[i + (m - 1) * ar_dim1], abs(d_1)) + (
5817	d_2 = ai[i + (m - 1) * ai_dim1], abs(d_2));
5818	}
5819
5820	if (scale == 0.) {
5821	goto L180;
5822	}
5823	mp = m + *igh;
5824	/* .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... */
5825	i_2 = *igh;
5826	for (ii = m; ii <= i_2; ++ii) {
5827	i = mp - ii;
5828	ortr[i] = ar[i + (m - 1) * ar_dim1] / scale;
5829	orti[i] = ai[i + (m - 1) * ai_dim1] / scale;
5830	h = h + ortr[i] * ortr[i] + orti[i] * orti[i];
5831	/* L100: */
5832	}
5833
5834	g = sqrt(h);
5835	f = pythag_(&ortr[m], &orti[m]);
5836	if (f == 0.) {
5837	goto L103;
5838	}
5839	h += f * g;
5840	g /= f;
5841	ortr[m] = (g + 1.) * ortr[m];
5842	orti[m] = (g + 1.) * orti[m];
5843	goto L105;
5844
5845	L103:
5846	ortr[m] = g;
5847	ar[m + (m - 1) * ar_dim1] = scale;
5848	/* .......... FORM (I-(UUT)/H) A .......... */
5849	L105:
5850	i_2 = *n;
5851	for (j = m; j <= i_2; ++j) {
5852	fr = 0.;
5853	fi = 0.;
5854	/* .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... */
5855	i_3 = *igh;
5856	for (ii = m; ii <= i_3; ++ii) {
5857	i = mp - ii;
5858	fr = fr + ortr[i] * ar[i + j * ar_dim1] + orti[i] * ai[i + j *
5859	ai_dim1];
5860	fi = fi + ortr[i] * ai[i + j * ai_dim1] - orti[i] * ar[i + j *
5861	ar_dim1];
5862	/* L110: */
5863	}
5864
5865	fr /= h;
5866	fi /= h;
5867
5868	i_3 = *igh;
5869	for (i = m; i <= i_3; ++i) {
5870	ar[i + j * ar_dim1] = ar[i + j * ar_dim1] - fr * ortr[i] + fi
5871	* orti[i];
5872	ai[i + j * ai_dim1] = ai[i + j * ai_dim1] - fr * orti[i] - fi
5873	* ortr[i];
5874	/* L120: */
5875	}
5876
5877	/* L130: */
5878	}
5879	/* .......... FORM (I-(UUT)/H)A(I-(UUT)/H) .......... */
5880	i_2 = *igh;
5881	for (i = 1; i <= i_2; ++i) {
5882	fr = 0.;
5883	fi = 0.;
5884	/* .......... FOR J=IGH STEP -1 UNTIL M DO -- .......... */
5885	i_3 = *igh;
5886	for (jj = m; jj <= i_3; ++jj) {
5887	j = mp - jj;
5888	fr = fr + ortr[j] * ar[i + j * ar_dim1] - orti[j] * ai[i + j *
5889	ai_dim1];
5890	fi = fi + ortr[j] * ai[i + j * ai_dim1] + orti[j] * ar[i + j *
5891	ar_dim1];
5892	/* L140: */
5893	}
5894
5895	fr /= h;
5896	fi /= h;
5897
5898	i_3 = *igh;
5899	for (j = m; j <= i_3; ++j) {
5900	ar[i + j * ar_dim1] = ar[i + j * ar_dim1] - fr * ortr[j] - fi
5901	* orti[j];
5902	ai[i + j * ai_dim1] = ai[i + j * ai_dim1] + fr * orti[j] - fi
5903	* ortr[j];
5904	/* L150: */
5905	}
5906
5907	/* L160: */
5908	}
5909
5910	ortr[m] = scale * ortr[m];
5911	orti[m] = scale * orti[m];
5912	ar[m + (m - 1) * ar_dim1] = -g * ar[m + (m - 1) * ar_dim1];
5913	ai[m + (m - 1) * ai_dim1] = -g * ai[m + (m - 1) * ai_dim1];
5914	L180:
5915	;
5916	}
5917
5918	L200:
5919	return 0;
5920	} /* corth_ */
5921
5922	/* Subroutine / int elmbak_(integer nm, integer low, integer igh,
5923	doublereal a, integer int_, integer m, doublereal z)
5924	{
5925	/* System generated locals */
5926	integer a_dim1, a_offset, z_dim1, z_offset, i_1, i_2, i_3;
5927
5928	/* Local variables */
5929	static integer i, j;
5930	static doublereal x;
5931	static integer la, mm, mp, kp1, mp1;
5932
5933
5934
5935	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMBAK, */
5936	/* NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. */
5937	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). */
5938
5939	/* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL GENERAL */
5940	/* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */
5941	/* UPPER HESSENBERG MATRIX DETERMINED BY ELMHES. */
5942
5943	/* ON INPUT */
5944
5945	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
5946	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
5947	/* DIMENSION STATEMENT. */
5948
5949	/* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
5950	/* SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, */
5951	/* SET LOW=1 AND IGH EQUAL TO THE ORDER OF THE MATRIX. */
5952
5953	/* A CONTAINS THE MULTIPLIERS WHICH WERE USED IN THE */
5954	/* REDUCTION BY ELMHES IN ITS LOWER TRIANGLE */
5955	/* BELOW THE SUBDIAGONAL. */
5956
5957	/* INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS */
5958	/* INTERCHANGED IN THE REDUCTION BY ELMHES. */
5959	/* ONLY ELEMENTS LOW THROUGH IGH ARE USED. */
5960
5961	/* M IS THE NUMBER OF COLUMNS OF Z TO BE BACK TRANSFORMED. */
5962
5963	/* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGEN- */
5964	/* VECTORS TO BE BACK TRANSFORMED IN ITS FIRST M COLUMNS. */
5965
5966	/* ON OUTPUT */
5967
5968	/* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE */
5969	/* TRANSFORMED EIGENVECTORS IN ITS FIRST M COLUMNS. */
5970
5971	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
5972	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
5973	*/
5974
5975	/* THIS VERSION DATED AUGUST 1983. */
5976
5977	/* ------------------------------------------------------------------
5978	*/
5979
5980	/* Parameter adjustments */
5981	--int_;
5982	a_dim1 = *nm;
5983	a_offset = a_dim1 + 1;
5984	a -= a_offset;
5985	z_dim1 = *nm;
5986	z_offset = z_dim1 + 1;
5987	z -= z_offset;
5988
5989	/* Function Body */
5990	if (*m == 0) {
5991	goto L200;
5992	}
5993	la = *igh - 1;
5994	kp1 = *low + 1;
5995	if (la < kp1) {
5996	goto L200;
5997	}
5998	/* .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... */
5999	i_1 = la;
6000	for (mm = kp1; mm <= i_1; ++mm) {
6001	mp = low + igh - mm;
6002	mp1 = mp + 1;
6003
6004	i_2 = *igh;
6005	for (i = mp1; i <= i_2; ++i) {
6006	x = a[i + (mp - 1) * a_dim1];
6007	if (x == 0.) {
6008	goto L110;
6009	}
6010
6011	i_3 = *m;
6012	for (j = 1; j <= i_3; ++j) {
6013	/* L100: */
6014	z[i + j * z_dim1] += x * z[mp + j * z_dim1];
6015	}
6016
6017	L110:
6018	;
6019	}
6020
6021	i = int_[mp];
6022	if (i == mp) {
6023	goto L140;
6024	}
6025
6026	i_2 = *m;
6027	for (j = 1; j <= i_2; ++j) {
6028	x = z[i + j * z_dim1];
6029	z[i + j * z_dim1] = z[mp + j * z_dim1];
6030	z[mp + j * z_dim1] = x;
6031	/* L130: */
6032	}
6033
6034	L140:
6035	;
6036	}
6037
6038	L200:
6039	return 0;
6040	} /* elmbak_ */
6041
6042	/* Subroutine / int elmhes_(integer nm, integer n, integer low, integer *
6043	igh, doublereal a, integer int_)
6044	{
6045	/* System generated locals */
6046	integer a_dim1, a_offset, i_1, i_2, i_3;
6047	doublereal d_1;
6048
6049	/* Local variables */
6050	static integer i, j, m;
6051	static doublereal x, y;
6052	static integer la, mm1, kp1, mp1;
6053
6054
6055
6056	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMHES, */
6057	/* NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. */
6058	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). */
6059
6060	/* GIVEN A REAL GENERAL MATRIX, THIS SUBROUTINE */
6061	/* REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS */
6062	/* LOW THROUGH IGH TO UPPER HESSENBERG FORM BY */
6063	/* STABILIZED ELEMENTARY SIMILARITY TRANSFORMATIONS. */
6064
6065	/* ON INPUT */
6066
6067	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
6068	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
6069	/* DIMENSION STATEMENT. */
6070
6071	/* N IS THE ORDER OF THE MATRIX. */
6072
6073	/* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
6074	/* SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, */
6075	/* SET LOW=1, IGH=N. */
6076
6077	/* A CONTAINS THE INPUT MATRIX. */
6078
6079	/* ON OUTPUT */
6080
6081	/* A CONTAINS THE HESSENBERG MATRIX. THE MULTIPLIERS */
6082	/* WHICH WERE USED IN THE REDUCTION ARE STORED IN THE */
6083	/* REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX. */
6084
6085	/* INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS */
6086	/* INTERCHANGED IN THE REDUCTION. */
6087	/* ONLY ELEMENTS LOW THROUGH IGH ARE USED. */
6088
6089	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
6090	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
6091	*/
6092
6093	/* THIS VERSION DATED AUGUST 1983. */
6094
6095	/* ------------------------------------------------------------------
6096	*/
6097
6098	/* Parameter adjustments */
6099	a_dim1 = *nm;
6100	a_offset = a_dim1 + 1;
6101	a -= a_offset;
6102	--int_;
6103
6104	/* Function Body */
6105	la = *igh - 1;
6106	kp1 = *low + 1;
6107	if (la < kp1) {
6108	goto L200;
6109	}
6110
6111	i_1 = la;
6112	for (m = kp1; m <= i_1; ++m) {
6113	mm1 = m - 1;
6114	x = 0.;
6115	i = m;
6116
6117	i_2 = *igh;
6118	for (j = m; j <= i_2; ++j) {
6119	if ((d_1 = a[j + mm1 * a_dim1], abs(d_1)) <= abs(x)) {
6120	goto L100;
6121	}
6122	x = a[j + mm1 * a_dim1];
6123	i = j;
6124	L100:
6125	;
6126	}
6127
6128	int_[m] = i;
6129	if (i == m) {
6130	goto L130;
6131	}
6132	/* .......... INTERCHANGE ROWS AND COLUMNS OF A .......... */
6133	i_2 = *n;
6134	for (j = mm1; j <= i_2; ++j) {
6135	y = a[i + j * a_dim1];
6136	a[i + j * a_dim1] = a[m + j * a_dim1];
6137	a[m + j * a_dim1] = y;
6138	/* L110: */
6139	}
6140
6141	i_2 = *igh;
6142	for (j = 1; j <= i_2; ++j) {
6143	y = a[j + i * a_dim1];
6144	a[j + i * a_dim1] = a[j + m * a_dim1];
6145	a[j + m * a_dim1] = y;
6146	/* L120: */
6147	}
6148	/* .......... END INTERCHANGE .......... */
6149	L130:
6150	if (x == 0.) {
6151	goto L180;
6152	}
6153	mp1 = m + 1;
6154
6155	i_2 = *igh;
6156	for (i = mp1; i <= i_2; ++i) {
6157	y = a[i + mm1 * a_dim1];
6158	if (y == 0.) {
6159	goto L160;
6160	}
6161	y /= x;
6162	a[i + mm1 * a_dim1] = y;
6163
6164	i_3 = *n;
6165	for (j = m; j <= i_3; ++j) {
6166	/* L140: */
6167	a[i + j * a_dim1] -= y * a[m + j * a_dim1];
6168	}
6169
6170	i_3 = *igh;
6171	for (j = 1; j <= i_3; ++j) {
6172	/* L150: */
6173	a[j + m * a_dim1] += y * a[j + i * a_dim1];
6174	}
6175
6176	L160:
6177	;
6178	}
6179
6180	L180:
6181	;
6182	}
6183
6184	L200:
6185	return 0;
6186	} /* elmhes_ */
6187
6188	/* Subroutine / int eltran_(integer nm, integer n, integer low, integer *
6189	igh, doublereal a, integer int_, doublereal *z)
6190	{
6191	/* System generated locals */
6192	integer a_dim1, a_offset, z_dim1, z_offset, i_1, i_2;
6193
6194	/* Local variables */
6195	static integer i, j, kl, mm, mp, mp1;
6196
6197
6198
6199	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMTRANS,
6200	*/
6201	/* NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. */
6202	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). */
6203
6204	/* THIS SUBROUTINE ACCUMULATES THE STABILIZED ELEMENTARY */
6205	/* SIMILARITY TRANSFORMATIONS USED IN THE REDUCTION OF A */
6206	/* REAL GENERAL MATRIX TO UPPER HESSENBERG FORM BY ELMHES. */
6207
6208	/* ON INPUT */
6209
6210	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
6211	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
6212	/* DIMENSION STATEMENT. */
6213
6214	/* N IS THE ORDER OF THE MATRIX. */
6215
6216	/* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
6217	/* SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, */
6218	/* SET LOW=1, IGH=N. */
6219
6220	/* A CONTAINS THE MULTIPLIERS WHICH WERE USED IN THE */
6221	/* REDUCTION BY ELMHES IN ITS LOWER TRIANGLE */
6222	/* BELOW THE SUBDIAGONAL. */
6223
6224	/* INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS */
6225	/* INTERCHANGED IN THE REDUCTION BY ELMHES. */
6226	/* ONLY ELEMENTS LOW THROUGH IGH ARE USED. */
6227
6228	/* ON OUTPUT */
6229
6230	/* Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE */
6231	/* REDUCTION BY ELMHES. */
6232
6233	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
6234	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
6235	*/
6236
6237	/* THIS VERSION DATED AUGUST 1983. */
6238
6239	/* ------------------------------------------------------------------
6240	*/
6241
6242	/* .......... INITIALIZE Z TO IDENTITY MATRIX .......... */
6243	/* Parameter adjustments */
6244	z_dim1 = *nm;
6245	z_offset = z_dim1 + 1;
6246	z -= z_offset;
6247	--int_;
6248	a_dim1 = *nm;
6249	a_offset = a_dim1 + 1;
6250	a -= a_offset;
6251
6252	/* Function Body */
6253	i_1 = *n;
6254	for (j = 1; j <= i_1; ++j) {
6255
6256	i_2 = *n;
6257	for (i = 1; i <= i_2; ++i) {
6258	/* L60: */
6259	z[i + j * z_dim1] = 0.;
6260	}
6261
6262	z[j + j * z_dim1] = 1.;
6263	/* L80: */
6264	}
6265
6266	kl = igh - low - 1;
6267	if (kl < 1) {
6268	goto L200;
6269	}
6270	/* .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... */
6271	i_1 = kl;
6272	for (mm = 1; mm <= i_1; ++mm) {
6273	mp = *igh - mm;
6274	mp1 = mp + 1;
6275
6276	i_2 = *igh;
6277	for (i = mp1; i <= i_2; ++i) {
6278	/* L100: */
6279	z[i + mp * z_dim1] = a[i + (mp - 1) * a_dim1];
6280	}
6281
6282	i = int_[mp];
6283	if (i == mp) {
6284	goto L140;
6285	}
6286
6287	i_2 = *igh;
6288	for (j = mp; j <= i_2; ++j) {
6289	z[mp + j * z_dim1] = z[i + j * z_dim1];
6290	z[i + j * z_dim1] = 0.;
6291	/* L130: */
6292	}
6293
6294	z[i + mp * z_dim1] = 1.;
6295	L140:
6296	;
6297	}
6298
6299	L200:
6300	return 0;
6301	} /* eltran_ */
6302
6303	/* Subroutine / int figi_(integer nm, integer n, doublereal t, doublereal
6304	d, doublereal e, doublereal e2, integer ierr)
6305	{
6306	/* System generated locals */
6307	integer t_dim1, t_offset, i_1;
6308	doublereal d_1;
6309
6310	/* Builtin functions */
6311	double sqrt(doublereal);
6312
6313	/* Local variables */
6314	static integer i;
6315
6316
6317
6318	/* GIVEN A NONSYMMETRIC TRIDIAGONAL MATRIX SUCH THAT THE PRODUCTS */
6319	/* OF CORRESPONDING PAIRS OF OFF-DIAGONAL ELEMENTS ARE ALL */
6320	/* NON-NEGATIVE, THIS SUBROUTINE REDUCES IT TO A SYMMETRIC */
6321	/* TRIDIAGONAL MATRIX WITH THE SAME EIGENVALUES. IF, FURTHER, */
6322	/* A ZERO PRODUCT ONLY OCCURS WHEN BOTH FACTORS ARE ZERO, */
6323	/* THE REDUCED MATRIX IS SIMILAR TO THE ORIGINAL MATRIX. */
6324
6325	/* ON INPUT */
6326
6327	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
6328	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
6329	/* DIMENSION STATEMENT. */
6330
6331	/* N IS THE ORDER OF THE MATRIX. */
6332
6333	/* T CONTAINS THE INPUT MATRIX. ITS SUBDIAGONAL IS */
6334	/* STORED IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN, */
6335	/* ITS DIAGONAL IN THE N POSITIONS OF THE SECOND COLUMN, */
6336	/* AND ITS SUPERDIAGONAL IN THE FIRST N-1 POSITIONS OF */
6337	/* THE THIRD COLUMN. T(1,1) AND T(N,3) ARE ARBITRARY. */
6338
6339	/* ON OUTPUT */
6340
6341	/* T IS UNALTERED. */
6342
6343	/* D CONTAINS THE DIAGONAL ELEMENTS OF THE SYMMETRIC MATRIX. */
6344
6345	/* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE SYMMETRIC */
6346	/* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS NOT SET. */
6347
6348	/* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */
6349	/* E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. */
6350
6351	/* IERR IS SET TO */
6352	/* ZERO FOR NORMAL RETURN, */
6353	/* N+I IF T(I,1)T(I-1,3) IS NEGATIVE, /
6354	/* -(3N+I) IF T(I,1)T(I-1,3) IS ZERO WITH ONE FACTOR */
6355	/* NON-ZERO. IN THIS CASE, THE EIGENVECTORS OF */
6356	/* THE SYMMETRIC MATRIX ARE NOT SIMPLY RELATED */
6357	/* TO THOSE OF T AND SHOULD NOT BE SOUGHT. */
6358
6359	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
6360	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
6361	*/
6362
6363	/* THIS VERSION DATED AUGUST 1983. */
6364
6365	/* ------------------------------------------------------------------
6366	*/
6367
6368	/* Parameter adjustments */
6369	t_dim1 = *nm;
6370	t_offset = t_dim1 + 1;
6371	t -= t_offset;
6372	--e2;
6373	--e;
6374	--d;
6375
6376	/* Function Body */
6377	*ierr = 0;
6378
6379	i_1 = *n;
6380	for (i = 1; i <= i_1; ++i) {
6381	if (i == 1) {
6382	goto L90;
6383	}
6384	e2[i] = t[i + t_dim1] * t[i - 1 + t_dim1 * 3];
6385	if ((d_1 = e2[i]) < 0.) {
6386	goto L1000;
6387	} else if (d_1 == 0) {
6388	goto L60;
6389	} else {
6390	goto L80;
6391	}
6392	L60:
6393	if (t[i + t_dim1] == 0. && t[i - 1 + t_dim1 * 3] == 0.) {
6394	goto L80;
6395	}
6396	/* .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL */
6397	/* ELEMENTS IS ZERO WITH ONE MEMBER NON-ZERO ..........
6398	*/
6399	ierr = -(n * 3 + i);
6400	L80:
6401	e[i] = sqrt(e2[i]);
6402	L90:
6403	d[i] = t[i + (t_dim1 << 1)];
6404	/* L100: */
6405	}
6406
6407	goto L1001;
6408	/* .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL */
6409	/* ELEMENTS IS NEGATIVE .......... */
6410	L1000:
6411	ierr = n + i;
6412	L1001:
6413	return 0;
6414	} /* figi_ */
6415
6416	/* Subroutine / int figi2_(integer nm, integer n, doublereal t,
6417	doublereal d, doublereal e, doublereal z, integer ierr)
6418	{
6419	/* System generated locals */
6420	integer t_dim1, t_offset, z_dim1, z_offset, i_1, i_2;
6421
6422	/* Builtin functions */
6423	double sqrt(doublereal);
6424
6425	/* Local variables */
6426	static doublereal h;
6427	static integer i, j;
6428
6429
6430
6431	/* GIVEN A NONSYMMETRIC TRIDIAGONAL MATRIX SUCH THAT THE PRODUCTS */
6432	/* OF CORRESPONDING PAIRS OF OFF-DIAGONAL ELEMENTS ARE ALL */
6433	/* NON-NEGATIVE, AND ZERO ONLY WHEN BOTH FACTORS ARE ZERO, THIS */
6434	/* SUBROUTINE REDUCES IT TO A SYMMETRIC TRIDIAGONAL MATRIX */
6435	/* USING AND ACCUMULATING DIAGONAL SIMILARITY TRANSFORMATIONS. */
6436
6437	/* ON INPUT */
6438
6439	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
6440	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
6441	/* DIMENSION STATEMENT. */
6442
6443	/* N IS THE ORDER OF THE MATRIX. */
6444
6445	/* T CONTAINS THE INPUT MATRIX. ITS SUBDIAGONAL IS */
6446	/* STORED IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN, */
6447	/* ITS DIAGONAL IN THE N POSITIONS OF THE SECOND COLUMN, */
6448	/* AND ITS SUPERDIAGONAL IN THE FIRST N-1 POSITIONS OF */
6449	/* THE THIRD COLUMN. T(1,1) AND T(N,3) ARE ARBITRARY. */
6450
6451	/* ON OUTPUT */
6452
6453	/* T IS UNALTERED. */
6454
6455	/* D CONTAINS THE DIAGONAL ELEMENTS OF THE SYMMETRIC MATRIX. */
6456
6457	/* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE SYMMETRIC */
6458	/* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS NOT SET. */
6459
6460	/* Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN */
6461	/* THE REDUCTION. */
6462
6463	/* IERR IS SET TO */
6464	/* ZERO FOR NORMAL RETURN, */
6465	/* N+I IF T(I,1)T(I-1,3) IS NEGATIVE, /
6466	/* 2N+I IF T(I,1)T(I-1,3) IS ZERO WITH */
6467	/* ONE FACTOR NON-ZERO. */
6468
6469	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
6470	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
6471	*/
6472
6473	/* THIS VERSION DATED AUGUST 1983. */
6474
6475	/* ------------------------------------------------------------------
6476	*/
6477
6478	/* Parameter adjustments */
6479	t_dim1 = *nm;
6480	t_offset = t_dim1 + 1;
6481	t -= t_offset;
6482	z_dim1 = *nm;
6483	z_offset = z_dim1 + 1;
6484	z -= z_offset;
6485	--e;
6486	--d;
6487
6488	/* Function Body */
6489	*ierr = 0;
6490
6491	i_1 = *n;
6492	for (i = 1; i <= i_1; ++i) {
6493
6494	i_2 = *n;
6495	for (j = 1; j <= i_2; ++j) {
6496	/* L50: */
6497	z[i + j * z_dim1] = 0.;
6498	}
6499
6500	if (i == 1) {
6501	goto L70;
6502	}
6503	h = t[i + t_dim1] * t[i - 1 + t_dim1 * 3];
6504	if (h < 0.) {
6505	goto L900;
6506	} else if (h == 0) {
6507	goto L60;
6508	} else {
6509	goto L80;
6510	}
6511	L60:
6512	if (t[i + t_dim1] != 0. \|\| t[i - 1 + t_dim1 * 3] != 0.) {
6513	goto L1000;
6514	}
6515	e[i] = 0.;
6516	L70:
6517	z[i + i * z_dim1] = 1.;
6518	goto L90;
6519	L80:
6520	e[i] = sqrt(h);
6521	z[i + i * z_dim1] = z[i - 1 + (i - 1) * z_dim1] * e[i] / t[i - 1 +
6522	t_dim1 * 3];
6523	L90:
6524	d[i] = t[i + (t_dim1 << 1)];
6525	/* L100: */
6526	}
6527
6528	goto L1001;
6529	/* .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL */
6530	/* ELEMENTS IS NEGATIVE .......... */
6531	L900:
6532	ierr = n + i;
6533	goto L1001;
6534	/* .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL */
6535	/* ELEMENTS IS ZERO WITH ONE MEMBER NON-ZERO .......... */
6536	L1000:
6537	ierr = (n << 1) + i;
6538	L1001:
6539	return 0;
6540	} /* figi2_ */
6541
6542	/* Subroutine / int hqr_(integer nm, integer n, integer low, integer *igh,
6543	doublereal h, doublereal wr, doublereal wi, integer ierr)
6544	{
6545	/* System generated locals */
6546	integer h_dim1, h_offset, i_1, i_2, i_3;
6547	doublereal d_1, d_2;
6548
6549	/* Builtin functions */
6550	double sqrt(doublereal), d_sign(doublereal , doublereal );
6551
6552	/* Local variables */
6553	static doublereal norm;
6554	static integer i, j, k, l, m;
6555	static doublereal p, q, r, s, t, w, x, y;
6556	static integer na, en, ll, mm;
6557	static doublereal zz;
6558	static logical notlas;
6559	static integer mp2, itn, its, enm2;
6560	static doublereal tst1, tst2;
6561
6562
6563
6564	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR, */
6565	/* NUM. MATH. 14, 219-231(1970) BY MARTIN, PETERS, AND WILKINSON. */
6566	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 359-371(1971). */
6567
6568	/* THIS SUBROUTINE FINDS THE EIGENVALUES OF A REAL */
6569	/* UPPER HESSENBERG MATRIX BY THE QR METHOD. */
6570
6571	/* ON INPUT */
6572
6573	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
6574	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
6575	/* DIMENSION STATEMENT. */
6576
6577	/* N IS THE ORDER OF THE MATRIX. */
6578
6579	/* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
6580	/* SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, */
6581	/* SET LOW=1, IGH=N. */
6582
6583	/* H CONTAINS THE UPPER HESSENBERG MATRIX. INFORMATION ABOUT */
6584	/* THE TRANSFORMATIONS USED IN THE REDUCTION TO HESSENBERG */
6585	/* FORM BY ELMHES OR ORTHES, IF PERFORMED, IS STORED */
6586	/* IN THE REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX. */
6587
6588	/* ON OUTPUT */
6589
6590	/* H HAS BEEN DESTROYED. THEREFORE, IT MUST BE SAVED */
6591	/* BEFORE CALLING HQR IF SUBSEQUENT CALCULATION AND */
6592	/* BACK TRANSFORMATION OF EIGENVECTORS IS TO BE PERFORMED. */
6593
6594	/* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, */
6595	/* RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES */
6596	/* ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS */
6597	/* OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE */
6598	/* HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN */
6599	/* ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT */
6600	/* FOR INDICES IERR+1,...,N. */
6601
6602	/* IERR IS SET TO */
6603	/* ZERO FOR NORMAL RETURN, */
6604	/* J IF THE LIMIT OF 30N ITERATIONS IS EXHAUSTED /
6605	/* WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. */
6606
6607	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
6608	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
6609	*/
6610
6611	/* THIS VERSION DATED AUGUST 1983. */
6612
6613	/* ------------------------------------------------------------------
6614	*/
6615
6616	/* Parameter adjustments */
6617	--wi;
6618	--wr;
6619	h_dim1 = *nm;
6620	h_offset = h_dim1 + 1;
6621	h -= h_offset;
6622
6623	/* Function Body */
6624	*ierr = 0;
6625	norm = 0.;
6626	k = 1;
6627	/* .......... STORE ROOTS ISOLATED BY BALANC */
6628	/* AND COMPUTE MATRIX NORM .......... */
6629	i_1 = *n;
6630	for (i = 1; i <= i_1; ++i) {
6631
6632	i_2 = *n;
6633	for (j = k; j <= i_2; ++j) {
6634	/* L40: */
6635	norm += (d_1 = h[i + j * h_dim1], abs(d_1));
6636	}
6637
6638	k = i;
6639	if (i >= low && i <= igh) {
6640	goto L50;
6641	}
6642	wr[i] = h[i + i * h_dim1];
6643	wi[i] = 0.;
6644	L50:
6645	;
6646	}
6647
6648	en = *igh;
6649	t = 0.;
6650	itn = n 30;
6651	/* .......... SEARCH FOR NEXT EIGENVALUES .......... */
6652	L60:
6653	if (en < *low) {
6654	goto L1001;
6655	}
6656	its = 0;
6657	na = en - 1;
6658	enm2 = na - 1;
6659	/* .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT */
6660	/* FOR L=EN STEP -1 UNTIL LOW DO -- .......... */
6661	L70:
6662	i_1 = en;
6663	for (ll = *low; ll <= i_1; ++ll) {
6664	l = en + *low - ll;
6665	if (l == *low) {
6666	goto L100;
6667	}
6668	s = (d_1 = h[l - 1 + (l - 1) * h_dim1], abs(d_1)) + (d_2 = h[l + l
6669	* h_dim1], abs(d_2));
6670	if (s == 0.) {
6671	s = norm;
6672	}
6673	tst1 = s;
6674	tst2 = tst1 + (d_1 = h[l + (l - 1) * h_dim1], abs(d_1));
6675	if (tst2 == tst1) {
6676	goto L100;
6677	}
6678	/* L80: */
6679	}
6680	/* .......... FORM SHIFT .......... */
6681	L100:
6682	x = h[en + en * h_dim1];
6683	if (l == en) {
6684	goto L270;
6685	}
6686	y = h[na + na * h_dim1];
6687	w = h[en + na * h_dim1] * h[na + en * h_dim1];
6688	if (l == na) {
6689	goto L280;
6690	}
6691	if (itn == 0) {
6692	goto L1000;
6693	}
6694	if (its != 10 && its != 20) {
6695	goto L130;
6696	}
6697	/* .......... FORM EXCEPTIONAL SHIFT .......... */
6698	t += x;
6699
6700	i_1 = en;
6701	for (i = *low; i <= i_1; ++i) {
6702	/* L120: */
6703	h[i + i * h_dim1] -= x;
6704	}
6705
6706	s = (d_1 = h[en + na * h_dim1], abs(d_1)) + (d_2 = h[na + enm2 *
6707	h_dim1], abs(d_2));
6708	x = s * .75;
6709	y = x;
6710	w = s * -.4375 * s;
6711	L130:
6712	++its;
6713	--itn;
6714	/* .......... LOOK FOR TWO CONSECUTIVE SMALL */
6715	/* SUB-DIAGONAL ELEMENTS. */
6716	/* FOR M=EN-2 STEP -1 UNTIL L DO -- .......... */
6717	i_1 = enm2;
6718	for (mm = l; mm <= i_1; ++mm) {
6719	m = enm2 + l - mm;
6720	zz = h[m + m * h_dim1];
6721	r = x - zz;
6722	s = y - zz;
6723	p = (r * s - w) / h[m + 1 + m * h_dim1] + h[m + (m + 1) * h_dim1];
6724	q = h[m + 1 + (m + 1) * h_dim1] - zz - r - s;
6725	r = h[m + 2 + (m + 1) * h_dim1];
6726	s = abs(p) + abs(q) + abs(r);
6727	p /= s;
6728	q /= s;
6729	r /= s;
6730	if (m == l) {
6731	goto L150;
6732	}
6733	tst1 = abs(p) * ((d_1 = h[m - 1 + (m - 1) * h_dim1], abs(d_1)) +
6734	abs(zz) + (d_2 = h[m + 1 + (m + 1) * h_dim1], abs(d_2)));
6735	tst2 = tst1 + (d_1 = h[m + (m - 1) * h_dim1], abs(d_1)) * (abs(q) +
6736	abs(r));
6737	if (tst2 == tst1) {
6738	goto L150;
6739	}
6740	/* L140: */
6741	}
6742
6743	L150:
6744	mp2 = m + 2;
6745
6746	i_1 = en;
6747	for (i = mp2; i <= i_1; ++i) {
6748	h[i + (i - 2) * h_dim1] = 0.;
6749	if (i == mp2) {
6750	goto L160;
6751	}
6752	h[i + (i - 3) * h_dim1] = 0.;
6753	L160:
6754	;
6755	}
6756	/* .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND */
6757	/* COLUMNS M TO EN .......... */
6758	i_1 = na;
6759	for (k = m; k <= i_1; ++k) {
6760	notlas = k != na;
6761	if (k == m) {
6762	goto L170;
6763	}
6764	p = h[k + (k - 1) * h_dim1];
6765	q = h[k + 1 + (k - 1) * h_dim1];
6766	r = 0.;
6767	if (notlas) {
6768	r = h[k + 2 + (k - 1) * h_dim1];
6769	}
6770	x = abs(p) + abs(q) + abs(r);
6771	if (x == 0.) {
6772	goto L260;
6773	}
6774	p /= x;
6775	q /= x;
6776	r /= x;
6777	L170:
6778	d_1 = sqrt(p * p + q * q + r * r);
6779	s = d_sign(&d_1, &p);
6780	if (k == m) {
6781	goto L180;
6782	}
6783	h[k + (k - 1) * h_dim1] = -s * x;
6784	goto L190;
6785	L180:
6786	if (l != m) {
6787	h[k + (k - 1) * h_dim1] = -h[k + (k - 1) * h_dim1];
6788	}
6789	L190:
6790	p += s;
6791	x = p / s;
6792	y = q / s;
6793	zz = r / s;
6794	q /= p;
6795	r /= p;
6796	if (notlas) {
6797	goto L225;
6798	}
6799	/* .......... ROW MODIFICATION .......... */
6800	i_2 = *n;
6801	for (j = k; j <= i_2; ++j) {
6802	p = h[k + j * h_dim1] + q * h[k + 1 + j * h_dim1];
6803	h[k + j * h_dim1] -= p * x;
6804	h[k + 1 + j * h_dim1] -= p * y;
6805	/* L200: */
6806	}
6807
6808	/* Computing MIN */
6809	i_2 = en, i_3 = k + 3;
6810	j = min(i_2,i_3);
6811	/* .......... COLUMN MODIFICATION .......... */
6812	i_2 = j;
6813	for (i = 1; i <= i_2; ++i) {
6814	p = x * h[i + k * h_dim1] + y * h[i + (k + 1) * h_dim1];
6815	h[i + k * h_dim1] -= p;
6816	h[i + (k + 1) * h_dim1] -= p * q;
6817	/* L210: */
6818	}
6819	goto L255;
6820	L225:
6821	/* .......... ROW MODIFICATION .......... */
6822	i_2 = *n;
6823	for (j = k; j <= i_2; ++j) {
6824	p = h[k + j * h_dim1] + q * h[k + 1 + j * h_dim1] + r * h[k + 2 +
6825	j * h_dim1];
6826	h[k + j * h_dim1] -= p * x;
6827	h[k + 1 + j * h_dim1] -= p * y;
6828	h[k + 2 + j * h_dim1] -= p * zz;
6829	/* L230: */
6830	}
6831
6832	/* Computing MIN */
6833	i_2 = en, i_3 = k + 3;
6834	j = min(i_2,i_3);
6835	/* .......... COLUMN MODIFICATION .......... */
6836	i_2 = j;
6837	for (i = 1; i <= i_2; ++i) {
6838	p = x * h[i + k * h_dim1] + y * h[i + (k + 1) * h_dim1] + zz * h[
6839	i + (k + 2) * h_dim1];
6840	h[i + k * h_dim1] -= p;
6841	h[i + (k + 1) * h_dim1] -= p * q;
6842	h[i + (k + 2) * h_dim1] -= p * r;
6843	/* L240: */
6844	}
6845	L255:
6846
6847	L260:
6848	;
6849	}
6850
6851	goto L70;
6852	/* .......... ONE ROOT FOUND .......... */
6853	L270:
6854	wr[en] = x + t;
6855	wi[en] = 0.;
6856	en = na;
6857	goto L60;
6858	/* .......... TWO ROOTS FOUND .......... */
6859	L280:
6860	p = (y - x) / 2.;
6861	q = p * p + w;
6862	zz = sqrt((abs(q)));
6863	x += t;
6864	if (q < 0.) {
6865	goto L320;
6866	}
6867	/* .......... REAL PAIR .......... */
6868	zz = p + d_sign(&zz, &p);
6869	wr[na] = x + zz;
6870	wr[en] = wr[na];
6871	if (zz != 0.) {
6872	wr[en] = x - w / zz;
6873	}
6874	wi[na] = 0.;
6875	wi[en] = 0.;
6876	goto L330;
6877	/* .......... COMPLEX PAIR .......... */
6878	L320:
6879	wr[na] = x + p;
6880	wr[en] = x + p;
6881	wi[na] = zz;
6882	wi[en] = -zz;
6883	L330:
6884	en = enm2;
6885	goto L60;
6886	/* .......... SET ERROR -- ALL EIGENVALUES HAVE NOT */
6887	/* CONVERGED AFTER 30N ITERATIONS .......... /
6888	L1000:
6889	*ierr = en;
6890	L1001:
6891	return 0;
6892	} /* hqr_ */
6893
6894	/* Subroutine / int hqr2_(integer nm, integer n, integer low, integer *
6895	igh, doublereal h, doublereal wr, doublereal wi, doublereal z,
6896	integer *ierr)
6897	{
6898	/* System generated locals */
6899	integer h_dim1, h_offset, z_dim1, z_offset, i_1, i_2, i_3;
6900	doublereal d_1, d_2, d_3, d_4;
6901
6902	/* Builtin functions */
6903	double sqrt(doublereal), d_sign(doublereal , doublereal );
6904
6905	/* Local variables */
6906	extern /* Subroutine / int cdiv_(doublereal , doublereal , doublereal
6907	, doublereal , doublereal , doublereal *);
6908	static doublereal norm;
6909	static integer i, j, k, l, m;
6910	static doublereal p, q, r, s, t, w, x, y;
6911	static integer na, ii, en, jj;
6912	static doublereal ra, sa;
6913	static integer ll, mm, nn;
6914	static doublereal vi, vr, zz;
6915	static logical notlas;
6916	static integer mp2, itn, its, enm2;
6917	static doublereal tst1, tst2;
6918
6919
6920
6921	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR2, */
6922	/* NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. */
6923	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). */
6924
6925	/* THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS */
6926	/* OF A REAL UPPER HESSENBERG MATRIX BY THE QR METHOD. THE */
6927	/* EIGENVECTORS OF A REAL GENERAL MATRIX CAN ALSO BE FOUND */
6928	/* IF ELMHES AND ELTRAN OR ORTHES AND ORTRAN HAVE */
6929	/* BEEN USED TO REDUCE THIS GENERAL MATRIX TO HESSENBERG FORM */
6930	/* AND TO ACCUMULATE THE SIMILARITY TRANSFORMATIONS. */
6931
6932	/* ON INPUT */
6933
6934	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
6935	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
6936	/* DIMENSION STATEMENT. */
6937
6938	/* N IS THE ORDER OF THE MATRIX. */
6939
6940	/* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
6941	/* SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, */
6942	/* SET LOW=1, IGH=N. */
6943
6944	/* H CONTAINS THE UPPER HESSENBERG MATRIX. */
6945
6946	/* Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED BY ELTRAN */
6947	/* AFTER THE REDUCTION BY ELMHES, OR BY ORTRAN AFTER THE */
6948	/* REDUCTION BY ORTHES, IF PERFORMED. IF THE EIGENVECTORS */
6949	/* OF THE HESSENBERG MATRIX ARE DESIRED, Z MUST CONTAIN THE */
6950	/* IDENTITY MATRIX. */
6951
6952	/* ON OUTPUT */
6953
6954	/* H HAS BEEN DESTROYED. */
6955
6956	/* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, */
6957	/* RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES */
6958	/* ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS */
6959	/* OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE */
6960	/* HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN */
6961	/* ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT */
6962	/* FOR INDICES IERR+1,...,N. */
6963
6964	/* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS. */
6965	/* IF THE I-TH EIGENVALUE IS REAL, THE I-TH COLUMN OF Z */
6966	/* CONTAINS ITS EIGENVECTOR. IF THE I-TH EIGENVALUE IS COMPLEX
6967	*/
6968	/* WITH POSITIVE IMAGINARY PART, THE I-TH AND (I+1)-TH */
6969	/* COLUMNS OF Z CONTAIN THE REAL AND IMAGINARY PARTS OF ITS */
6970	/* EIGENVECTOR. THE EIGENVECTORS ARE UNNORMALIZED. IF AN */
6971	/* ERROR EXIT IS MADE, NONE OF THE EIGENVECTORS HAS BEEN FOUND.
6972	*/
6973
6974	/* IERR IS SET TO */
6975	/* ZERO FOR NORMAL RETURN, */
6976	/* J IF THE LIMIT OF 30N ITERATIONS IS EXHAUSTED /
6977	/* WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. */
6978
6979	/* CALLS CDIV FOR COMPLEX DIVISION. */
6980
6981	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
6982	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
6983	*/
6984
6985	/* THIS VERSION DATED AUGUST 1983. */
6986
6987	/* ------------------------------------------------------------------
6988	*/
6989
6990	/* Parameter adjustments */
6991	z_dim1 = *nm;
6992	z_offset = z_dim1 + 1;
6993	z -= z_offset;
6994	--wi;
6995	--wr;
6996	h_dim1 = *nm;
6997	h_offset = h_dim1 + 1;
6998	h -= h_offset;
6999
7000	/* Function Body */
7001	*ierr = 0;
7002	norm = 0.;
7003	k = 1;
7004	/* .......... STORE ROOTS ISOLATED BY BALANC */
7005	/* AND COMPUTE MATRIX NORM .......... */
7006	i_1 = *n;
7007	for (i = 1; i <= i_1; ++i) {
7008
7009	i_2 = *n;
7010	for (j = k; j <= i_2; ++j) {
7011	/* L40: */
7012	norm += (d_1 = h[i + j * h_dim1], abs(d_1));
7013	}
7014
7015	k = i;
7016	if (i >= low && i <= igh) {
7017	goto L50;
7018	}
7019	wr[i] = h[i + i * h_dim1];
7020	wi[i] = 0.;
7021	L50:
7022	;
7023	}
7024
7025	en = *igh;
7026	t = 0.;
7027	itn = n 30;
7028	/* .......... SEARCH FOR NEXT EIGENVALUES .......... */
7029	L60:
7030	if (en < *low) {
7031	goto L340;
7032	}
7033	its = 0;
7034	na = en - 1;
7035	enm2 = na - 1;
7036	/* .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT */
7037	/* FOR L=EN STEP -1 UNTIL LOW DO -- .......... */
7038	L70:
7039	i_1 = en;
7040	for (ll = *low; ll <= i_1; ++ll) {
7041	l = en + *low - ll;
7042	if (l == *low) {
7043	goto L100;
7044	}
7045	s = (d_1 = h[l - 1 + (l - 1) * h_dim1], abs(d_1)) + (d_2 = h[l + l
7046	* h_dim1], abs(d_2));
7047	if (s == 0.) {
7048	s = norm;
7049	}
7050	tst1 = s;
7051	tst2 = tst1 + (d_1 = h[l + (l - 1) * h_dim1], abs(d_1));
7052	if (tst2 == tst1) {
7053	goto L100;
7054	}
7055	/* L80: */
7056	}
7057	/* .......... FORM SHIFT .......... */
7058	L100:
7059	x = h[en + en * h_dim1];
7060	if (l == en) {
7061	goto L270;
7062	}
7063	y = h[na + na * h_dim1];
7064	w = h[en + na * h_dim1] * h[na + en * h_dim1];
7065	if (l == na) {
7066	goto L280;
7067	}
7068	if (itn == 0) {
7069	goto L1000;
7070	}
7071	if (its != 10 && its != 20) {
7072	goto L130;
7073	}
7074	/* .......... FORM EXCEPTIONAL SHIFT .......... */
7075	t += x;
7076
7077	i_1 = en;
7078	for (i = *low; i <= i_1; ++i) {
7079	/* L120: */
7080	h[i + i * h_dim1] -= x;
7081	}
7082
7083	s = (d_1 = h[en + na * h_dim1], abs(d_1)) + (d_2 = h[na + enm2 *
7084	h_dim1], abs(d_2));
7085	x = s * .75;
7086	y = x;
7087	w = s * -.4375 * s;
7088	L130:
7089	++its;
7090	--itn;
7091	/* .......... LOOK FOR TWO CONSECUTIVE SMALL */
7092	/* SUB-DIAGONAL ELEMENTS. */
7093	/* FOR M=EN-2 STEP -1 UNTIL L DO -- .......... */
7094	i_1 = enm2;
7095	for (mm = l; mm <= i_1; ++mm) {
7096	m = enm2 + l - mm;
7097	zz = h[m + m * h_dim1];
7098	r = x - zz;
7099	s = y - zz;
7100	p = (r * s - w) / h[m + 1 + m * h_dim1] + h[m + (m + 1) * h_dim1];
7101	q = h[m + 1 + (m + 1) * h_dim1] - zz - r - s;
7102	r = h[m + 2 + (m + 1) * h_dim1];
7103	s = abs(p) + abs(q) + abs(r);
7104	p /= s;
7105	q /= s;
7106	r /= s;
7107	if (m == l) {
7108	goto L150;
7109	}
7110	tst1 = abs(p) * ((d_1 = h[m - 1 + (m - 1) * h_dim1], abs(d_1)) +
7111	abs(zz) + (d_2 = h[m + 1 + (m + 1) * h_dim1], abs(d_2)));
7112	tst2 = tst1 + (d_1 = h[m + (m - 1) * h_dim1], abs(d_1)) * (abs(q) +
7113	abs(r));
7114	if (tst2 == tst1) {
7115	goto L150;
7116	}
7117	/* L140: */
7118	}
7119
7120	L150:
7121	mp2 = m + 2;
7122
7123	i_1 = en;
7124	for (i = mp2; i <= i_1; ++i) {
7125	h[i + (i - 2) * h_dim1] = 0.;
7126	if (i == mp2) {
7127	goto L160;
7128	}
7129	h[i + (i - 3) * h_dim1] = 0.;
7130	L160:
7131	;
7132	}
7133	/* .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND */
7134	/* COLUMNS M TO EN .......... */
7135	i_1 = na;
7136	for (k = m; k <= i_1; ++k) {
7137	notlas = k != na;
7138	if (k == m) {
7139	goto L170;
7140	}
7141	p = h[k + (k - 1) * h_dim1];
7142	q = h[k + 1 + (k - 1) * h_dim1];
7143	r = 0.;
7144	if (notlas) {
7145	r = h[k + 2 + (k - 1) * h_dim1];
7146	}
7147	x = abs(p) + abs(q) + abs(r);
7148	if (x == 0.) {
7149	goto L260;
7150	}
7151	p /= x;
7152	q /= x;
7153	r /= x;
7154	L170:
7155	d_1 = sqrt(p * p + q * q + r * r);
7156	s = d_sign(&d_1, &p);
7157	if (k == m) {
7158	goto L180;
7159	}
7160	h[k + (k - 1) * h_dim1] = -s * x;
7161	goto L190;
7162	L180:
7163	if (l != m) {
7164	h[k + (k - 1) * h_dim1] = -h[k + (k - 1) * h_dim1];
7165	}
7166	L190:
7167	p += s;
7168	x = p / s;
7169	y = q / s;
7170	zz = r / s;
7171	q /= p;
7172	r /= p;
7173	if (notlas) {
7174	goto L225;
7175	}
7176	/* .......... ROW MODIFICATION .......... */
7177	i_2 = *n;
7178	for (j = k; j <= i_2; ++j) {
7179	p = h[k + j * h_dim1] + q * h[k + 1 + j * h_dim1];
7180	h[k + j * h_dim1] -= p * x;
7181	h[k + 1 + j * h_dim1] -= p * y;
7182	/* L200: */
7183	}
7184
7185	/* Computing MIN */
7186	i_2 = en, i_3 = k + 3;
7187	j = min(i_2,i_3);
7188	/* .......... COLUMN MODIFICATION .......... */
7189	i_2 = j;
7190	for (i = 1; i <= i_2; ++i) {
7191	p = x * h[i + k * h_dim1] + y * h[i + (k + 1) * h_dim1];
7192	h[i + k * h_dim1] -= p;
7193	h[i + (k + 1) * h_dim1] -= p * q;
7194	/* L210: */
7195	}
7196	/* .......... ACCUMULATE TRANSFORMATIONS .......... */
7197	i_2 = *igh;
7198	for (i = *low; i <= i_2; ++i) {
7199	p = x * z[i + k * z_dim1] + y * z[i + (k + 1) * z_dim1];
7200	z[i + k * z_dim1] -= p;
7201	z[i + (k + 1) * z_dim1] -= p * q;
7202	/* L220: */
7203	}
7204	goto L255;
7205	L225:
7206	/* .......... ROW MODIFICATION .......... */
7207	i_2 = *n;
7208	for (j = k; j <= i_2; ++j) {
7209	p = h[k + j * h_dim1] + q * h[k + 1 + j * h_dim1] + r * h[k + 2 +
7210	j * h_dim1];
7211	h[k + j * h_dim1] -= p * x;
7212	h[k + 1 + j * h_dim1] -= p * y;
7213	h[k + 2 + j * h_dim1] -= p * zz;
7214	/* L230: */
7215	}
7216
7217	/* Computing MIN */
7218	i_2 = en, i_3 = k + 3;
7219	j = min(i_2,i_3);
7220	/* .......... COLUMN MODIFICATION .......... */
7221	i_2 = j;
7222	for (i = 1; i <= i_2; ++i) {
7223	p = x * h[i + k * h_dim1] + y * h[i + (k + 1) * h_dim1] + zz * h[
7224	i + (k + 2) * h_dim1];
7225	h[i + k * h_dim1] -= p;
7226	h[i + (k + 1) * h_dim1] -= p * q;
7227	h[i + (k + 2) * h_dim1] -= p * r;
7228	/* L240: */
7229	}
7230	/* .......... ACCUMULATE TRANSFORMATIONS .......... */
7231	i_2 = *igh;
7232	for (i = *low; i <= i_2; ++i) {
7233	p = x * z[i + k * z_dim1] + y * z[i + (k + 1) * z_dim1] + zz * z[
7234	i + (k + 2) * z_dim1];
7235	z[i + k * z_dim1] -= p;
7236	z[i + (k + 1) * z_dim1] -= p * q;
7237	z[i + (k + 2) * z_dim1] -= p * r;
7238	/* L250: */
7239	}
7240	L255:
7241
7242	L260:
7243	;
7244	}
7245
7246	goto L70;
7247	/* .......... ONE ROOT FOUND .......... */
7248	L270:
7249	h[en + en * h_dim1] = x + t;
7250	wr[en] = h[en + en * h_dim1];
7251	wi[en] = 0.;
7252	en = na;
7253	goto L60;
7254	/* .......... TWO ROOTS FOUND .......... */
7255	L280:
7256	p = (y - x) / 2.;
7257	q = p * p + w;
7258	zz = sqrt((abs(q)));
7259	h[en + en * h_dim1] = x + t;
7260	x = h[en + en * h_dim1];
7261	h[na + na * h_dim1] = y + t;
7262	if (q < 0.) {
7263	goto L320;
7264	}
7265	/* .......... REAL PAIR .......... */
7266	zz = p + d_sign(&zz, &p);
7267	wr[na] = x + zz;
7268	wr[en] = wr[na];
7269	if (zz != 0.) {
7270	wr[en] = x - w / zz;
7271	}
7272	wi[na] = 0.;
7273	wi[en] = 0.;
7274	x = h[en + na * h_dim1];
7275	s = abs(x) + abs(zz);
7276	p = x / s;
7277	q = zz / s;
7278	r = sqrt(p * p + q * q);
7279	p /= r;
7280	q /= r;
7281	/* .......... ROW MODIFICATION .......... */
7282	i_1 = *n;
7283	for (j = na; j <= i_1; ++j) {
7284	zz = h[na + j * h_dim1];
7285	h[na + j * h_dim1] = q * zz + p * h[en + j * h_dim1];
7286	h[en + j * h_dim1] = q * h[en + j * h_dim1] - p * zz;
7287	/* L290: */
7288	}
7289	/* .......... COLUMN MODIFICATION .......... */
7290	i_1 = en;
7291	for (i = 1; i <= i_1; ++i) {
7292	zz = h[i + na * h_dim1];
7293	h[i + na * h_dim1] = q * zz + p * h[i + en * h_dim1];
7294	h[i + en * h_dim1] = q * h[i + en * h_dim1] - p * zz;
7295	/* L300: */
7296	}
7297	/* .......... ACCUMULATE TRANSFORMATIONS .......... */
7298	i_1 = *igh;
7299	for (i = *low; i <= i_1; ++i) {
7300	zz = z[i + na * z_dim1];
7301	z[i + na * z_dim1] = q * zz + p * z[i + en * z_dim1];
7302	z[i + en * z_dim1] = q * z[i + en * z_dim1] - p * zz;
7303	/* L310: */
7304	}
7305
7306	goto L330;
7307	/* .......... COMPLEX PAIR .......... */
7308	L320:
7309	wr[na] = x + p;
7310	wr[en] = x + p;
7311	wi[na] = zz;
7312	wi[en] = -zz;
7313	L330:
7314	en = enm2;
7315	goto L60;
7316	/* .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND */
7317	/* VECTORS OF UPPER TRIANGULAR FORM .......... */
7318	L340:
7319	if (norm == 0.) {
7320	goto L1001;
7321	}
7322	/* .......... FOR EN=N STEP -1 UNTIL 1 DO -- .......... */
7323	i_1 = *n;
7324	for (nn = 1; nn <= i_1; ++nn) {
7325	en = *n + 1 - nn;
7326	p = wr[en];
7327	q = wi[en];
7328	na = en - 1;
7329	if (q < 0.) {
7330	goto L710;
7331	} else if (q == 0) {
7332	goto L600;
7333	} else {
7334	goto L800;
7335	}
7336	/* .......... REAL VECTOR .......... */
7337	L600:
7338	m = en;
7339	h[en + en * h_dim1] = 1.;
7340	if (na == 0) {
7341	goto L800;
7342	}
7343	/* .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... */
7344	i_2 = na;
7345	for (ii = 1; ii <= i_2; ++ii) {
7346	i = en - ii;
7347	w = h[i + i * h_dim1] - p;
7348	r = 0.;
7349
7350	i_3 = en;
7351	for (j = m; j <= i_3; ++j) {
7352	/* L610: */
7353	r += h[i + j * h_dim1] * h[j + en * h_dim1];
7354	}
7355
7356	if (wi[i] >= 0.) {
7357	goto L630;
7358	}
7359	zz = w;
7360	s = r;
7361	goto L700;
7362	L630:
7363	m = i;
7364	if (wi[i] != 0.) {
7365	goto L640;
7366	}
7367	t = w;
7368	if (t != 0.) {
7369	goto L635;
7370	}
7371	tst1 = norm;
7372	t = tst1;
7373	L632:
7374	t *= .01;
7375	tst2 = norm + t;
7376	if (tst2 > tst1) {
7377	goto L632;
7378	}
7379	L635:
7380	h[i + en * h_dim1] = -r / t;
7381	goto L680;
7382	/* .......... SOLVE REAL EQUATIONS .......... */
7383	L640:
7384	x = h[i + (i + 1) * h_dim1];
7385	y = h[i + 1 + i * h_dim1];
7386	q = (wr[i] - p) * (wr[i] - p) + wi[i] * wi[i];
7387	t = (x * s - zz * r) / q;
7388	h[i + en * h_dim1] = t;
7389	if (abs(x) <= abs(zz)) {
7390	goto L650;
7391	}
7392	h[i + 1 + en * h_dim1] = (-r - w * t) / x;
7393	goto L680;
7394	L650:
7395	h[i + 1 + en * h_dim1] = (-s - y * t) / zz;
7396
7397	/* .......... OVERFLOW CONTROL .......... */
7398	L680:
7399	t = (d_1 = h[i + en * h_dim1], abs(d_1));
7400	if (t == 0.) {
7401	goto L700;
7402	}
7403	tst1 = t;
7404	tst2 = tst1 + 1. / tst1;
7405	if (tst2 > tst1) {
7406	goto L700;
7407	}
7408	i_3 = en;
7409	for (j = i; j <= i_3; ++j) {
7410	h[j + en * h_dim1] /= t;
7411	/* L690: */
7412	}
7413
7414	L700:
7415	;
7416	}
7417	/* .......... END REAL VECTOR .......... */
7418	goto L800;
7419	/* .......... COMPLEX VECTOR .......... */
7420	L710:
7421	m = na;
7422	/* .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT */
7423	/* EIGENVECTOR MATRIX IS TRIANGULAR .......... */
7424	if ((d_1 = h[en + na * h_dim1], abs(d_1)) <= (d_2 = h[na + en *
7425	h_dim1], abs(d_2))) {
7426	goto L720;
7427	}
7428	h[na + na * h_dim1] = q / h[en + na * h_dim1];
7429	h[na + en * h_dim1] = -(h[en + en * h_dim1] - p) / h[en + na * h_dim1]
7430	;
7431	goto L730;
7432	L720:
7433	d_1 = -h[na + en * h_dim1];
7434	d_2 = h[na + na * h_dim1] - p;
7435	cdiv_(&c_b550, &d_1, &d_2, &q, &h[na + na * h_dim1], &h[na + en *
7436	h_dim1]);
7437	L730:
7438	h[en + na * h_dim1] = 0.;
7439	h[en + en * h_dim1] = 1.;
7440	enm2 = na - 1;
7441	if (enm2 == 0) {
7442	goto L800;
7443	}
7444	/* .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- .......... */
7445	i_2 = enm2;
7446	for (ii = 1; ii <= i_2; ++ii) {
7447	i = na - ii;
7448	w = h[i + i * h_dim1] - p;
7449	ra = 0.;
7450	sa = 0.;
7451
7452	i_3 = en;
7453	for (j = m; j <= i_3; ++j) {
7454	ra += h[i + j * h_dim1] * h[j + na * h_dim1];
7455	sa += h[i + j * h_dim1] * h[j + en * h_dim1];
7456	/* L760: */
7457	}
7458
7459	if (wi[i] >= 0.) {
7460	goto L770;
7461	}
7462	zz = w;
7463	r = ra;
7464	s = sa;
7465	goto L795;
7466	L770:
7467	m = i;
7468	if (wi[i] != 0.) {
7469	goto L780;
7470	}
7471	d_1 = -ra;
7472	d_2 = -sa;
7473	cdiv_(&d_1, &d_2, &w, &q, &h[i + na * h_dim1], &h[i + en *
7474	h_dim1]);
7475	goto L790;
7476	/* .......... SOLVE COMPLEX EQUATIONS .......... */
7477	L780:
7478	x = h[i + (i + 1) * h_dim1];
7479	y = h[i + 1 + i * h_dim1];
7480	vr = (wr[i] - p) * (wr[i] - p) + wi[i] * wi[i] - q * q;
7481	vi = (wr[i] - p) * 2. * q;
7482	if (vr != 0. \|\| vi != 0.) {
7483	goto L784;
7484	}
7485	tst1 = norm * (abs(w) + abs(q) + abs(x) + abs(y) + abs(zz));
7486	vr = tst1;
7487	L783:
7488	vr *= .01;
7489	tst2 = tst1 + vr;
7490	if (tst2 > tst1) {
7491	goto L783;
7492	}
7493	L784:
7494	d_1 = x * r - zz * ra + q * sa;
7495	d_2 = x * s - zz * sa - q * ra;
7496	cdiv_(&d_1, &d_2, &vr, &vi, &h[i + na * h_dim1], &h[i + en *
7497	h_dim1]);
7498	if (abs(x) <= abs(zz) + abs(q)) {
7499	goto L785;
7500	}
7501	h[i + 1 + na * h_dim1] = (-ra - w * h[i + na * h_dim1] + q * h[i
7502	+ en * h_dim1]) / x;
7503	h[i + 1 + en * h_dim1] = (-sa - w * h[i + en * h_dim1] - q * h[i
7504	+ na * h_dim1]) / x;
7505	goto L790;
7506	L785:
7507	d_1 = -r - y * h[i + na * h_dim1];
7508	d_2 = -s - y * h[i + en * h_dim1];
7509	cdiv_(&d_1, &d_2, &zz, &q, &h[i + 1 + na * h_dim1], &h[i + 1 +
7510	en * h_dim1]);
7511
7512	/* .......... OVERFLOW CONTROL .......... */
7513	L790:
7514	/* Computing MAX */
7515	d_3 = (d_1 = h[i + na * h_dim1], abs(d_1)), d_4 = (d_2 = h[i
7516	+ en * h_dim1], abs(d_2));
7517	t = max(d_3,d_4);
7518	if (t == 0.) {
7519	goto L795;
7520	}
7521	tst1 = t;
7522	tst2 = tst1 + 1. / tst1;
7523	if (tst2 > tst1) {
7524	goto L795;
7525	}
7526	i_3 = en;
7527	for (j = i; j <= i_3; ++j) {
7528	h[j + na * h_dim1] /= t;
7529	h[j + en * h_dim1] /= t;
7530	/* L792: */
7531	}
7532
7533	L795:
7534	;
7535	}
7536	/* .......... END COMPLEX VECTOR .......... */
7537	L800:
7538	;
7539	}
7540	/* .......... END BACK SUBSTITUTION. */
7541	/* VECTORS OF ISOLATED ROOTS .......... */
7542	i_1 = *n;
7543	for (i = 1; i <= i_1; ++i) {
7544	if (i >= low && i <= igh) {
7545	goto L840;
7546	}
7547
7548	i_2 = *n;
7549	for (j = i; j <= i_2; ++j) {
7550	/* L820: */
7551	z[i + j * z_dim1] = h[i + j * h_dim1];
7552	}
7553
7554	L840:
7555	;
7556	}
7557	/* .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE */
7558	/* VECTORS OF ORIGINAL FULL MATRIX. */
7559	/* FOR J=N STEP -1 UNTIL LOW DO -- .......... */
7560	i_1 = *n;
7561	for (jj = *low; jj <= i_1; ++jj) {
7562	j = n + low - jj;
7563	m = min(j,*igh);
7564
7565	i_2 = *igh;
7566	for (i = *low; i <= i_2; ++i) {
7567	zz = 0.;
7568
7569	i_3 = m;
7570	for (k = *low; k <= i_3; ++k) {
7571	/* L860: */
7572	zz += z[i + k * z_dim1] * h[k + j * h_dim1];
7573	}
7574
7575	z[i + j * z_dim1] = zz;
7576	/* L880: */
7577	}
7578	}
7579
7580	goto L1001;
7581	/* .......... SET ERROR -- ALL EIGENVALUES HAVE NOT */
7582	/* CONVERGED AFTER 30N ITERATIONS .......... /
7583	L1000:
7584	*ierr = en;
7585	L1001:
7586	return 0;
7587	} /* hqr2_ */
7588
7589	/* Subroutine / int htrib3_(integer nm, integer n, doublereal a,
7590	doublereal tau, integer m, doublereal zr, doublereal zi)
7591	{
7592	/* System generated locals */
7593	integer a_dim1, a_offset, zr_dim1, zr_offset, zi_dim1, zi_offset, i_1,
7594	i_2, i_3;
7595
7596	/* Local variables */
7597	static doublereal h;
7598	static integer i, j, k, l;
7599	static doublereal s, si;
7600
7601
7602
7603	/* THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF */
7604	/* THE ALGOL PROCEDURE TRBAK3, NUM. MATH. 11, 181-195(1968) */
7605	/* BY MARTIN, REINSCH, AND WILKINSON. */
7606	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). */
7607
7608	/* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX HERMITIAN */
7609	/* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */
7610	/* REAL SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY HTRID3. */
7611
7612	/* ON INPUT */
7613
7614	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
7615	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
7616	/* DIMENSION STATEMENT. */
7617
7618	/* N IS THE ORDER OF THE MATRIX. */
7619
7620	/* A CONTAINS INFORMATION ABOUT THE UNITARY TRANSFORMATIONS */
7621	/* USED IN THE REDUCTION BY HTRID3. */
7622
7623	/* TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. */
7624
7625	/* M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. */
7626
7627	/* ZR CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED */
7628	/* IN ITS FIRST M COLUMNS. */
7629
7630	/* ON OUTPUT */
7631
7632	/* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */
7633	/* RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS */
7634	/* IN THEIR FIRST M COLUMNS. */
7635
7636	/* NOTE THAT THE LAST COMPONENT OF EACH RETURNED VECTOR */
7637	/* IS REAL AND THAT VECTOR EUCLIDEAN NORMS ARE PRESERVED. */
7638
7639	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
7640	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
7641	*/
7642
7643	/* THIS VERSION DATED AUGUST 1983. */
7644
7645	/* ------------------------------------------------------------------
7646	*/
7647
7648	/* Parameter adjustments */
7649	tau -= 3;
7650	a_dim1 = *nm;
7651	a_offset = a_dim1 + 1;
7652	a -= a_offset;
7653	zi_dim1 = *nm;
7654	zi_offset = zi_dim1 + 1;
7655	zi -= zi_offset;
7656	zr_dim1 = *nm;
7657	zr_offset = zr_dim1 + 1;
7658	zr -= zr_offset;
7659
7660	/* Function Body */
7661	if (*m == 0) {
7662	goto L200;
7663	}
7664	/* .......... TRANSFORM THE EIGENVECTORS OF THE REAL SYMMETRIC */
7665	/* TRIDIAGONAL MATRIX TO THOSE OF THE HERMITIAN */
7666	/* TRIDIAGONAL MATRIX. .......... */
7667	i_1 = *n;
7668	for (k = 1; k <= i_1; ++k) {
7669
7670	i_2 = *m;
7671	for (j = 1; j <= i_2; ++j) {
7672	zi[k + j * zi_dim1] = -zr[k + j * zr_dim1] * tau[(k << 1) + 2];
7673	zr[k + j * zr_dim1] *= tau[(k << 1) + 1];
7674	/* L50: */
7675	}
7676	}
7677
7678	if (*n == 1) {
7679	goto L200;
7680	}
7681	/* .......... RECOVER AND APPLY THE HOUSEHOLDER MATRICES .......... */
7682	i_2 = *n;
7683	for (i = 2; i <= i_2; ++i) {
7684	l = i - 1;
7685	h = a[i + i * a_dim1];
7686	if (h == 0.) {
7687	goto L140;
7688	}
7689
7690	i_1 = *m;
7691	for (j = 1; j <= i_1; ++j) {
7692	s = 0.;
7693	si = 0.;
7694
7695	i_3 = l;
7696	for (k = 1; k <= i_3; ++k) {
7697	s = s + a[i + k * a_dim1] * zr[k + j * zr_dim1] - a[k + i *
7698	a_dim1] * zi[k + j * zi_dim1];
7699	si = si + a[i + k * a_dim1] * zi[k + j * zi_dim1] + a[k + i *
7700	a_dim1] * zr[k + j * zr_dim1];
7701	/* L110: */
7702	}
7703	/* .......... DOUBLE DIVISIONS AVOID POSSIBLE UNDERFLOW ......
7704	.... */
7705	s = s / h / h;
7706	si = si / h / h;
7707
7708	i_3 = l;
7709	for (k = 1; k <= i_3; ++k) {
7710	zr[k + j * zr_dim1] = zr[k + j * zr_dim1] - s * a[i + k *
7711	a_dim1] - si * a[k + i * a_dim1];
7712	zi[k + j * zi_dim1] = zi[k + j * zi_dim1] - si * a[i + k *
7713	a_dim1] + s * a[k + i * a_dim1];
7714	/* L120: */
7715	}
7716
7717	/* L130: */
7718	}
7719
7720	L140:
7721	;
7722	}
7723
7724	L200:
7725	return 0;
7726	} /* htrib3_ */
7727
7728	/* Subroutine / int htribk_(integer nm, integer n, doublereal ar,
7729	doublereal ai, doublereal tau, integer m, doublereal zr,
7730	doublereal *zi)
7731	{
7732	/* System generated locals */
7733	integer ar_dim1, ar_offset, ai_dim1, ai_offset, zr_dim1, zr_offset,
7734	zi_dim1, zi_offset, i_1, i_2, i_3;
7735
7736	/* Local variables */
7737	static doublereal h;
7738	static integer i, j, k, l;
7739	static doublereal s, si;
7740
7741
7742
7743	/* THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF */
7744	/* THE ALGOL PROCEDURE TRBAK1, NUM. MATH. 11, 181-195(1968) */
7745	/* BY MARTIN, REINSCH, AND WILKINSON. */
7746	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). */
7747
7748	/* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX HERMITIAN */
7749	/* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */
7750	/* REAL SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY HTRIDI. */
7751
7752	/* ON INPUT */
7753
7754	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
7755	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
7756	/* DIMENSION STATEMENT. */
7757
7758	/* N IS THE ORDER OF THE MATRIX. */
7759
7760	/* AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY TRANS- */
7761	/* FORMATIONS USED IN THE REDUCTION BY HTRIDI IN THEIR */
7762	/* FULL LOWER TRIANGLES EXCEPT FOR THE DIAGONAL OF AR. */
7763
7764	/* TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. */
7765
7766	/* M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. */
7767
7768	/* ZR CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED */
7769	/* IN ITS FIRST M COLUMNS. */
7770
7771	/* ON OUTPUT */
7772
7773	/* ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, */
7774	/* RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS */
7775	/* IN THEIR FIRST M COLUMNS. */
7776
7777	/* NOTE THAT THE LAST COMPONENT OF EACH RETURNED VECTOR */
7778	/* IS REAL AND THAT VECTOR EUCLIDEAN NORMS ARE PRESERVED. */
7779
7780	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
7781	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
7782	*/
7783
7784	/* THIS VERSION DATED AUGUST 1983. */
7785
7786	/* ------------------------------------------------------------------
7787	*/
7788
7789	/* Parameter adjustments */
7790	tau -= 3;
7791	ai_dim1 = *nm;
7792	ai_offset = ai_dim1 + 1;
7793	ai -= ai_offset;
7794	ar_dim1 = *nm;
7795	ar_offset = ar_dim1 + 1;
7796	ar -= ar_offset;
7797	zi_dim1 = *nm;
7798	zi_offset = zi_dim1 + 1;
7799	zi -= zi_offset;
7800	zr_dim1 = *nm;
7801	zr_offset = zr_dim1 + 1;
7802	zr -= zr_offset;
7803
7804	/* Function Body */
7805	if (*m == 0) {
7806	goto L200;
7807	}
7808	/* .......... TRANSFORM THE EIGENVECTORS OF THE REAL SYMMETRIC */
7809	/* TRIDIAGONAL MATRIX TO THOSE OF THE HERMITIAN */
7810	/* TRIDIAGONAL MATRIX. .......... */
7811	i_1 = *n;
7812	for (k = 1; k <= i_1; ++k) {
7813
7814	i_2 = *m;
7815	for (j = 1; j <= i_2; ++j) {
7816	zi[k + j * zi_dim1] = -zr[k + j * zr_dim1] * tau[(k << 1) + 2];
7817	zr[k + j * zr_dim1] *= tau[(k << 1) + 1];
7818	/* L50: */
7819	}
7820	}
7821
7822	if (*n == 1) {
7823	goto L200;
7824	}
7825	/* .......... RECOVER AND APPLY THE HOUSEHOLDER MATRICES .......... */
7826	i_2 = *n;
7827	for (i = 2; i <= i_2; ++i) {
7828	l = i - 1;
7829	h = ai[i + i * ai_dim1];
7830	if (h == 0.) {
7831	goto L140;
7832	}
7833
7834	i_1 = *m;
7835	for (j = 1; j <= i_1; ++j) {
7836	s = 0.;
7837	si = 0.;
7838
7839	i_3 = l;
7840	for (k = 1; k <= i_3; ++k) {
7841	s = s + ar[i + k * ar_dim1] * zr[k + j * zr_dim1] - ai[i + k *
7842	ai_dim1] * zi[k + j * zi_dim1];
7843	si = si + ar[i + k * ar_dim1] * zi[k + j * zi_dim1] + ai[i +
7844	k * ai_dim1] * zr[k + j * zr_dim1];
7845	/* L110: */
7846	}
7847	/* .......... DOUBLE DIVISIONS AVOID POSSIBLE UNDERFLOW ......
7848	.... */
7849	s = s / h / h;
7850	si = si / h / h;
7851
7852	i_3 = l;
7853	for (k = 1; k <= i_3; ++k) {
7854	zr[k + j * zr_dim1] = zr[k + j * zr_dim1] - s * ar[i + k *
7855	ar_dim1] - si * ai[i + k * ai_dim1];
7856	zi[k + j * zi_dim1] = zi[k + j * zi_dim1] - si * ar[i + k *
7857	ar_dim1] + s * ai[i + k * ai_dim1];
7858	/* L120: */
7859	}
7860
7861	/* L130: */
7862	}
7863
7864	L140:
7865	;
7866	}
7867
7868	L200:
7869	return 0;
7870	} /* htribk_ */
7871
7872	/* Subroutine / int htrid3_(integer nm, integer n, doublereal a,
7873	doublereal d, doublereal e, doublereal e2, doublereal tau)
7874	{
7875	/* System generated locals */
7876	integer a_dim1, a_offset, i_1, i_2, i_3;
7877	doublereal d_1, d_2;
7878
7879	/* Builtin functions */
7880	double sqrt(doublereal);
7881
7882	/* Local variables */
7883	static doublereal f, g, h;
7884	static integer i, j, k, l;
7885	static doublereal scale, fi, gi, hh;
7886	static integer ii;
7887	static doublereal si;
7888	extern doublereal pythag_(doublereal , doublereal );
7889	static integer jm1, jp1;
7890
7891
7892
7893	/* THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF */
7894	/* THE ALGOL PROCEDURE TRED3, NUM. MATH. 11, 181-195(1968) */
7895	/* BY MARTIN, REINSCH, AND WILKINSON. */
7896	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). */
7897
7898	/* THIS SUBROUTINE REDUCES A COMPLEX HERMITIAN MATRIX, STORED AS */
7899	/* A SINGLE SQUARE ARRAY, TO A REAL SYMMETRIC TRIDIAGONAL MATRIX */
7900	/* USING UNITARY SIMILARITY TRANSFORMATIONS. */
7901
7902	/* ON INPUT */
7903
7904	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
7905	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
7906	/* DIMENSION STATEMENT. */
7907
7908	/* N IS THE ORDER OF THE MATRIX. */
7909
7910	/* A CONTAINS THE LOWER TRIANGLE OF THE COMPLEX HERMITIAN INPUT */
7911	/* MATRIX. THE REAL PARTS OF THE MATRIX ELEMENTS ARE STORED */
7912	/* IN THE FULL LOWER TRIANGLE OF A, AND THE IMAGINARY PARTS */
7913	/* ARE STORED IN THE TRANSPOSED POSITIONS OF THE STRICT UPPER */
7914	/* TRIANGLE OF A. NO STORAGE IS REQUIRED FOR THE ZERO */
7915	/* IMAGINARY PARTS OF THE DIAGONAL ELEMENTS. */
7916
7917	/* ON OUTPUT */
7918
7919	/* A CONTAINS INFORMATION ABOUT THE UNITARY TRANSFORMATIONS */
7920	/* USED IN THE REDUCTION. */
7921
7922	/* D CONTAINS THE DIAGONAL ELEMENTS OF THE THE TRIDIAGONAL MATRIX.
7923	*/
7924
7925	/* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL */
7926	/* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. */
7927
7928	/* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */
7929	/* E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. */
7930
7931	/* TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. */
7932
7933	/* CALLS PYTHAG FOR DSQRT(AA + BB) . */
7934
7935	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
7936	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
7937	*/
7938
7939	/* THIS VERSION DATED AUGUST 1983. */
7940
7941	/* ------------------------------------------------------------------
7942	*/
7943
7944	/* Parameter adjustments */
7945	tau -= 3;
7946	--e2;
7947	--e;
7948	--d;
7949	a_dim1 = *nm;
7950	a_offset = a_dim1 + 1;
7951	a -= a_offset;
7952
7953	/* Function Body */
7954	tau[(*n << 1) + 1] = 1.;
7955	tau[(*n << 1) + 2] = 0.;
7956	/* .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... */
7957	i_1 = *n;
7958	for (ii = 1; ii <= i_1; ++ii) {
7959	i = *n + 1 - ii;
7960	l = i - 1;
7961	h = 0.;
7962	scale = 0.;
7963	if (l < 1) {
7964	goto L130;
7965	}
7966	/* .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... */
7967	i_2 = l;
7968	for (k = 1; k <= i_2; ++k) {
7969	/* L120: */
7970	scale = scale + (d_1 = a[i + k * a_dim1], abs(d_1)) + (d_2 = a[
7971	k + i * a_dim1], abs(d_2));
7972	}
7973
7974	if (scale != 0.) {
7975	goto L140;
7976	}
7977	tau[(l << 1) + 1] = 1.;
7978	tau[(l << 1) + 2] = 0.;
7979	L130:
7980	e[i] = 0.;
7981	e2[i] = 0.;
7982	goto L290;
7983
7984	L140:
7985	i_2 = l;
7986	for (k = 1; k <= i_2; ++k) {
7987	a[i + k * a_dim1] /= scale;
7988	a[k + i * a_dim1] /= scale;
7989	h = h + a[i + k * a_dim1] * a[i + k * a_dim1] + a[k + i * a_dim1]
7990	* a[k + i * a_dim1];
7991	/* L150: */
7992	}
7993
7994	e2[i] = scale * scale * h;
7995	g = sqrt(h);
7996	e[i] = scale * g;
7997	f = pythag_(&a[i + l * a_dim1], &a[l + i * a_dim1]);
7998	/* .......... FORM NEXT DIAGONAL ELEMENT OF MATRIX T .......... */
7999	if (f == 0.) {
8000	goto L160;
8001	}
8002	tau[(l << 1) + 1] = (a[l + i * a_dim1] * tau[(i << 1) + 2] - a[i + l *
8003	a_dim1] * tau[(i << 1) + 1]) / f;
8004	si = (a[i + l * a_dim1] * tau[(i << 1) + 2] + a[l + i * a_dim1] * tau[
8005	(i << 1) + 1]) / f;
8006	h += f * g;
8007	g = g / f + 1.;
8008	a[i + l * a_dim1] = g * a[i + l * a_dim1];
8009	a[l + i * a_dim1] = g * a[l + i * a_dim1];
8010	if (l == 1) {
8011	goto L270;
8012	}
8013	goto L170;
8014	L160:
8015	tau[(l << 1) + 1] = -tau[(i << 1) + 1];
8016	si = tau[(i << 1) + 2];
8017	a[i + l * a_dim1] = g;
8018	L170:
8019	f = 0.;
8020
8021	i_2 = l;
8022	for (j = 1; j <= i_2; ++j) {
8023	g = 0.;
8024	gi = 0.;
8025	if (j == 1) {
8026	goto L190;
8027	}
8028	jm1 = j - 1;
8029	/* .......... FORM ELEMENT OF AU .......... /
8030	i_3 = jm1;
8031	for (k = 1; k <= i_3; ++k) {
8032	g = g + a[j + k * a_dim1] * a[i + k * a_dim1] + a[k + j *
8033	a_dim1] * a[k + i * a_dim1];
8034	gi = gi - a[j + k * a_dim1] * a[k + i * a_dim1] + a[k + j *
8035	a_dim1] * a[i + k * a_dim1];
8036	/* L180: */
8037	}
8038
8039	L190:
8040	g += a[j + j * a_dim1] * a[i + j * a_dim1];
8041	gi -= a[j + j * a_dim1] * a[j + i * a_dim1];
8042	jp1 = j + 1;
8043	if (l < jp1) {
8044	goto L220;
8045	}
8046
8047	i_3 = l;
8048	for (k = jp1; k <= i_3; ++k) {
8049	g = g + a[k + j * a_dim1] * a[i + k * a_dim1] - a[j + k *
8050	a_dim1] * a[k + i * a_dim1];
8051	gi = gi - a[k + j * a_dim1] * a[k + i * a_dim1] - a[j + k *
8052	a_dim1] * a[i + k * a_dim1];
8053	/* L200: */
8054	}
8055	/* .......... FORM ELEMENT OF P .......... */
8056	L220:
8057	e[j] = g / h;
8058	tau[(j << 1) + 2] = gi / h;
8059	f = f + e[j] * a[i + j * a_dim1] - tau[(j << 1) + 2] * a[j + i *
8060	a_dim1];
8061	/* L240: */
8062	}
8063
8064	hh = f / (h + h);
8065	/* .......... FORM REDUCED A .......... */
8066	i_2 = l;
8067	for (j = 1; j <= i_2; ++j) {
8068	f = a[i + j * a_dim1];
8069	g = e[j] - hh * f;
8070	e[j] = g;
8071	fi = -a[j + i * a_dim1];
8072	gi = tau[(j << 1) + 2] - hh * fi;
8073	tau[(j << 1) + 2] = -gi;
8074	a[j + j * a_dim1] -= (f * g + fi * gi) * 2.;
8075	if (j == 1) {
8076	goto L260;
8077	}
8078	jm1 = j - 1;
8079
8080	i_3 = jm1;
8081	for (k = 1; k <= i_3; ++k) {
8082	a[j + k * a_dim1] = a[j + k * a_dim1] - f * e[k] - g * a[i +
8083	k * a_dim1] + fi * tau[(k << 1) + 2] + gi * a[k + i *
8084	a_dim1];
8085	a[k + j * a_dim1] = a[k + j * a_dim1] - f * tau[(k << 1) + 2]
8086	- g * a[k + i * a_dim1] - fi * e[k] - gi * a[i + k *
8087	a_dim1];
8088	/* L250: */
8089	}
8090
8091	L260:
8092	;
8093	}
8094
8095	L270:
8096	i_2 = l;
8097	for (k = 1; k <= i_2; ++k) {
8098	a[i + k * a_dim1] = scale * a[i + k * a_dim1];
8099	a[k + i * a_dim1] = scale * a[k + i * a_dim1];
8100	/* L280: */
8101	}
8102
8103	tau[(l << 1) + 2] = -si;
8104	L290:
8105	d[i] = a[i + i * a_dim1];
8106	a[i + i * a_dim1] = scale * sqrt(h);
8107	/* L300: */
8108	}
8109
8110	return 0;
8111	} /* htrid3_ */
8112
8113	/* Subroutine / int htridi_(integer nm, integer n, doublereal ar,
8114	doublereal ai, doublereal d, doublereal e, doublereal e2,
8115	doublereal *tau)
8116	{
8117	/* System generated locals */
8118	integer ar_dim1, ar_offset, ai_dim1, ai_offset, i_1, i_2, i_3;
8119	doublereal d_1, d_2;
8120
8121	/* Builtin functions */
8122	double sqrt(doublereal);
8123
8124	/* Local variables */
8125	static doublereal f, g, h;
8126	static integer i, j, k, l;
8127	static doublereal scale, fi, gi, hh;
8128	static integer ii;
8129	static doublereal si;
8130	extern doublereal pythag_(doublereal , doublereal );
8131	static integer jp1;
8132
8133
8134
8135	/* THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF */
8136	/* THE ALGOL PROCEDURE TRED1, NUM. MATH. 11, 181-195(1968) */
8137	/* BY MARTIN, REINSCH, AND WILKINSON. */
8138	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). */
8139
8140	/* THIS SUBROUTINE REDUCES A COMPLEX HERMITIAN MATRIX */
8141	/* TO A REAL SYMMETRIC TRIDIAGONAL MATRIX USING */
8142	/* UNITARY SIMILARITY TRANSFORMATIONS. */
8143
8144	/* ON INPUT */
8145
8146	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
8147	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
8148	/* DIMENSION STATEMENT. */
8149
8150	/* N IS THE ORDER OF THE MATRIX. */
8151
8152	/* AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, */
8153	/* RESPECTIVELY, OF THE COMPLEX HERMITIAN INPUT MATRIX. */
8154	/* ONLY THE LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED. */
8155
8156	/* ON OUTPUT */
8157
8158	/* AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY TRANS- */
8159	/* FORMATIONS USED IN THE REDUCTION IN THEIR FULL LOWER */
8160	/* TRIANGLES. THEIR STRICT UPPER TRIANGLES AND THE */
8161	/* DIAGONAL OF AR ARE UNALTERED. */
8162
8163	/* D CONTAINS THE DIAGONAL ELEMENTS OF THE THE TRIDIAGONAL MATRIX.
8164	*/
8165
8166	/* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL */
8167	/* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. */
8168
8169	/* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */
8170	/* E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. */
8171
8172	/* TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. */
8173
8174	/* CALLS PYTHAG FOR DSQRT(AA + BB) . */
8175
8176	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
8177	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
8178	*/
8179
8180	/* THIS VERSION DATED AUGUST 1983. */
8181
8182	/* ------------------------------------------------------------------
8183	*/
8184
8185	/* Parameter adjustments */
8186	tau -= 3;
8187	--e2;
8188	--e;
8189	--d;
8190	ai_dim1 = *nm;
8191	ai_offset = ai_dim1 + 1;
8192	ai -= ai_offset;
8193	ar_dim1 = *nm;
8194	ar_offset = ar_dim1 + 1;
8195	ar -= ar_offset;
8196
8197	/* Function Body */
8198	tau[(*n << 1) + 1] = 1.;
8199	tau[(*n << 1) + 2] = 0.;
8200
8201	i_1 = *n;
8202	for (i = 1; i <= i_1; ++i) {
8203	/* L100: */
8204	d[i] = ar[i + i * ar_dim1];
8205	}
8206	/* .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... */
8207	i_1 = *n;
8208	for (ii = 1; ii <= i_1; ++ii) {
8209	i = *n + 1 - ii;
8210	l = i - 1;
8211	h = 0.;
8212	scale = 0.;
8213	if (l < 1) {
8214	goto L130;
8215	}
8216	/* .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... */
8217	i_2 = l;
8218	for (k = 1; k <= i_2; ++k) {
8219	/* L120: */
8220	scale = scale + (d_1 = ar[i + k * ar_dim1], abs(d_1)) + (d_2 =
8221	ai[i + k * ai_dim1], abs(d_2));
8222	}
8223
8224	if (scale != 0.) {
8225	goto L140;
8226	}
8227	tau[(l << 1) + 1] = 1.;
8228	tau[(l << 1) + 2] = 0.;
8229	L130:
8230	e[i] = 0.;
8231	e2[i] = 0.;
8232	goto L290;
8233
8234	L140:
8235	i_2 = l;
8236	for (k = 1; k <= i_2; ++k) {
8237	ar[i + k * ar_dim1] /= scale;
8238	ai[i + k * ai_dim1] /= scale;
8239	h = h + ar[i + k * ar_dim1] * ar[i + k * ar_dim1] + ai[i + k *
8240	ai_dim1] * ai[i + k * ai_dim1];
8241	/* L150: */
8242	}
8243
8244	e2[i] = scale * scale * h;
8245	g = sqrt(h);
8246	e[i] = scale * g;
8247	f = pythag_(&ar[i + l * ar_dim1], &ai[i + l * ai_dim1]);
8248	/* .......... FORM NEXT DIAGONAL ELEMENT OF MATRIX T .......... */
8249	if (f == 0.) {
8250	goto L160;
8251	}
8252	tau[(l << 1) + 1] = (ai[i + l * ai_dim1] * tau[(i << 1) + 2] - ar[i +
8253	l * ar_dim1] * tau[(i << 1) + 1]) / f;
8254	si = (ar[i + l * ar_dim1] * tau[(i << 1) + 2] + ai[i + l * ai_dim1] *
8255	tau[(i << 1) + 1]) / f;
8256	h += f * g;
8257	g = g / f + 1.;
8258	ar[i + l * ar_dim1] = g * ar[i + l * ar_dim1];
8259	ai[i + l * ai_dim1] = g * ai[i + l * ai_dim1];
8260	if (l == 1) {
8261	goto L270;
8262	}
8263	goto L170;
8264	L160:
8265	tau[(l << 1) + 1] = -tau[(i << 1) + 1];
8266	si = tau[(i << 1) + 2];
8267	ar[i + l * ar_dim1] = g;
8268	L170:
8269	f = 0.;
8270
8271	i_2 = l;
8272	for (j = 1; j <= i_2; ++j) {
8273	g = 0.;
8274	gi = 0.;
8275	/* .......... FORM ELEMENT OF AU .......... /
8276	i_3 = j;
8277	for (k = 1; k <= i_3; ++k) {
8278	g = g + ar[j + k * ar_dim1] * ar[i + k * ar_dim1] + ai[j + k *
8279	ai_dim1] * ai[i + k * ai_dim1];
8280	gi = gi - ar[j + k * ar_dim1] * ai[i + k * ai_dim1] + ai[j +
8281	k * ai_dim1] * ar[i + k * ar_dim1];
8282	/* L180: */
8283	}
8284
8285	jp1 = j + 1;
8286	if (l < jp1) {
8287	goto L220;
8288	}
8289
8290	i_3 = l;
8291	for (k = jp1; k <= i_3; ++k) {
8292	g = g + ar[k + j * ar_dim1] * ar[i + k * ar_dim1] - ai[k + j *
8293	ai_dim1] * ai[i + k * ai_dim1];
8294	gi = gi - ar[k + j * ar_dim1] * ai[i + k * ai_dim1] - ai[k +
8295	j * ai_dim1] * ar[i + k * ar_dim1];
8296	/* L200: */
8297	}
8298	/* .......... FORM ELEMENT OF P .......... */
8299	L220:
8300	e[j] = g / h;
8301	tau[(j << 1) + 2] = gi / h;
8302	f = f + e[j] * ar[i + j * ar_dim1] - tau[(j << 1) + 2] * ai[i + j
8303	* ai_dim1];
8304	/* L240: */
8305	}
8306
8307	hh = f / (h + h);
8308	/* .......... FORM REDUCED A .......... */
8309	i_2 = l;
8310	for (j = 1; j <= i_2; ++j) {
8311	f = ar[i + j * ar_dim1];
8312	g = e[j] - hh * f;
8313	e[j] = g;
8314	fi = -ai[i + j * ai_dim1];
8315	gi = tau[(j << 1) + 2] - hh * fi;
8316	tau[(j << 1) + 2] = -gi;
8317
8318	i_3 = j;
8319	for (k = 1; k <= i_3; ++k) {
8320	ar[j + k * ar_dim1] = ar[j + k * ar_dim1] - f * e[k] - g * ar[
8321	i + k * ar_dim1] + fi * tau[(k << 1) + 2] + gi * ai[i
8322	+ k * ai_dim1];
8323	ai[j + k * ai_dim1] = ai[j + k * ai_dim1] - f * tau[(k << 1)
8324	+ 2] - g * ai[i + k * ai_dim1] - fi * e[k] - gi * ar[
8325	i + k * ar_dim1];
8326	/* L260: */
8327	}
8328	}
8329
8330	L270:
8331	i_3 = l;
8332	for (k = 1; k <= i_3; ++k) {
8333	ar[i + k * ar_dim1] = scale * ar[i + k * ar_dim1];
8334	ai[i + k * ai_dim1] = scale * ai[i + k * ai_dim1];
8335	/* L280: */
8336	}
8337
8338	tau[(l << 1) + 2] = -si;
8339	L290:
8340	hh = d[i];
8341	d[i] = ar[i + i * ar_dim1];
8342	ar[i + i * ar_dim1] = hh;
8343	ai[i + i * ai_dim1] = scale * sqrt(h);
8344	/* L300: */
8345	}
8346
8347	return 0;
8348	} /* htridi_ */
8349
8350	/* Subroutine / int imtql1_(integer n, doublereal d, doublereal e,
8351	integer *ierr)
8352	{
8353	/* System generated locals */
8354	integer i_1, i_2;
8355	doublereal d_1, d_2;
8356
8357	/* Builtin functions */
8358	double d_sign(doublereal , doublereal );
8359
8360	/* Local variables */
8361	static doublereal b, c, f, g;
8362	static integer i, j, l, m;
8363	static doublereal p, r, s;
8364	static integer ii;
8365	extern doublereal pythag_(doublereal , doublereal );
8366	static integer mml;
8367	static doublereal tst1, tst2;
8368
8369
8370
8371	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE IMTQL1, */
8372	/* NUM. MATH. 12, 377-383(1968) BY MARTIN AND WILKINSON, */
8373	/* AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE. */
8374	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971). */
8375
8376	/* THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC */
8377	/* TRIDIAGONAL MATRIX BY THE IMPLICIT QL METHOD. */
8378
8379	/* ON INPUT */
8380
8381	/* N IS THE ORDER OF THE MATRIX. */
8382
8383	/* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */
8384
8385	/* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */
8386	/* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */
8387
8388	/* ON OUTPUT */
8389
8390	/* D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN */
8391	/* ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND */
8392	/* ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE */
8393	/* THE SMALLEST EIGENVALUES. */
8394
8395	/* E HAS BEEN DESTROYED. */
8396
8397	/* IERR IS SET TO */
8398	/* ZERO FOR NORMAL RETURN, */
8399	/* J IF THE J-TH EIGENVALUE HAS NOT BEEN */
8400	/* DETERMINED AFTER 30 ITERATIONS. */
8401
8402	/* CALLS PYTHAG FOR DSQRT(AA + BB) . */
8403
8404	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
8405	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
8406	*/
8407
8408	/* THIS VERSION DATED AUGUST 1983. */
8409
8410	/* ------------------------------------------------------------------
8411	*/
8412
8413	/* Parameter adjustments */
8414	--e;
8415	--d;
8416
8417	/* Function Body */
8418	*ierr = 0;
8419	if (*n == 1) {
8420	goto L1001;
8421	}
8422
8423	i_1 = *n;
8424	for (i = 2; i <= i_1; ++i) {
8425	/* L100: */
8426	e[i - 1] = e[i];
8427	}
8428
8429	e[*n] = 0.;
8430
8431	i_1 = *n;
8432	for (l = 1; l <= i_1; ++l) {
8433	j = 0;
8434	/* .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... */
8435	L105:
8436	i_2 = *n;
8437	for (m = l; m <= i_2; ++m) {
8438	if (m == *n) {
8439	goto L120;
8440	}
8441	tst1 = (d_1 = d[m], abs(d_1)) + (d_2 = d[m + 1], abs(d_2));
8442	tst2 = tst1 + (d_1 = e[m], abs(d_1));
8443	if (tst2 == tst1) {
8444	goto L120;
8445	}
8446	/* L110: */
8447	}
8448
8449	L120:
8450	p = d[l];
8451	if (m == l) {
8452	goto L215;
8453	}
8454	if (j == 30) {
8455	goto L1000;
8456	}
8457	++j;
8458	/* .......... FORM SHIFT .......... */
8459	g = (d[l + 1] - p) / (e[l] * 2.);
8460	r = pythag_(&g, &c_b141);
8461	g = d[m] - p + e[l] / (g + d_sign(&r, &g));
8462	s = 1.;
8463	c = 1.;
8464	p = 0.;
8465	mml = m - l;
8466	/* .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... */
8467	i_2 = mml;
8468	for (ii = 1; ii <= i_2; ++ii) {
8469	i = m - ii;
8470	f = s * e[i];
8471	b = c * e[i];
8472	r = pythag_(&f, &g);
8473	e[i + 1] = r;
8474	if (r == 0.) {
8475	goto L210;
8476	}
8477	s = f / r;
8478	c = g / r;
8479	g = d[i + 1] - p;
8480	r = (d[i] - g) * s + c * 2. * b;
8481	p = s * r;
8482	d[i + 1] = g + p;
8483	g = c * r - b;
8484	/* L200: */
8485	}
8486
8487	d[l] -= p;
8488	e[l] = g;
8489	e[m] = 0.;
8490	goto L105;
8491	/* .......... RECOVER FROM UNDERFLOW .......... */
8492	L210:
8493	d[i + 1] -= p;
8494	e[m] = 0.;
8495	goto L105;
8496	/* .......... ORDER EIGENVALUES .......... */
8497	L215:
8498	if (l == 1) {
8499	goto L250;
8500	}
8501	/* .......... FOR I=L STEP -1 UNTIL 2 DO -- .......... */
8502	i_2 = l;
8503	for (ii = 2; ii <= i_2; ++ii) {
8504	i = l + 2 - ii;
8505	if (p >= d[i - 1]) {
8506	goto L270;
8507	}
8508	d[i] = d[i - 1];
8509	/* L230: */
8510	}
8511
8512	L250:
8513	i = 1;
8514	L270:
8515	d[i] = p;
8516	/* L290: */
8517	}
8518
8519	goto L1001;
8520	/* .......... SET ERROR -- NO CONVERGENCE TO AN */
8521	/* EIGENVALUE AFTER 30 ITERATIONS .......... */
8522	L1000:
8523	*ierr = l;
8524	L1001:
8525	return 0;
8526	} /* imtql1_ */
8527
8528	/* Subroutine / int imtql2_(integer nm, integer n, doublereal d,
8529	doublereal e, doublereal z, integer *ierr)
8530	{
8531	/* System generated locals */
8532	integer z_dim1, z_offset, i_1, i_2, i_3;
8533	doublereal d_1, d_2;
8534
8535	/* Builtin functions */
8536	double d_sign(doublereal , doublereal );
8537
8538	/* Local variables */
8539	static doublereal b, c, f, g;
8540	static integer i, j, k, l, m;
8541	static doublereal p, r, s;
8542	static integer ii;
8543	extern doublereal pythag_(doublereal , doublereal );
8544	static integer mml;
8545	static doublereal tst1, tst2;
8546
8547
8548
8549	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE IMTQL2, */
8550	/* NUM. MATH. 12, 377-383(1968) BY MARTIN AND WILKINSON, */
8551	/* AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE. */
8552	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971). */
8553
8554	/* THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS */
8555	/* OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE IMPLICIT QL METHOD. */
8556	/* THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO */
8557	/* BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS */
8558	/* FULL MATRIX TO TRIDIAGONAL FORM. */
8559
8560	/* ON INPUT */
8561
8562	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
8563	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
8564	/* DIMENSION STATEMENT. */
8565
8566	/* N IS THE ORDER OF THE MATRIX. */
8567
8568	/* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */
8569
8570	/* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */
8571	/* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */
8572
8573	/* Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE */
8574	/* REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS */
8575	/* OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN */
8576	/* THE IDENTITY MATRIX. */
8577
8578	/* ON OUTPUT */
8579
8580	/* D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN */
8581	/* ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT */
8582	/* UNORDERED FOR INDICES 1,2,...,IERR-1. */
8583
8584	/* E HAS BEEN DESTROYED. */
8585
8586	/* Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC */
8587	/* TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE, */
8588	/* Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED */
8589	/* EIGENVALUES. */
8590
8591	/* IERR IS SET TO */
8592	/* ZERO FOR NORMAL RETURN, */
8593	/* J IF THE J-TH EIGENVALUE HAS NOT BEEN */
8594	/* DETERMINED AFTER 30 ITERATIONS. */
8595
8596	/* CALLS PYTHAG FOR DSQRT(AA + BB) . */
8597
8598	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
8599	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
8600	*/
8601
8602	/* THIS VERSION DATED AUGUST 1983. */
8603
8604	/* ------------------------------------------------------------------
8605	*/
8606
8607	/* Parameter adjustments */
8608	z_dim1 = *nm;
8609	z_offset = z_dim1 + 1;
8610	z -= z_offset;
8611	--e;
8612	--d;
8613
8614	/* Function Body */
8615	*ierr = 0;
8616	if (*n == 1) {
8617	goto L1001;
8618	}
8619
8620	i_1 = *n;
8621	for (i = 2; i <= i_1; ++i) {
8622	/* L100: */
8623	e[i - 1] = e[i];
8624	}
8625
8626	e[*n] = 0.;
8627
8628	i_1 = *n;
8629	for (l = 1; l <= i_1; ++l) {
8630	j = 0;
8631	/* .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... */
8632	L105:
8633	i_2 = *n;
8634	for (m = l; m <= i_2; ++m) {
8635	if (m == *n) {
8636	goto L120;
8637	}
8638	tst1 = (d_1 = d[m], abs(d_1)) + (d_2 = d[m + 1], abs(d_2));
8639	tst2 = tst1 + (d_1 = e[m], abs(d_1));
8640	if (tst2 == tst1) {
8641	goto L120;
8642	}
8643	/* L110: */
8644	}
8645
8646	L120:
8647	p = d[l];
8648	if (m == l) {
8649	goto L240;
8650	}
8651	if (j == 30) {
8652	goto L1000;
8653	}
8654	++j;
8655	/* .......... FORM SHIFT .......... */
8656	g = (d[l + 1] - p) / (e[l] * 2.);
8657	r = pythag_(&g, &c_b141);
8658	g = d[m] - p + e[l] / (g + d_sign(&r, &g));
8659	s = 1.;
8660	c = 1.;
8661	p = 0.;
8662	mml = m - l;
8663	/* .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... */
8664	i_2 = mml;
8665	for (ii = 1; ii <= i_2; ++ii) {
8666	i = m - ii;
8667	f = s * e[i];
8668	b = c * e[i];
8669	r = pythag_(&f, &g);
8670	e[i + 1] = r;
8671	if (r == 0.) {
8672	goto L210;
8673	}
8674	s = f / r;
8675	c = g / r;
8676	g = d[i + 1] - p;
8677	r = (d[i] - g) * s + c * 2. * b;
8678	p = s * r;
8679	d[i + 1] = g + p;
8680	g = c * r - b;
8681	/* .......... FORM VECTOR .......... */
8682	i_3 = *n;
8683	for (k = 1; k <= i_3; ++k) {
8684	f = z[k + (i + 1) * z_dim1];
8685	z[k + (i + 1) * z_dim1] = s * z[k + i * z_dim1] + c * f;
8686	z[k + i * z_dim1] = c * z[k + i * z_dim1] - s * f;
8687	/* L180: */
8688	}
8689
8690	/* L200: */
8691	}
8692
8693	d[l] -= p;
8694	e[l] = g;
8695	e[m] = 0.;
8696	goto L105;
8697	/* .......... RECOVER FROM UNDERFLOW .......... */
8698	L210:
8699	d[i + 1] -= p;
8700	e[m] = 0.;
8701	goto L105;
8702	L240:
8703	;
8704	}
8705	/* .......... ORDER EIGENVALUES AND EIGENVECTORS .......... */
8706	i_1 = *n;
8707	for (ii = 2; ii <= i_1; ++ii) {
8708	i = ii - 1;
8709	k = i;
8710	p = d[i];
8711
8712	i_2 = *n;
8713	for (j = ii; j <= i_2; ++j) {
8714	if (d[j] >= p) {
8715	goto L260;
8716	}
8717	k = j;
8718	p = d[j];
8719	L260:
8720	;
8721	}
8722
8723	if (k == i) {
8724	goto L300;
8725	}
8726	d[k] = d[i];
8727	d[i] = p;
8728
8729	i_2 = *n;
8730	for (j = 1; j <= i_2; ++j) {
8731	p = z[j + i * z_dim1];
8732	z[j + i * z_dim1] = z[j + k * z_dim1];
8733	z[j + k * z_dim1] = p;
8734	/* L280: */
8735	}
8736
8737	L300:
8738	;
8739	}
8740
8741	goto L1001;
8742	/* .......... SET ERROR -- NO CONVERGENCE TO AN */
8743	/* EIGENVALUE AFTER 30 ITERATIONS .......... */
8744	L1000:
8745	*ierr = l;
8746	L1001:
8747	return 0;
8748	} /* imtql2_ */
8749
8750	/* Subroutine / int imtqlv_(integer n, doublereal d, doublereal e,
8751	doublereal e2, doublereal w, integer ind, integer ierr,
8752	doublereal *rv1)
8753	{
8754	/* System generated locals */
8755	integer i_1, i_2;
8756	doublereal d_1, d_2;
8757
8758	/* Builtin functions */
8759	double d_sign(doublereal , doublereal );
8760
8761	/* Local variables */
8762	static doublereal b, c, f, g;
8763	static integer i, j, k, l, m;
8764	static doublereal p, r, s;
8765	static integer ii;
8766	extern doublereal pythag_(doublereal , doublereal );
8767	static integer tag, mml;
8768	static doublereal tst1, tst2;
8769
8770
8771
8772	/* THIS SUBROUTINE IS A VARIANT OF IMTQL1 WHICH IS A TRANSLATION OF
8773	*/
8774	/* ALGOL PROCEDURE IMTQL1, NUM. MATH. 12, 377-383(1968) BY MARTIN AND
8775	*/
8776	/* WILKINSON, AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE. */
8777	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971). */
8778
8779	/* THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC TRIDIAGONAL */
8780	/* MATRIX BY THE IMPLICIT QL METHOD AND ASSOCIATES WITH THEM */
8781	/* THEIR CORRESPONDING SUBMATRIX INDICES. */
8782
8783	/* ON INPUT */
8784
8785	/* N IS THE ORDER OF THE MATRIX. */
8786
8787	/* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */
8788
8789	/* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */
8790	/* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */
8791
8792	/* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */
8793	/* E2(1) IS ARBITRARY. */
8794
8795	/* ON OUTPUT */
8796
8797	/* D AND E ARE UNALTERED. */
8798
8799	/* ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED */
8800	/* AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE */
8801	/* MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES. */
8802	/* E2(1) IS ALSO SET TO ZERO. */
8803
8804	/* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN */
8805	/* ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND */
8806	/* ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE */
8807	/* THE SMALLEST EIGENVALUES. */
8808
8809	/* IND CONTAINS THE SUBMATRIX INDICES ASSOCIATED WITH THE */
8810	/* CORRESPONDING EIGENVALUES IN W -- 1 FOR EIGENVALUES */
8811	/* BELONGING TO THE FIRST SUBMATRIX FROM THE TOP, */
8812	/* 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC.. */
8813
8814	/* IERR IS SET TO */
8815	/* ZERO FOR NORMAL RETURN, */
8816	/* J IF THE J-TH EIGENVALUE HAS NOT BEEN */
8817	/* DETERMINED AFTER 30 ITERATIONS. */
8818
8819	/* RV1 IS A TEMPORARY STORAGE ARRAY. */
8820
8821	/* CALLS PYTHAG FOR DSQRT(AA + BB) . */
8822
8823	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
8824	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
8825	*/
8826
8827	/* THIS VERSION DATED AUGUST 1983. */
8828
8829	/* ------------------------------------------------------------------
8830	*/
8831
8832	/* Parameter adjustments */
8833	--rv1;
8834	--ind;
8835	--w;
8836	--e2;
8837	--e;
8838	--d;
8839
8840	/* Function Body */
8841	*ierr = 0;
8842	k = 0;
8843	tag = 0;
8844
8845	i_1 = *n;
8846	for (i = 1; i <= i_1; ++i) {
8847	w[i] = d[i];
8848	if (i != 1) {
8849	rv1[i - 1] = e[i];
8850	}
8851	/* L100: */
8852	}
8853
8854	e2[1] = 0.;
8855	rv1[*n] = 0.;
8856
8857	i_1 = *n;
8858	for (l = 1; l <= i_1; ++l) {
8859	j = 0;
8860	/* .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... */
8861	L105:
8862	i_2 = *n;
8863	for (m = l; m <= i_2; ++m) {
8864	if (m == *n) {
8865	goto L120;
8866	}
8867	tst1 = (d_1 = w[m], abs(d_1)) + (d_2 = w[m + 1], abs(d_2));
8868	tst2 = tst1 + (d_1 = rv1[m], abs(d_1));
8869	if (tst2 == tst1) {
8870	goto L120;
8871	}
8872	/* .......... GUARD AGAINST UNDERFLOWED ELEMENT OF E2 ........
8873	.. */
8874	if (e2[m + 1] == 0.) {
8875	goto L125;
8876	}
8877	/* L110: */
8878	}
8879
8880	L120:
8881	if (m <= k) {
8882	goto L130;
8883	}
8884	if (m != *n) {
8885	e2[m + 1] = 0.;
8886	}
8887	L125:
8888	k = m;
8889	++tag;
8890	L130:
8891	p = w[l];
8892	if (m == l) {
8893	goto L215;
8894	}
8895	if (j == 30) {
8896	goto L1000;
8897	}
8898	++j;
8899	/* .......... FORM SHIFT .......... */
8900	g = (w[l + 1] - p) / (rv1[l] * 2.);
8901	r = pythag_(&g, &c_b141);
8902	g = w[m] - p + rv1[l] / (g + d_sign(&r, &g));
8903	s = 1.;
8904	c = 1.;
8905	p = 0.;
8906	mml = m - l;
8907	/* .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... */
8908	i_2 = mml;
8909	for (ii = 1; ii <= i_2; ++ii) {
8910	i = m - ii;
8911	f = s * rv1[i];
8912	b = c * rv1[i];
8913	r = pythag_(&f, &g);
8914	rv1[i + 1] = r;
8915	if (r == 0.) {
8916	goto L210;
8917	}
8918	s = f / r;
8919	c = g / r;
8920	g = w[i + 1] - p;
8921	r = (w[i] - g) * s + c * 2. * b;
8922	p = s * r;
8923	w[i + 1] = g + p;
8924	g = c * r - b;
8925	/* L200: */
8926	}
8927
8928	w[l] -= p;
8929	rv1[l] = g;
8930	rv1[m] = 0.;
8931	goto L105;
8932	/* .......... RECOVER FROM UNDERFLOW .......... */
8933	L210:
8934	w[i + 1] -= p;
8935	rv1[m] = 0.;
8936	goto L105;
8937	/* .......... ORDER EIGENVALUES .......... */
8938	L215:
8939	if (l == 1) {
8940	goto L250;
8941	}
8942	/* .......... FOR I=L STEP -1 UNTIL 2 DO -- .......... */
8943	i_2 = l;
8944	for (ii = 2; ii <= i_2; ++ii) {
8945	i = l + 2 - ii;
8946	if (p >= w[i - 1]) {
8947	goto L270;
8948	}
8949	w[i] = w[i - 1];
8950	ind[i] = ind[i - 1];
8951	/* L230: */
8952	}
8953
8954	L250:
8955	i = 1;
8956	L270:
8957	w[i] = p;
8958	ind[i] = tag;
8959	/* L290: */
8960	}
8961
8962	goto L1001;
8963	/* .......... SET ERROR -- NO CONVERGENCE TO AN */
8964	/* EIGENVALUE AFTER 30 ITERATIONS .......... */
8965	L1000:
8966	*ierr = l;
8967	L1001:
8968	return 0;
8969	} /* imtqlv_ */
8970
8971	/* Subroutine / int invit_(integer nm, integer n, doublereal a,
8972	doublereal wr, doublereal wi, logical select, integer mm, integer
8973	m, doublereal z, integer ierr, doublereal rm1, doublereal *rv1,
8974	doublereal *rv2)
8975	{
8976	/* System generated locals */
8977	integer a_dim1, a_offset, z_dim1, z_offset, rm1_dim1, rm1_offset, i_1,
8978	i_2, i_3;
8979	doublereal d_1, d_2;
8980
8981	/* Builtin functions */
8982	double sqrt(doublereal);
8983
8984	/* Local variables */
8985	extern /* Subroutine / int cdiv_(doublereal , doublereal , doublereal
8986	, doublereal , doublereal , doublereal *);
8987	static doublereal norm;
8988	static integer i, j, k, l, s;
8989	static doublereal t, w, x, y;
8990	static integer n1;
8991	static doublereal normv;
8992	static integer ii;
8993	static doublereal ilambd;
8994	static integer ip, mp, ns, uk;
8995	static doublereal rlambd;
8996	extern doublereal pythag_(doublereal , doublereal ), epslon_(doublereal
8997	*);
8998	static integer km1, ip1;
8999	static doublereal growto, ukroot;
9000	static integer its;
9001	static doublereal eps3;
9002
9003
9004
9005	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE INVIT */
9006	/* BY PETERS AND WILKINSON. */
9007	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). */
9008
9009	/* THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A REAL UPPER */
9010	/* HESSENBERG MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES, */
9011	/* USING INVERSE ITERATION. */
9012
9013	/* ON INPUT */
9014
9015	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
9016	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
9017	/* DIMENSION STATEMENT. */
9018
9019	/* N IS THE ORDER OF THE MATRIX. */
9020
9021	/* A CONTAINS THE HESSENBERG MATRIX. */
9022
9023	/* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, RESPECTIVELY, */
9024	/* OF THE EIGENVALUES OF THE MATRIX. THE EIGENVALUES MUST BE */
9025	/* STORED IN A MANNER IDENTICAL TO THAT OF SUBROUTINE HQR, */
9026	/* WHICH RECOGNIZES POSSIBLE SPLITTING OF THE MATRIX. */
9027
9028	/* SELECT SPECIFIES THE EIGENVECTORS TO BE FOUND. THE */
9029	/* EIGENVECTOR CORRESPONDING TO THE J-TH EIGENVALUE IS */
9030	/* SPECIFIED BY SETTING SELECT(J) TO .TRUE.. */
9031
9032	/* MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF */
9033	/* COLUMNS REQUIRED TO STORE THE EIGENVECTORS TO BE FOUND. */
9034	/* NOTE THAT TWO COLUMNS ARE REQUIRED TO STORE THE */
9035	/* EIGENVECTOR CORRESPONDING TO A COMPLEX EIGENVALUE. */
9036
9037	/* ON OUTPUT */
9038
9039	/* A AND WI ARE UNALTERED. */
9040
9041	/* WR MAY HAVE BEEN ALTERED SINCE CLOSE EIGENVALUES ARE PERTURBED
9042	*/
9043	/* SLIGHTLY IN SEARCHING FOR INDEPENDENT EIGENVECTORS. */
9044
9045	/* SELECT MAY HAVE BEEN ALTERED. IF THE ELEMENTS CORRESPONDING */
9046	/* TO A PAIR OF CONJUGATE COMPLEX EIGENVALUES WERE EACH */
9047	/* INITIALLY SET TO .TRUE., THE PROGRAM RESETS THE SECOND OF */
9048	/* THE TWO ELEMENTS TO .FALSE.. */
9049
9050	/* M IS THE NUMBER OF COLUMNS ACTUALLY USED TO STORE */
9051	/* THE EIGENVECTORS. */
9052
9053	/* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS. */
9054	/* IF THE NEXT SELECTED EIGENVALUE IS REAL, THE NEXT COLUMN */
9055	/* OF Z CONTAINS ITS EIGENVECTOR. IF THE EIGENVALUE IS */
9056	/* COMPLEX, THE NEXT TWO COLUMNS OF Z CONTAIN THE REAL AND */
9057	/* IMAGINARY PARTS OF ITS EIGENVECTOR. THE EIGENVECTORS ARE */
9058	/* NORMALIZED SO THAT THE COMPONENT OF LARGEST MAGNITUDE IS 1. */
9059	/* ANY VECTOR WHICH FAILS THE ACCEPTANCE TEST IS SET TO ZERO. */
9060
9061	/* IERR IS SET TO */
9062	/* ZERO FOR NORMAL RETURN, */
9063	/* -(2N+1) IF MORE THAN MM COLUMNS OF Z ARE NECESSARY /
9064	/* TO STORE THE EIGENVECTORS CORRESPONDING TO */
9065	/* THE SPECIFIED EIGENVALUES. */
9066	/* -K IF THE ITERATION CORRESPONDING TO THE K-TH */
9067	/* VALUE FAILS, */
9068	/* -(N+K) IF BOTH ERROR SITUATIONS OCCUR. */
9069
9070	/* RM1, RV1, AND RV2 ARE TEMPORARY STORAGE ARRAYS. NOTE THAT RM1
9071	*/
9072	/* IS SQUARE OF DIMENSION N BY N AND, AUGMENTED BY TWO COLUMNS */
9073	/* OF Z, IS THE TRANSPOSE OF THE CORRESPONDING ALGOL B ARRAY. */
9074
9075	/* THE ALGOL PROCEDURE GUESSVEC APPEARS IN INVIT IN LINE. */
9076
9077	/* CALLS CDIV FOR COMPLEX DIVISION. */
9078	/* CALLS PYTHAG FOR DSQRT(AA + BB) . */
9079
9080	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
9081	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
9082	*/
9083
9084	/* THIS VERSION DATED AUGUST 1983. */
9085
9086	/* ------------------------------------------------------------------
9087	*/
9088
9089	/* Parameter adjustments */
9090	--rv2;
9091	--rv1;
9092	rm1_dim1 = *n;
9093	rm1_offset = rm1_dim1 + 1;
9094	rm1 -= rm1_offset;
9095	--select;
9096	--wi;
9097	--wr;
9098	a_dim1 = *nm;
9099	a_offset = a_dim1 + 1;
9100	a -= a_offset;
9101	z_dim1 = *nm;
9102	z_offset = z_dim1 + 1;
9103	z -= z_offset;
9104
9105	/* Function Body */
9106	*ierr = 0;
9107	uk = 0;
9108	s = 1;
9109	/* .......... IP = 0, REAL EIGENVALUE */
9110	/* 1, FIRST OF CONJUGATE COMPLEX PAIR */
9111	/* -1, SECOND OF CONJUGATE COMPLEX PAIR .......... */
9112	ip = 0;
9113	n1 = *n - 1;
9114
9115	i_1 = *n;
9116	for (k = 1; k <= i_1; ++k) {
9117	if (wi[k] == 0. \|\| ip < 0) {
9118	goto L100;
9119	}
9120	ip = 1;
9121	if (select[k] && select[k + 1]) {
9122	select[k + 1] = FALSE_;
9123	}
9124	L100:
9125	if (! select[k]) {
9126	goto L960;
9127	}
9128	if (wi[k] != 0.) {
9129	++s;
9130	}
9131	if (s > *mm) {
9132	goto L1000;
9133	}
9134	if (uk >= k) {
9135	goto L200;
9136	}
9137	/* .......... CHECK FOR POSSIBLE SPLITTING .......... */
9138	i_2 = *n;
9139	for (uk = k; uk <= i_2; ++uk) {
9140	if (uk == *n) {
9141	goto L140;
9142	}
9143	if (a[uk + 1 + uk * a_dim1] == 0.) {
9144	goto L140;
9145	}
9146	/* L120: */
9147	}
9148	/* .......... COMPUTE INFINITY NORM OF LEADING UK BY UK */
9149	/* (HESSENBERG) MATRIX .......... */
9150	L140:
9151	norm = 0.;
9152	mp = 1;
9153
9154	i_2 = uk;
9155	for (i = 1; i <= i_2; ++i) {
9156	x = 0.;
9157
9158	i_3 = uk;
9159	for (j = mp; j <= i_3; ++j) {
9160	/* L160: */
9161	x += (d_1 = a[i + j * a_dim1], abs(d_1));
9162	}
9163
9164	if (x > norm) {
9165	norm = x;
9166	}
9167	mp = i;
9168	/* L180: */
9169	}
9170	/* .......... EPS3 REPLACES ZERO PIVOT IN DECOMPOSITION */
9171	/* AND CLOSE ROOTS ARE MODIFIED BY EPS3 .......... */
9172	if (norm == 0.) {
9173	norm = 1.;
9174	}
9175	eps3 = epslon_(&norm);
9176	/* .......... GROWTO IS THE CRITERION FOR THE GROWTH .......... */
9177	ukroot = (doublereal) uk;
9178	ukroot = sqrt(ukroot);
9179	growto = .1 / ukroot;
9180	L200:
9181	rlambd = wr[k];
9182	ilambd = wi[k];
9183	if (k == 1) {
9184	goto L280;
9185	}
9186	km1 = k - 1;
9187	goto L240;
9188	/* .......... PERTURB EIGENVALUE IF IT IS CLOSE */
9189	/* TO ANY PREVIOUS EIGENVALUE .......... */
9190	L220:
9191	rlambd += eps3;
9192	/* .......... FOR I=K-1 STEP -1 UNTIL 1 DO -- .......... */
9193	L240:
9194	i_2 = km1;
9195	for (ii = 1; ii <= i_2; ++ii) {
9196	i = k - ii;
9197	if (select[i] && (d_1 = wr[i] - rlambd, abs(d_1)) < eps3 && (
9198	d_2 = wi[i] - ilambd, abs(d_2)) < eps3) {
9199	goto L220;
9200	}
9201	/* L260: */
9202	}
9203
9204	wr[k] = rlambd;
9205	/* .......... PERTURB CONJUGATE EIGENVALUE TO MATCH .......... */
9206	ip1 = k + ip;
9207	wr[ip1] = rlambd;
9208	/* .......... FORM UPPER HESSENBERG A-RLAMBDI (TRANSPOSED) /
9209	/* AND INITIAL REAL VECTOR .......... */
9210	L280:
9211	mp = 1;
9212
9213	i_2 = uk;
9214	for (i = 1; i <= i_2; ++i) {
9215
9216	i_3 = uk;
9217	for (j = mp; j <= i_3; ++j) {
9218	/* L300: */
9219	rm1[j + i * rm1_dim1] = a[i + j * a_dim1];
9220	}
9221
9222	rm1[i + i * rm1_dim1] -= rlambd;
9223	mp = i;
9224	rv1[i] = eps3;
9225	/* L320: */
9226	}
9227
9228	its = 0;
9229	if (ilambd != 0.) {
9230	goto L520;
9231	}
9232	/* .......... REAL EIGENVALUE. */
9233	/* TRIANGULAR DECOMPOSITION WITH INTERCHANGES, */
9234	/* REPLACING ZERO PIVOTS BY EPS3 .......... */
9235	if (uk == 1) {
9236	goto L420;
9237	}
9238
9239	i_2 = uk;
9240	for (i = 2; i <= i_2; ++i) {
9241	mp = i - 1;
9242	if ((d_1 = rm1[mp + i * rm1_dim1], abs(d_1)) <= (d_2 = rm1[mp
9243	+ mp * rm1_dim1], abs(d_2))) {
9244	goto L360;
9245	}
9246
9247	i_3 = uk;
9248	for (j = mp; j <= i_3; ++j) {
9249	y = rm1[j + i * rm1_dim1];
9250	rm1[j + i * rm1_dim1] = rm1[j + mp * rm1_dim1];
9251	rm1[j + mp * rm1_dim1] = y;
9252	/* L340: */
9253	}
9254
9255	L360:
9256	if (rm1[mp + mp * rm1_dim1] == 0.) {
9257	rm1[mp + mp * rm1_dim1] = eps3;
9258	}
9259	x = rm1[mp + i * rm1_dim1] / rm1[mp + mp * rm1_dim1];
9260	if (x == 0.) {
9261	goto L400;
9262	}
9263
9264	i_3 = uk;
9265	for (j = i; j <= i_3; ++j) {
9266	/* L380: */
9267	rm1[j + i * rm1_dim1] -= x * rm1[j + mp * rm1_dim1];
9268	}
9269
9270	L400:
9271	;
9272	}
9273
9274	L420:
9275	if (rm1[uk + uk * rm1_dim1] == 0.) {
9276	rm1[uk + uk * rm1_dim1] = eps3;
9277	}
9278	/* .......... BACK SUBSTITUTION FOR REAL VECTOR */
9279	/* FOR I=UK STEP -1 UNTIL 1 DO -- .......... */
9280	L440:
9281	i_2 = uk;
9282	for (ii = 1; ii <= i_2; ++ii) {
9283	i = uk + 1 - ii;
9284	y = rv1[i];
9285	if (i == uk) {
9286	goto L480;
9287	}
9288	ip1 = i + 1;
9289
9290	i_3 = uk;
9291	for (j = ip1; j <= i_3; ++j) {
9292	/* L460: */
9293	y -= rm1[j + i * rm1_dim1] * rv1[j];
9294	}
9295
9296	L480:
9297	rv1[i] = y / rm1[i + i * rm1_dim1];
9298	/* L500: */
9299	}
9300
9301	goto L740;
9302	/* .......... COMPLEX EIGENVALUE. */
9303	/* TRIANGULAR DECOMPOSITION WITH INTERCHANGES, */
9304	/* REPLACING ZERO PIVOTS BY EPS3. STORE IMAGINARY */
9305	/* PARTS IN UPPER TRIANGLE STARTING AT (1,3) ..........
9306	*/
9307	L520:
9308	ns = *n - s;
9309	z[(s - 1) * z_dim1 + 1] = -ilambd;
9310	z[s * z_dim1 + 1] = 0.;
9311	if (*n == 2) {
9312	goto L550;
9313	}
9314	rm1[rm1_dim1 * 3 + 1] = -ilambd;
9315	z[(s - 1) * z_dim1 + 1] = 0.;
9316	if (*n == 3) {
9317	goto L550;
9318	}
9319
9320	i_2 = *n;
9321	for (i = 4; i <= i_2; ++i) {
9322	/* L540: */
9323	rm1[i * rm1_dim1 + 1] = 0.;
9324	}
9325
9326	L550:
9327	i_2 = uk;
9328	for (i = 2; i <= i_2; ++i) {
9329	mp = i - 1;
9330	w = rm1[mp + i * rm1_dim1];
9331	if (i < *n) {
9332	t = rm1[mp + (i + 1) * rm1_dim1];
9333	}
9334	if (i == *n) {
9335	t = z[mp + (s - 1) * z_dim1];
9336	}
9337	x = rm1[mp + mp * rm1_dim1] * rm1[mp + mp * rm1_dim1] + t * t;
9338	if (w * w <= x) {
9339	goto L580;
9340	}
9341	x = rm1[mp + mp * rm1_dim1] / w;
9342	y = t / w;
9343	rm1[mp + mp * rm1_dim1] = w;
9344	if (i < *n) {
9345	rm1[mp + (i + 1) * rm1_dim1] = 0.;
9346	}
9347	if (i == *n) {
9348	z[mp + (s - 1) * z_dim1] = 0.;
9349	}
9350
9351	i_3 = uk;
9352	for (j = i; j <= i_3; ++j) {
9353	w = rm1[j + i * rm1_dim1];
9354	rm1[j + i * rm1_dim1] = rm1[j + mp * rm1_dim1] - x * w;
9355	rm1[j + mp * rm1_dim1] = w;
9356	if (j < n1) {
9357	goto L555;
9358	}
9359	l = j - ns;
9360	z[i + l * z_dim1] = z[mp + l * z_dim1] - y * w;
9361	z[mp + l * z_dim1] = 0.;
9362	goto L560;
9363	L555:
9364	rm1[i + (j + 2) * rm1_dim1] = rm1[mp + (j + 2) * rm1_dim1] -
9365	y * w;
9366	rm1[mp + (j + 2) * rm1_dim1] = 0.;
9367	L560:
9368	;
9369	}
9370
9371	rm1[i + i * rm1_dim1] -= y * ilambd;
9372	if (i < n1) {
9373	goto L570;
9374	}
9375	l = i - ns;
9376	z[mp + l * z_dim1] = -ilambd;
9377	z[i + l * z_dim1] += x * ilambd;
9378	goto L640;
9379	L570:
9380	rm1[mp + (i + 2) * rm1_dim1] = -ilambd;
9381	rm1[i + (i + 2) * rm1_dim1] += x * ilambd;
9382	goto L640;
9383	L580:
9384	if (x != 0.) {
9385	goto L600;
9386	}
9387	rm1[mp + mp * rm1_dim1] = eps3;
9388	if (i < *n) {
9389	rm1[mp + (i + 1) * rm1_dim1] = 0.;
9390	}
9391	if (i == *n) {
9392	z[mp + (s - 1) * z_dim1] = 0.;
9393	}
9394	t = 0.;
9395	x = eps3 * eps3;
9396	L600:
9397	w /= x;
9398	x = rm1[mp + mp * rm1_dim1] * w;
9399	y = -t * w;
9400
9401	i_3 = uk;
9402	for (j = i; j <= i_3; ++j) {
9403	if (j < n1) {
9404	goto L610;
9405	}
9406	l = j - ns;
9407	t = z[mp + l * z_dim1];
9408	z[i + l * z_dim1] = -x * t - y * rm1[j + mp * rm1_dim1];
9409	goto L615;
9410	L610:
9411	t = rm1[mp + (j + 2) * rm1_dim1];
9412	rm1[i + (j + 2) * rm1_dim1] = -x * t - y * rm1[j + mp *
9413	rm1_dim1];
9414	L615:
9415	rm1[j + i * rm1_dim1] = rm1[j + i * rm1_dim1] - x * rm1[j +
9416	mp * rm1_dim1] + y * t;
9417	/* L620: */
9418	}
9419
9420	if (i < n1) {
9421	goto L630;
9422	}
9423	l = i - ns;
9424	z[i + l * z_dim1] -= ilambd;
9425	goto L640;
9426	L630:
9427	rm1[i + (i + 2) * rm1_dim1] -= ilambd;
9428	L640:
9429	;
9430	}
9431
9432	if (uk < n1) {
9433	goto L650;
9434	}
9435	l = uk - ns;
9436	t = z[uk + l * z_dim1];
9437	goto L655;
9438	L650:
9439	t = rm1[uk + (uk + 2) * rm1_dim1];
9440	L655:
9441	if (rm1[uk + uk * rm1_dim1] == 0. && t == 0.) {
9442	rm1[uk + uk * rm1_dim1] = eps3;
9443	}
9444	/* .......... BACK SUBSTITUTION FOR COMPLEX VECTOR */
9445	/* FOR I=UK STEP -1 UNTIL 1 DO -- .......... */
9446	L660:
9447	i_2 = uk;
9448	for (ii = 1; ii <= i_2; ++ii) {
9449	i = uk + 1 - ii;
9450	x = rv1[i];
9451	y = 0.;
9452	if (i == uk) {
9453	goto L700;
9454	}
9455	ip1 = i + 1;
9456
9457	i_3 = uk;
9458	for (j = ip1; j <= i_3; ++j) {
9459	if (j < n1) {
9460	goto L670;
9461	}
9462	l = j - ns;
9463	t = z[i + l * z_dim1];
9464	goto L675;
9465	L670:
9466	t = rm1[i + (j + 2) * rm1_dim1];
9467	L675:
9468	x = x - rm1[j + i * rm1_dim1] * rv1[j] + t * rv2[j];
9469	y = y - rm1[j + i * rm1_dim1] * rv2[j] - t * rv1[j];
9470	/* L680: */
9471	}
9472
9473	L700:
9474	if (i < n1) {
9475	goto L710;
9476	}
9477	l = i - ns;
9478	t = z[i + l * z_dim1];
9479	goto L715;
9480	L710:
9481	t = rm1[i + (i + 2) * rm1_dim1];
9482	L715:
9483	cdiv_(&x, &y, &rm1[i + i * rm1_dim1], &t, &rv1[i], &rv2[i]);
9484	/* L720: */
9485	}
9486	/* .......... ACCEPTANCE TEST FOR REAL OR COMPLEX */
9487	/* EIGENVECTOR AND NORMALIZATION .......... */
9488	L740:
9489	++its;
9490	norm = 0.;
9491	normv = 0.;
9492
9493	i_2 = uk;
9494	for (i = 1; i <= i_2; ++i) {
9495	if (ilambd == 0.) {
9496	x = (d_1 = rv1[i], abs(d_1));
9497	}
9498	if (ilambd != 0.) {
9499	x = pythag_(&rv1[i], &rv2[i]);
9500	}
9501	if (normv >= x) {
9502	goto L760;
9503	}
9504	normv = x;
9505	j = i;
9506	L760:
9507	norm += x;
9508	/* L780: */
9509	}
9510
9511	if (norm < growto) {
9512	goto L840;
9513	}
9514	/* .......... ACCEPT VECTOR .......... */
9515	x = rv1[j];
9516	if (ilambd == 0.) {
9517	x = 1. / x;
9518	}
9519	if (ilambd != 0.) {
9520	y = rv2[j];
9521	}
9522
9523	i_2 = uk;
9524	for (i = 1; i <= i_2; ++i) {
9525	if (ilambd != 0.) {
9526	goto L800;
9527	}
9528	z[i + s * z_dim1] = rv1[i] * x;
9529	goto L820;
9530	L800:
9531	cdiv_(&rv1[i], &rv2[i], &x, &y, &z[i + (s - 1) * z_dim1], &z[i +
9532	s * z_dim1]);
9533	L820:
9534	;
9535	}
9536
9537	if (uk == *n) {
9538	goto L940;
9539	}
9540	j = uk + 1;
9541	goto L900;
9542	/* .......... IN-LINE PROCEDURE FOR CHOOSING */
9543	/* A NEW STARTING VECTOR .......... */
9544	L840:
9545	if (its >= uk) {
9546	goto L880;
9547	}
9548	x = ukroot;
9549	y = eps3 / (x + 1.);
9550	rv1[1] = eps3;
9551
9552	i_2 = uk;
9553	for (i = 2; i <= i_2; ++i) {
9554	/* L860: */
9555	rv1[i] = y;
9556	}
9557
9558	j = uk - its + 1;
9559	rv1[j] -= eps3 * x;
9560	if (ilambd == 0.) {
9561	goto L440;
9562	}
9563	goto L660;
9564	/* .......... SET ERROR -- UNACCEPTED EIGENVECTOR .......... */
9565	L880:
9566	j = 1;
9567	*ierr = -k;
9568	/* .......... SET REMAINING VECTOR COMPONENTS TO ZERO ..........
9569	*/
9570	L900:
9571	i_2 = *n;
9572	for (i = j; i <= i_2; ++i) {
9573	z[i + s * z_dim1] = 0.;
9574	if (ilambd != 0.) {
9575	z[i + (s - 1) * z_dim1] = 0.;
9576	}
9577	/* L920: */
9578	}
9579
9580	L940:
9581	++s;
9582	L960:
9583	if (ip == -1) {
9584	ip = 0;
9585	}
9586	if (ip == 1) {
9587	ip = -1;
9588	}
9589	/* L980: */
9590	}
9591
9592	goto L1001;
9593	/* .......... SET ERROR -- UNDERESTIMATE OF EIGENVECTOR */
9594	/* SPACE REQUIRED .......... */
9595	L1000:
9596	if (*ierr != 0) {
9597	ierr -= n;
9598	}
9599	if (*ierr == 0) {
9600	ierr = -((n << 1) + 1);
9601	}
9602	L1001:
9603	*m = s - 1 - abs(ip);
9604	return 0;
9605	} /* invit_ */
9606
9607	/* Subroutine / int minfit_(integer nm, integer m, integer n, doublereal *
9608	a, doublereal w, integer ip, doublereal b, integer ierr,
9609	doublereal *rv1)
9610	{
9611	/* System generated locals */
9612	integer a_dim1, a_offset, b_dim1, b_offset, i_1, i_2, i_3;
9613	doublereal d_1, d_2, d_3, d_4;
9614
9615	/* Builtin functions */
9616	double sqrt(doublereal), d_sign(doublereal , doublereal );
9617
9618	/* Local variables */
9619	static doublereal c, f, g, h;
9620	static integer i, j, k, l;
9621	static doublereal s, x, y, z, scale;
9622	static integer i1, k1, l1, m1, ii, kk, ll;
9623	extern doublereal pythag_(doublereal , doublereal );
9624	static integer its;
9625	static doublereal tst1, tst2;
9626
9627
9628
9629	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE MINFIT, */
9630	/* NUM. MATH. 14, 403-420(1970) BY GOLUB AND REINSCH. */
9631	/* HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 134-151(1971). */
9632
9633	/* THIS SUBROUTINE DETERMINES, TOWARDS THE SOLUTION OF THE LINEAR */
9634	/* T */
9635	/* SYSTEM AX=B, THE SINGULAR VALUE DECOMPOSITION A=USV OF A REAL */
9636	/* T */
9637	/* M BY N RECTANGULAR MATRIX, FORMING U B RATHER THAN U. HOUSEHOLDER
9638	*/
9639	/* BIDIAGONALIZATION AND A VARIANT OF THE QR ALGORITHM ARE USED. */
9640
9641	/* ON INPUT */
9642
9643	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
9644	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
9645	/* DIMENSION STATEMENT. NOTE THAT NM MUST BE AT LEAST */
9646	/* AS LARGE AS THE MAXIMUM OF M AND N. */
9647
9648	/* M IS THE NUMBER OF ROWS OF A AND B. */
9649
9650	/* N IS THE NUMBER OF COLUMNS OF A AND THE ORDER OF V. */
9651
9652	/* A CONTAINS THE RECTANGULAR COEFFICIENT MATRIX OF THE SYSTEM. */
9653
9654	/* IP IS THE NUMBER OF COLUMNS OF B. IP CAN BE ZERO. */
9655
9656	/* B CONTAINS THE CONSTANT COLUMN MATRIX OF THE SYSTEM */
9657	/* IF IP IS NOT ZERO. OTHERWISE B IS NOT REFERENCED. */
9658
9659	/* ON OUTPUT */
9660
9661	/* A HAS BEEN OVERWRITTEN BY THE MATRIX V (ORTHOGONAL) OF THE */
9662	/* DECOMPOSITION IN ITS FIRST N ROWS AND COLUMNS. IF AN */
9663	/* ERROR EXIT IS MADE, THE COLUMNS OF V CORRESPONDING TO */
9664	/* INDICES OF CORRECT SINGULAR VALUES SHOULD BE CORRECT. */
9665
9666	/* W CONTAINS THE N (NON-NEGATIVE) SINGULAR VALUES OF A (THE */
9667	/* DIAGONAL ELEMENTS OF S). THEY ARE UNORDERED. IF AN */
9668	/* ERROR EXIT IS MADE, THE SINGULAR VALUES SHOULD BE CORRECT */
9669	/* FOR INDICES IERR+1,IERR+2,...,N. */
9670
9671	/* T */
9672	/* B HAS BEEN OVERWRITTEN BY U B. IF AN ERROR EXIT IS MADE, */
9673	/* T */
9674	/* THE ROWS OF U B CORRESPONDING TO INDICES OF CORRECT */
9675	/* SINGULAR VALUES SHOULD BE CORRECT. */
9676
9677	/* IERR IS SET TO */
9678	/* ZERO FOR NORMAL RETURN, */
9679	/* K IF THE K-TH SINGULAR VALUE HAS NOT BEEN */
9680	/* DETERMINED AFTER 30 ITERATIONS. */
9681
9682	/* RV1 IS A TEMPORARY STORAGE ARRAY. */
9683
9684	/* CALLS PYTHAG FOR DSQRT(AA + BB) . */
9685
9686	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
9687	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
9688	*/
9689
9690	/* THIS VERSION DATED AUGUST 1983. */
9691
9692	/* ------------------------------------------------------------------
9693	*/
9694
9695	/* Parameter adjustments */
9696	--rv1;
9697	--w;
9698	a_dim1 = *nm;
9699	a_offset = a_dim1 + 1;
9700	a -= a_offset;
9701	b_dim1 = *nm;
9702	b_offset = b_dim1 + 1;
9703	b -= b_offset;
9704
9705	/* Function Body */
9706	*ierr = 0;
9707	/* .......... HOUSEHOLDER REDUCTION TO BIDIAGONAL FORM .......... */
9708	g = 0.;
9709	scale = 0.;
9710	x = 0.;
9711
9712	i_1 = *n;
9713	for (i = 1; i <= i_1; ++i) {
9714	l = i + 1;
9715	rv1[i] = scale * g;
9716	g = 0.;
9717	s = 0.;
9718	scale = 0.;
9719	if (i > *m) {
9720	goto L210;
9721	}
9722
9723	i_2 = *m;
9724	for (k = i; k <= i_2; ++k) {
9725	/* L120: */
9726	scale += (d_1 = a[k + i * a_dim1], abs(d_1));
9727	}
9728
9729	if (scale == 0.) {
9730	goto L210;
9731	}
9732
9733	i_2 = *m;
9734	for (k = i; k <= i_2; ++k) {
9735	a[k + i * a_dim1] /= scale;
9736	/* Computing 2nd power */
9737	d_1 = a[k + i * a_dim1];
9738	s += d_1 * d_1;
9739	/* L130: */
9740	}
9741
9742	f = a[i + i * a_dim1];
9743	d_1 = sqrt(s);
9744	g = -d_sign(&d_1, &f);
9745	h = f * g - s;
9746	a[i + i * a_dim1] = f - g;
9747	if (i == *n) {
9748	goto L160;
9749	}
9750
9751	i_2 = *n;
9752	for (j = l; j <= i_2; ++j) {
9753	s = 0.;
9754
9755	i_3 = *m;
9756	for (k = i; k <= i_3; ++k) {
9757	/* L140: */
9758	s += a[k + i * a_dim1] * a[k + j * a_dim1];
9759	}
9760
9761	f = s / h;
9762
9763	i_3 = *m;
9764	for (k = i; k <= i_3; ++k) {
9765	a[k + j * a_dim1] += f * a[k + i * a_dim1];
9766	/* L150: */
9767	}
9768	}
9769
9770	L160:
9771	if (*ip == 0) {
9772	goto L190;
9773	}
9774
9775	i_3 = *ip;
9776	for (j = 1; j <= i_3; ++j) {
9777	s = 0.;
9778
9779	i_2 = *m;
9780	for (k = i; k <= i_2; ++k) {
9781	/* L170: */
9782	s += a[k + i * a_dim1] * b[k + j * b_dim1];
9783	}
9784
9785	f = s / h;
9786
9787	i_2 = *m;
9788	for (k = i; k <= i_2; ++k) {
9789	b[k + j * b_dim1] += f * a[k + i * a_dim1];
9790	/* L180: */
9791	}
9792	}
9793
9794	L190:
9795	i_2 = *m;
9796	for (k = i; k <= i_2; ++k) {
9797	/* L200: */
9798	a[k + i * a_dim1] = scale * a[k + i * a_dim1];
9799	}
9800
9801	L210:
9802	w[i] = scale * g;
9803	g = 0.;
9804	s = 0.;
9805	scale = 0.;
9806	if (i > m \|\| i == n) {
9807	goto L290;
9808	}
9809
9810	i_2 = *n;
9811	for (k = l; k <= i_2; ++k) {
9812	/* L220: */
9813	scale += (d_1 = a[i + k * a_dim1], abs(d_1));
9814	}
9815
9816	if (scale == 0.) {
9817	goto L290;
9818	}
9819
9820	i_2 = *n;
9821	for (k = l; k <= i_2; ++k) {
9822	a[i + k * a_dim1] /= scale;
9823	/* Computing 2nd power */
9824	d_1 = a[i + k * a_dim1];
9825	s += d_1 * d_1;
9826	/* L230: */
9827	}
9828
9829	f = a[i + l * a_dim1];
9830	d_1 = sqrt(s);
9831	g = -d_sign(&d_1, &f);
9832	h = f * g - s;
9833	a[i + l * a_dim1] = f - g;
9834
9835	i_2 = *n;
9836	for (k = l; k <= i_2; ++k) {
9837	/* L240: */
9838	rv1[k] = a[i + k * a_dim1] / h;
9839	}
9840
9841	if (i == *m) {
9842	goto L270;
9843	}
9844
9845	i_2 = *m;
9846	for (j = l; j <= i_2; ++j) {
9847	s = 0.;
9848
9849	i_3 = *n;
9850	for (k = l; k <= i_3; ++k) {
9851	/* L250: */
9852	s += a[j + k * a_dim1] * a[i + k * a_dim1];
9853	}
9854
9855	i_3 = *n;
9856	for (k = l; k <= i_3; ++k) {
9857	a[j + k * a_dim1] += s * rv1[k];
9858	/* L260: */
9859	}
9860	}
9861
9862	L270:
9863	i_3 = *n;
9864	for (k = l; k <= i_3; ++k) {
9865	/* L280: */
9866	a[i + k * a_dim1] = scale * a[i + k * a_dim1];
9867	}
9868
9869	L290:
9870	/* Computing MAX */
9871	d_3 = x, d_4 = (d_1 = w[i], abs(d_1)) + (d_2 = rv1[i], abs(d_2))
9872	;
9873	x = max(d_3,d_4);
9874	/* L300: */
9875	}
9876	/* .......... ACCUMULATION OF RIGHT-HAND TRANSFORMATIONS. */
9877	/* FOR I=N STEP -1 UNTIL 1 DO -- .......... */
9878	i_1 = *n;
9879	for (ii = 1; ii <= i_1; ++ii) {
9880	i = *n + 1 - ii;
9881	if (i == *n) {
9882	goto L390;
9883	}
9884	if (g == 0.) {
9885	goto L360;
9886	}
9887
9888	i_3 = *n;
9889	for (j = l; j <= i_3; ++j) {
9890	/* .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ......
9891	.... */
9892	/* L320: */
9893	a[j + i * a_dim1] = a[i + j * a_dim1] / a[i + l * a_dim1] / g;
9894	}
9895
9896	i_3 = *n;
9897	for (j = l; j <= i_3; ++j) {
9898	s = 0.;
9899
9900	i_2 = *n;
9901	for (k = l; k <= i_2; ++k) {
9902	/* L340: */
9903	s += a[i + k * a_dim1] * a[k + j * a_dim1];
9904	}
9905
9906	i_2 = *n;
9907	for (k = l; k <= i_2; ++k) {
9908	a[k + j * a_dim1] += s * a[k + i * a_dim1];
9909	/* L350: */
9910	}
9911	}
9912
9913	L360:
9914	i_2 = *n;
9915	for (j = l; j <= i_2; ++j) {
9916	a[i + j * a_dim1] = 0.;
9917	a[j + i * a_dim1] = 0.;
9918	/* L380: */
9919	}
9920
9921	L390:
9922	a[i + i * a_dim1] = 1.;
9923	g = rv1[i];
9924	l = i;
9925	/* L400: */
9926	}
9927
9928	if (m >= n \|\| *ip == 0) {
9929	goto L510;
9930	}
9931	m1 = *m + 1;
9932
9933	i_1 = *n;
9934	for (i = m1; i <= i_1; ++i) {
9935
9936	i_2 = *ip;
9937	for (j = 1; j <= i_2; ++j) {
9938	b[i + j * b_dim1] = 0.;
9939	/* L500: */
9940	}
9941	}
9942	/* .......... DIAGONALIZATION OF THE BIDIAGONAL FORM .......... */
9943	L510:
9944	tst1 = x;
9945	/* .......... FOR K=N STEP -1 UNTIL 1 DO -- .......... */
9946	i_2 = *n;
9947	for (kk = 1; kk <= i_2; ++kk) {
9948	k1 = *n - kk;
9949	k = k1 + 1;
9950	its = 0;
9951	/* .......... TEST FOR SPLITTING. */
9952	/* FOR L=K STEP -1 UNTIL 1 DO -- .......... */
9953	L520:
9954	i_1 = k;
9955	for (ll = 1; ll <= i_1; ++ll) {
9956	l1 = k - ll;
9957	l = l1 + 1;
9958	tst2 = tst1 + (d_1 = rv1[l], abs(d_1));
9959	if (tst2 == tst1) {
9960	goto L565;
9961	}
9962	/* .......... RV1(1) IS ALWAYS ZERO, SO THERE IS NO EXIT */
9963	/* THROUGH THE BOTTOM OF THE LOOP .......... */
9964	tst2 = tst1 + (d_1 = w[l1], abs(d_1));
9965	if (tst2 == tst1) {
9966	goto L540;
9967	}
9968	/* L530: */
9969	}
9970	/* .......... CANCELLATION OF RV1(L) IF L GREATER THAN 1 .........
9971	. */
9972	L540:
9973	c = 0.;
9974	s = 1.;
9975
9976	i_1 = k;
9977	for (i = l; i <= i_1; ++i) {
9978	f = s * rv1[i];
9979	rv1[i] = c * rv1[i];
9980	tst2 = tst1 + abs(f);
9981	if (tst2 == tst1) {
9982	goto L565;
9983	}
9984	g = w[i];
9985	h = pythag_(&f, &g);
9986	w[i] = h;
9987	c = g / h;
9988	s = -f / h;
9989	if (*ip == 0) {
9990	goto L560;
9991	}
9992
9993	i_3 = *ip;
9994	for (j = 1; j <= i_3; ++j) {
9995	y = b[l1 + j * b_dim1];
9996	z = b[i + j * b_dim1];
9997	b[l1 + j * b_dim1] = y * c + z * s;
9998	b[i + j * b_dim1] = -y * s + z * c;
9999	/* L550: */
10000	}
10001
10002	L560:
10003	;
10004	}
10005	/* .......... TEST FOR CONVERGENCE .......... */
10006	L565:
10007	z = w[k];
10008	if (l == k) {
10009	goto L650;
10010	}
10011	/* .......... SHIFT FROM BOTTOM 2 BY 2 MINOR .......... */
10012	if (its == 30) {
10013	goto L1000;
10014	}
10015	++its;
10016	x = w[l];
10017	y = w[k1];
10018	g = rv1[k1];
10019	h = rv1[k];
10020	f = ((g + z) / h * ((g - z) / y) + y / h - h / y) * .5;
10021	g = pythag_(&f, &c_b141);
10022	f = x - z / x * z + h / x * (y / (f + d_sign(&g, &f)) - h);
10023	/* .......... NEXT QR TRANSFORMATION .......... */
10024	c = 1.;
10025	s = 1.;
10026
10027	i_1 = k1;
10028	for (i1 = l; i1 <= i_1; ++i1) {
10029	i = i1 + 1;
10030	g = rv1[i];
10031	y = w[i];
10032	h = s * g;
10033	g = c * g;
10034	z = pythag_(&f, &h);
10035	rv1[i1] = z;
10036	c = f / z;
10037	s = h / z;
10038	f = x * c + g * s;
10039	g = -x * s + g * c;
10040	h = y * s;
10041	y *= c;
10042
10043	i_3 = *n;
10044	for (j = 1; j <= i_3; ++j) {
10045	x = a[j + i1 * a_dim1];
10046	z = a[j + i * a_dim1];
10047	a[j + i1 * a_dim1] = x * c + z * s;
10048	a[j + i * a_dim1] = -x * s + z * c;
10049	/* L570: */
10050	}
10051
10052	z = pythag_(&f, &h);
10053	w[i1] = z;
10054	/* .......... ROTATION CAN BE ARBITRARY IF Z IS ZERO .........
10055	. */
10056	if (z == 0.) {
10057	goto L580;
10058	}
10059	c = f / z;
10060	s = h / z;
10061	L580:
10062	f = c * g + s * y;
10063	x = -s * g + c * y;
10064	if (*ip == 0) {
10065	goto L600;
10066	}
10067
10068	i_3 = *ip;
10069	for (j = 1; j <= i_3; ++j) {
10070	y = b[i1 + j * b_dim1];
10071	z = b[i + j * b_dim1];
10072	b[i1 + j * b_dim1] = y * c + z * s;
10073	b[i + j * b_dim1] = -y * s + z * c;
10074	/* L590: */
10075	}
10076
10077	L600:
10078	;
10079	}
10080
10081	rv1[l] = 0.;
10082	rv1[k] = f;
10083	w[k] = x;
10084	goto L520;
10085	/* .......... CONVERGENCE .......... */
10086	L650:
10087	if (z >= 0.) {
10088	goto L700;
10089	}
10090	/* .......... W(K) IS MADE NON-NEGATIVE .......... */
10091	w[k] = -z;
10092
10093	i_1 = *n;
10094	for (j = 1; j <= i_1; ++j) {
10095	/* L690: */
10096	a[j + k * a_dim1] = -a[j + k * a_dim1];
10097	}
10098
10099	L700:
10100	;
10101	}
10102
10103	goto L1001;
10104	/* .......... SET ERROR -- NO CONVERGENCE TO A */
10105	/* SINGULAR VALUE AFTER 30 ITERATIONS .......... */
10106	L1000:
10107	*ierr = k;
10108	L1001:
10109	return 0;
10110	} /* minfit_ */
10111
10112	/* Subroutine / int ortbak_(integer nm, integer low, integer igh,
10113	doublereal a, doublereal ort, integer m, doublereal z)
10114	{
10115	/* System generated locals */
10116	integer a_dim1, a_offset, z_dim1, z_offset, i_1, i_2, i_3;
10117
10118	/* Local variables */
10119	static doublereal g;
10120	static integer i, j, la, mm, mp, kp1, mp1;
10121
10122
10123
10124	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTBAK, */
10125	/* NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. */
10126	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). */
10127
10128	/* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL GENERAL */
10129	/* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */
10130	/* UPPER HESSENBERG MATRIX DETERMINED BY ORTHES. */
10131
10132	/* ON INPUT */
10133
10134	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
10135	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
10136	/* DIMENSION STATEMENT. */
10137
10138	/* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
10139	/* SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, */
10140	/* SET LOW=1 AND IGH EQUAL TO THE ORDER OF THE MATRIX. */
10141
10142	/* A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- */
10143	/* FORMATIONS USED IN THE REDUCTION BY ORTHES */
10144	/* IN ITS STRICT LOWER TRIANGLE. */
10145
10146	/* ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANS- */
10147	/* FORMATIONS USED IN THE REDUCTION BY ORTHES. */
10148	/* ONLY ELEMENTS LOW THROUGH IGH ARE USED. */
10149
10150	/* M IS THE NUMBER OF COLUMNS OF Z TO BE BACK TRANSFORMED. */
10151
10152	/* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGEN- */
10153	/* VECTORS TO BE BACK TRANSFORMED IN ITS FIRST M COLUMNS. */
10154
10155	/* ON OUTPUT */
10156
10157	/* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE */
10158	/* TRANSFORMED EIGENVECTORS IN ITS FIRST M COLUMNS. */
10159
10160	/* ORT HAS BEEN ALTERED. */
10161
10162	/* NOTE THAT ORTBAK PRESERVES VECTOR EUCLIDEAN NORMS. */
10163
10164	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
10165	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
10166	*/
10167
10168	/* THIS VERSION DATED AUGUST 1983. */
10169
10170	/* ------------------------------------------------------------------
10171	*/
10172
10173	/* Parameter adjustments */
10174	--ort;
10175	a_dim1 = *nm;
10176	a_offset = a_dim1 + 1;
10177	a -= a_offset;
10178	z_dim1 = *nm;
10179	z_offset = z_dim1 + 1;
10180	z -= z_offset;
10181
10182	/* Function Body */
10183	if (*m == 0) {
10184	goto L200;
10185	}
10186	la = *igh - 1;
10187	kp1 = *low + 1;
10188	if (la < kp1) {
10189	goto L200;
10190	}
10191	/* .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... */
10192	i_1 = la;
10193	for (mm = kp1; mm <= i_1; ++mm) {
10194	mp = low + igh - mm;
10195	if (a[mp + (mp - 1) * a_dim1] == 0.) {
10196	goto L140;
10197	}
10198	mp1 = mp + 1;
10199
10200	i_2 = *igh;
10201	for (i = mp1; i <= i_2; ++i) {
10202	/* L100: */
10203	ort[i] = a[i + (mp - 1) * a_dim1];
10204	}
10205
10206	i_2 = *m;
10207	for (j = 1; j <= i_2; ++j) {
10208	g = 0.;
10209
10210	i_3 = *igh;
10211	for (i = mp; i <= i_3; ++i) {
10212	/* L110: */
10213	g += ort[i] * z[i + j * z_dim1];
10214	}
10215	/* .......... DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHES.
10216	*/
10217	/* DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ......
10218	.... */
10219	g = g / ort[mp] / a[mp + (mp - 1) * a_dim1];
10220
10221	i_3 = *igh;
10222	for (i = mp; i <= i_3; ++i) {
10223	/* L120: */
10224	z[i + j * z_dim1] += g * ort[i];
10225	}
10226
10227	/* L130: */
10228	}
10229
10230	L140:
10231	;
10232	}
10233
10234	L200:
10235	return 0;
10236	} /* ortbak_ */
10237
10238	/* Subroutine / int orthes_(integer nm, integer n, integer low, integer *
10239	igh, doublereal a, doublereal ort)
10240	{
10241	/* System generated locals */
10242	integer a_dim1, a_offset, i_1, i_2, i_3;
10243	doublereal d_1;
10244
10245	/* Builtin functions */
10246	double sqrt(doublereal), d_sign(doublereal , doublereal );
10247
10248	/* Local variables */
10249	static doublereal f, g, h;
10250	static integer i, j, m;
10251	static doublereal scale;
10252	static integer la, ii, jj, mp, kp1;
10253
10254
10255
10256	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTHES, */
10257	/* NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. */
10258	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). */
10259
10260	/* GIVEN A REAL GENERAL MATRIX, THIS SUBROUTINE */
10261	/* REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS */
10262	/* LOW THROUGH IGH TO UPPER HESSENBERG FORM BY */
10263	/* ORTHOGONAL SIMILARITY TRANSFORMATIONS. */
10264
10265	/* ON INPUT */
10266
10267	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
10268	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
10269	/* DIMENSION STATEMENT. */
10270
10271	/* N IS THE ORDER OF THE MATRIX. */
10272
10273	/* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
10274	/* SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, */
10275	/* SET LOW=1, IGH=N. */
10276
10277	/* A CONTAINS THE INPUT MATRIX. */
10278
10279	/* ON OUTPUT */
10280
10281	/* A CONTAINS THE HESSENBERG MATRIX. INFORMATION ABOUT */
10282	/* THE ORTHOGONAL TRANSFORMATIONS USED IN THE REDUCTION */
10283	/* IS STORED IN THE REMAINING TRIANGLE UNDER THE */
10284	/* HESSENBERG MATRIX. */
10285
10286	/* ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. */
10287	/* ONLY ELEMENTS LOW THROUGH IGH ARE USED. */
10288
10289	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
10290	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
10291	*/
10292
10293	/* THIS VERSION DATED AUGUST 1983. */
10294
10295	/* ------------------------------------------------------------------
10296	*/
10297
10298	/* Parameter adjustments */
10299	a_dim1 = *nm;
10300	a_offset = a_dim1 + 1;
10301	a -= a_offset;
10302	--ort;
10303
10304	/* Function Body */
10305	la = *igh - 1;
10306	kp1 = *low + 1;
10307	if (la < kp1) {
10308	goto L200;
10309	}
10310
10311	i_1 = la;
10312	for (m = kp1; m <= i_1; ++m) {
10313	h = 0.;
10314	ort[m] = 0.;
10315	scale = 0.;
10316	/* .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
10317	*/
10318	i_2 = *igh;
10319	for (i = m; i <= i_2; ++i) {
10320	/* L90: */
10321	scale += (d_1 = a[i + (m - 1) * a_dim1], abs(d_1));
10322	}
10323
10324	if (scale == 0.) {
10325	goto L180;
10326	}
10327	mp = m + *igh;
10328	/* .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... */
10329	i_2 = *igh;
10330	for (ii = m; ii <= i_2; ++ii) {
10331	i = mp - ii;
10332	ort[i] = a[i + (m - 1) * a_dim1] / scale;
10333	h += ort[i] * ort[i];
10334	/* L100: */
10335	}
10336
10337	d_1 = sqrt(h);
10338	g = -d_sign(&d_1, &ort[m]);
10339	h -= ort[m] * g;
10340	ort[m] -= g;
10341	/* .......... FORM (I-(UUT)/H) A .......... */
10342	i_2 = *n;
10343	for (j = m; j <= i_2; ++j) {
10344	f = 0.;
10345	/* .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... */
10346	i_3 = *igh;
10347	for (ii = m; ii <= i_3; ++ii) {
10348	i = mp - ii;
10349	f += ort[i] * a[i + j * a_dim1];
10350	/* L110: */
10351	}
10352
10353	f /= h;
10354
10355	i_3 = *igh;
10356	for (i = m; i <= i_3; ++i) {
10357	/* L120: */
10358	a[i + j * a_dim1] -= f * ort[i];
10359	}
10360
10361	/* L130: */
10362	}
10363	/* .......... FORM (I-(UUT)/H)A(I-(UUT)/H) .......... */
10364	i_2 = *igh;
10365	for (i = 1; i <= i_2; ++i) {
10366	f = 0.;
10367	/* .......... FOR J=IGH STEP -1 UNTIL M DO -- .......... */
10368	i_3 = *igh;
10369	for (jj = m; jj <= i_3; ++jj) {
10370	j = mp - jj;
10371	f += ort[j] * a[i + j * a_dim1];
10372	/* L140: */
10373	}
10374
10375	f /= h;
10376
10377	i_3 = *igh;
10378	for (j = m; j <= i_3; ++j) {
10379	/* L150: */
10380	a[i + j * a_dim1] -= f * ort[j];
10381	}
10382
10383	/* L160: */
10384	}
10385
10386	ort[m] = scale * ort[m];
10387	a[m + (m - 1) * a_dim1] = scale * g;
10388	L180:
10389	;
10390	}
10391
10392	L200:
10393	return 0;
10394	} /* orthes_ */
10395
10396	/* Subroutine / int ortran_(integer nm, integer n, integer low, integer *
10397	igh, doublereal a, doublereal ort, doublereal *z)
10398	{
10399	/* System generated locals */
10400	integer a_dim1, a_offset, z_dim1, z_offset, i_1, i_2, i_3;
10401
10402	/* Local variables */
10403	static doublereal g;
10404	static integer i, j, kl, mm, mp, mp1;
10405
10406
10407
10408	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTRANS, */
10409	/* NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. */
10410	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). */
10411
10412	/* THIS SUBROUTINE ACCUMULATES THE ORTHOGONAL SIMILARITY */
10413	/* TRANSFORMATIONS USED IN THE REDUCTION OF A REAL GENERAL */
10414	/* MATRIX TO UPPER HESSENBERG FORM BY ORTHES. */
10415
10416	/* ON INPUT */
10417
10418	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
10419	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
10420	/* DIMENSION STATEMENT. */
10421
10422	/* N IS THE ORDER OF THE MATRIX. */
10423
10424	/* LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING */
10425	/* SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, */
10426	/* SET LOW=1, IGH=N. */
10427
10428	/* A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- */
10429	/* FORMATIONS USED IN THE REDUCTION BY ORTHES */
10430	/* IN ITS STRICT LOWER TRIANGLE. */
10431
10432	/* ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANS- */
10433	/* FORMATIONS USED IN THE REDUCTION BY ORTHES. */
10434	/* ONLY ELEMENTS LOW THROUGH IGH ARE USED. */
10435
10436	/* ON OUTPUT */
10437
10438	/* Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE */
10439	/* REDUCTION BY ORTHES. */
10440
10441	/* ORT HAS BEEN ALTERED. */
10442
10443	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
10444	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
10445	*/
10446
10447	/* THIS VERSION DATED AUGUST 1983. */
10448
10449	/* ------------------------------------------------------------------
10450	*/
10451
10452	/* .......... INITIALIZE Z TO IDENTITY MATRIX .......... */
10453	/* Parameter adjustments */
10454	z_dim1 = *nm;
10455	z_offset = z_dim1 + 1;
10456	z -= z_offset;
10457	--ort;
10458	a_dim1 = *nm;
10459	a_offset = a_dim1 + 1;
10460	a -= a_offset;
10461
10462	/* Function Body */
10463	i_1 = *n;
10464	for (j = 1; j <= i_1; ++j) {
10465
10466	i_2 = *n;
10467	for (i = 1; i <= i_2; ++i) {
10468	/* L60: */
10469	z[i + j * z_dim1] = 0.;
10470	}
10471
10472	z[j + j * z_dim1] = 1.;
10473	/* L80: */
10474	}
10475
10476	kl = igh - low - 1;
10477	if (kl < 1) {
10478	goto L200;
10479	}
10480	/* .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... */
10481	i_1 = kl;
10482	for (mm = 1; mm <= i_1; ++mm) {
10483	mp = *igh - mm;
10484	if (a[mp + (mp - 1) * a_dim1] == 0.) {
10485	goto L140;
10486	}
10487	mp1 = mp + 1;
10488
10489	i_2 = *igh;
10490	for (i = mp1; i <= i_2; ++i) {
10491	/* L100: */
10492	ort[i] = a[i + (mp - 1) * a_dim1];
10493	}
10494
10495	i_2 = *igh;
10496	for (j = mp; j <= i_2; ++j) {
10497	g = 0.;
10498
10499	i_3 = *igh;
10500	for (i = mp; i <= i_3; ++i) {
10501	/* L110: */
10502	g += ort[i] * z[i + j * z_dim1];
10503	}
10504	/* .......... DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHES.
10505	*/
10506	/* DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ......
10507	.... */
10508	g = g / ort[mp] / a[mp + (mp - 1) * a_dim1];
10509
10510	i_3 = *igh;
10511	for (i = mp; i <= i_3; ++i) {
10512	/* L120: */
10513	z[i + j * z_dim1] += g * ort[i];
10514	}
10515
10516	/* L130: */
10517	}
10518
10519	L140:
10520	;
10521	}
10522
10523	L200:
10524	return 0;
10525	} /* ortran_ */
10526
10527	/* Subroutine / int qzhes_(integer nm, integer n, doublereal a,
10528	doublereal b, logical matz, doublereal *z)
10529	{
10530	/* System generated locals */
10531	integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i_1, i_2,
10532	i_3;
10533	doublereal d_1, d_2;
10534
10535	/* Builtin functions */
10536	double sqrt(doublereal), d_sign(doublereal , doublereal );
10537
10538	/* Local variables */
10539	static integer i, j, k, l;
10540	static doublereal r, s, t;
10541	static integer l1;
10542	static doublereal u1, u2, v1, v2;
10543	static integer lb, nk1, nm1, nm2;
10544	static doublereal rho;
10545
10546
10547
10548	/* THIS SUBROUTINE IS THE FIRST STEP OF THE QZ ALGORITHM */
10549	/* FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS, */
10550	/* SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART. */
10551
10552	/* THIS SUBROUTINE ACCEPTS A PAIR OF REAL GENERAL MATRICES AND */
10553	/* REDUCES ONE OF THEM TO UPPER HESSENBERG FORM AND THE OTHER */
10554	/* TO UPPER TRIANGULAR FORM USING ORTHOGONAL TRANSFORMATIONS. */
10555	/* IT IS USUALLY FOLLOWED BY QZIT, QZVAL AND, POSSIBLY, QZVEC. */
10556
10557	/* ON INPUT */
10558
10559	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
10560	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
10561	/* DIMENSION STATEMENT. */
10562
10563	/* N IS THE ORDER OF THE MATRICES. */
10564
10565	/* A CONTAINS A REAL GENERAL MATRIX. */
10566
10567	/* B CONTAINS A REAL GENERAL MATRIX. */
10568
10569	/* MATZ SHOULD BE SET TO .TRUE. IF THE RIGHT HAND TRANSFORMATIONS
10570	*/
10571	/* ARE TO BE ACCUMULATED FOR LATER USE IN COMPUTING */
10572	/* EIGENVECTORS, AND TO .FALSE. OTHERWISE. */
10573
10574	/* ON OUTPUT */
10575
10576	/* A HAS BEEN REDUCED TO UPPER HESSENBERG FORM. THE ELEMENTS */
10577	/* BELOW THE FIRST SUBDIAGONAL HAVE BEEN SET TO ZERO. */
10578
10579	/* B HAS BEEN REDUCED TO UPPER TRIANGULAR FORM. THE ELEMENTS */
10580	/* BELOW THE MAIN DIAGONAL HAVE BEEN SET TO ZERO. */
10581
10582	/* Z CONTAINS THE PRODUCT OF THE RIGHT HAND TRANSFORMATIONS IF */
10583	/* MATZ HAS BEEN SET TO .TRUE. OTHERWISE, Z IS NOT REFERENCED.
10584	*/
10585
10586	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
10587	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
10588	*/
10589
10590	/* THIS VERSION DATED AUGUST 1983. */
10591
10592	/* ------------------------------------------------------------------
10593	*/
10594
10595	/* .......... INITIALIZE Z .......... */
10596	/* Parameter adjustments */
10597	z_dim1 = *nm;
10598	z_offset = z_dim1 + 1;
10599	z -= z_offset;
10600	b_dim1 = *nm;
10601	b_offset = b_dim1 + 1;
10602	b -= b_offset;
10603	a_dim1 = *nm;
10604	a_offset = a_dim1 + 1;
10605	a -= a_offset;
10606
10607	/* Function Body */
10608	if (! (*matz)) {
10609	goto L10;
10610	}
10611
10612	i_1 = *n;
10613	for (j = 1; j <= i_1; ++j) {
10614
10615	i_2 = *n;
10616	for (i = 1; i <= i_2; ++i) {
10617	z[i + j * z_dim1] = 0.;
10618	/* L2: */
10619	}
10620
10621	z[j + j * z_dim1] = 1.;
10622	/* L3: */
10623	}
10624	/* .......... REDUCE B TO UPPER TRIANGULAR FORM .......... */
10625	L10:
10626	if (*n <= 1) {
10627	goto L170;
10628	}
10629	nm1 = *n - 1;
10630
10631	i_1 = nm1;
10632	for (l = 1; l <= i_1; ++l) {
10633	l1 = l + 1;
10634	s = 0.;
10635
10636	i_2 = *n;
10637	for (i = l1; i <= i_2; ++i) {
10638	s += (d_1 = b[i + l * b_dim1], abs(d_1));
10639	/* L20: */
10640	}
10641
10642	if (s == 0.) {
10643	goto L100;
10644	}
10645	s += (d_1 = b[l + l * b_dim1], abs(d_1));
10646	r = 0.;
10647
10648	i_2 = *n;
10649	for (i = l; i <= i_2; ++i) {
10650	b[i + l * b_dim1] /= s;
10651	/* Computing 2nd power */
10652	d_1 = b[i + l * b_dim1];
10653	r += d_1 * d_1;
10654	/* L25: */
10655	}
10656
10657	d_1 = sqrt(r);
10658	r = d_sign(&d_1, &b[l + l * b_dim1]);
10659	b[l + l * b_dim1] += r;
10660	rho = r * b[l + l * b_dim1];
10661
10662	i_2 = *n;
10663	for (j = l1; j <= i_2; ++j) {
10664	t = 0.;
10665
10666	i_3 = *n;
10667	for (i = l; i <= i_3; ++i) {
10668	t += b[i + l * b_dim1] * b[i + j * b_dim1];
10669	/* L30: */
10670	}
10671
10672	t = -t / rho;
10673
10674	i_3 = *n;
10675	for (i = l; i <= i_3; ++i) {
10676	b[i + j * b_dim1] += t * b[i + l * b_dim1];
10677	/* L40: */
10678	}
10679
10680	/* L50: */
10681	}
10682
10683	i_2 = *n;
10684	for (j = 1; j <= i_2; ++j) {
10685	t = 0.;
10686
10687	i_3 = *n;
10688	for (i = l; i <= i_3; ++i) {
10689	t += b[i + l * b_dim1] * a[i + j * a_dim1];
10690	/* L60: */
10691	}
10692
10693	t = -t / rho;
10694
10695	i_3 = *n;
10696	for (i = l; i <= i_3; ++i) {
10697	a[i + j * a_dim1] += t * b[i + l * b_dim1];
10698	/* L70: */
10699	}
10700
10701	/* L80: */
10702	}
10703
10704	b[l + l * b_dim1] = -s * r;
10705
10706	i_2 = *n;
10707	for (i = l1; i <= i_2; ++i) {
10708	b[i + l * b_dim1] = 0.;
10709	/* L90: */
10710	}
10711
10712	L100:
10713	;
10714	}
10715	/* .......... REDUCE A TO UPPER HESSENBERG FORM, WHILE */
10716	/* KEEPING B TRIANGULAR .......... */
10717	if (*n == 2) {
10718	goto L170;
10719	}
10720	nm2 = *n - 2;
10721
10722	i_1 = nm2;
10723	for (k = 1; k <= i_1; ++k) {
10724	nk1 = nm1 - k;
10725	/* .......... FOR L=N-1 STEP -1 UNTIL K+1 DO -- .......... */
10726	i_2 = nk1;
10727	for (lb = 1; lb <= i_2; ++lb) {
10728	l = *n - lb;
10729	l1 = l + 1;
10730	/* .......... ZERO A(L+1,K) .......... */
10731	s = (d_1 = a[l + k * a_dim1], abs(d_1)) + (d_2 = a[l1 + k *
10732	a_dim1], abs(d_2));
10733	if (s == 0.) {
10734	goto L150;
10735	}
10736	u1 = a[l + k * a_dim1] / s;
10737	u2 = a[l1 + k * a_dim1] / s;
10738	d_1 = sqrt(u1 * u1 + u2 * u2);
10739	r = d_sign(&d_1, &u1);
10740	v1 = -(u1 + r) / r;
10741	v2 = -u2 / r;
10742	u2 = v2 / v1;
10743
10744	i_3 = *n;
10745	for (j = k; j <= i_3; ++j) {
10746	t = a[l + j * a_dim1] + u2 * a[l1 + j * a_dim1];
10747	a[l + j * a_dim1] += t * v1;
10748	a[l1 + j * a_dim1] += t * v2;
10749	/* L110: */
10750	}
10751
10752	a[l1 + k * a_dim1] = 0.;
10753
10754	i_3 = *n;
10755	for (j = l; j <= i_3; ++j) {
10756	t = b[l + j * b_dim1] + u2 * b[l1 + j * b_dim1];
10757	b[l + j * b_dim1] += t * v1;
10758	b[l1 + j * b_dim1] += t * v2;
10759	/* L120: */
10760	}
10761	/* .......... ZERO B(L+1,L) .......... */
10762	s = (d_1 = b[l1 + l1 * b_dim1], abs(d_1)) + (d_2 = b[l1 + l *
10763	b_dim1], abs(d_2));
10764	if (s == 0.) {
10765	goto L150;
10766	}
10767	u1 = b[l1 + l1 * b_dim1] / s;
10768	u2 = b[l1 + l * b_dim1] / s;
10769	d_1 = sqrt(u1 * u1 + u2 * u2);
10770	r = d_sign(&d_1, &u1);
10771	v1 = -(u1 + r) / r;
10772	v2 = -u2 / r;
10773	u2 = v2 / v1;
10774
10775	i_3 = l1;
10776	for (i = 1; i <= i_3; ++i) {
10777	t = b[i + l1 * b_dim1] + u2 * b[i + l * b_dim1];
10778	b[i + l1 * b_dim1] += t * v1;
10779	b[i + l * b_dim1] += t * v2;
10780	/* L130: */
10781	}
10782
10783	b[l1 + l * b_dim1] = 0.;
10784
10785	i_3 = *n;
10786	for (i = 1; i <= i_3; ++i) {
10787	t = a[i + l1 * a_dim1] + u2 * a[i + l * a_dim1];
10788	a[i + l1 * a_dim1] += t * v1;
10789	a[i + l * a_dim1] += t * v2;
10790	/* L140: */
10791	}
10792
10793	if (! (*matz)) {
10794	goto L150;
10795	}
10796
10797	i_3 = *n;
10798	for (i = 1; i <= i_3; ++i) {
10799	t = z[i + l1 * z_dim1] + u2 * z[i + l * z_dim1];
10800	z[i + l1 * z_dim1] += t * v1;
10801	z[i + l * z_dim1] += t * v2;
10802	/* L145: */
10803	}
10804
10805	L150:
10806	;
10807	}
10808
10809	/* L160: */
10810	}
10811
10812	L170:
10813	return 0;
10814	} /* qzhes_ */
10815
10816	/* Subroutine / int qzit_(integer nm, integer n, doublereal a, doublereal
10817	b, doublereal eps1, logical matz, doublereal z, integer *ierr)
10818	{
10819	/* System generated locals */
10820	integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i_1, i_2,
10821	i_3;
10822	doublereal d_1, d_2, d_3;
10823
10824	/* Builtin functions */
10825	double sqrt(doublereal), d_sign(doublereal , doublereal );
10826
10827	/* Local variables */
10828	static doublereal epsa, epsb;
10829	static integer i, j, k, l;
10830	static doublereal r, s, t, anorm, bnorm;
10831	static integer enorn;
10832	static doublereal a1, a2, a3;
10833	static integer k1, k2, l1;
10834	static doublereal u1, u2, u3, v1, v2, v3, a11, a12, a21, a22, a33, a34,
10835	a43, a44, b11, b12, b22, b33;
10836	static integer na, ld;
10837	static doublereal b34, b44;
10838	static integer en;
10839	static doublereal ep;
10840	static integer ll;
10841	static doublereal sh;
10842	extern doublereal epslon_(doublereal *);
10843	static logical notlas;
10844	static integer km1, lm1;
10845	static doublereal ani, bni;
10846	static integer ish, itn, its, enm2, lor1;
10847
10848
10849
10850	/* THIS SUBROUTINE IS THE SECOND STEP OF THE QZ ALGORITHM */
10851	/* FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS, */
10852	/* SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART, */
10853	/* AS MODIFIED IN TECHNICAL NOTE NASA TN D-7305(1973) BY WARD. */
10854
10855	/* THIS SUBROUTINE ACCEPTS A PAIR OF REAL MATRICES, ONE OF THEM */
10856	/* IN UPPER HESSENBERG FORM AND THE OTHER IN UPPER TRIANGULAR FORM. */
10857	/* IT REDUCES THE HESSENBERG MATRIX TO QUASI-TRIANGULAR FORM USING */
10858	/* ORTHOGONAL TRANSFORMATIONS WHILE MAINTAINING THE TRIANGULAR FORM */
10859	/* OF THE OTHER MATRIX. IT IS USUALLY PRECEDED BY QZHES AND */
10860	/* FOLLOWED BY QZVAL AND, POSSIBLY, QZVEC. */
10861
10862	/* ON INPUT */
10863
10864	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
10865	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
10866	/* DIMENSION STATEMENT. */
10867
10868	/* N IS THE ORDER OF THE MATRICES. */
10869
10870	/* A CONTAINS A REAL UPPER HESSENBERG MATRIX. */
10871
10872	/* B CONTAINS A REAL UPPER TRIANGULAR MATRIX. */
10873
10874	/* EPS1 IS A TOLERANCE USED TO DETERMINE NEGLIGIBLE ELEMENTS. */
10875	/* EPS1 = 0.0 (OR NEGATIVE) MAY BE INPUT, IN WHICH CASE AN */
10876	/* ELEMENT WILL BE NEGLECTED ONLY IF IT IS LESS THAN ROUNDOFF */
10877	/* ERROR TIMES THE NORM OF ITS MATRIX. IF THE INPUT EPS1 IS */
10878	/* POSITIVE, THEN AN ELEMENT WILL BE CONSIDERED NEGLIGIBLE */
10879	/* IF IT IS LESS THAN EPS1 TIMES THE NORM OF ITS MATRIX. A */
10880	/* POSITIVE VALUE OF EPS1 MAY RESULT IN FASTER EXECUTION, */
10881	/* BUT LESS ACCURATE RESULTS. */
10882
10883	/* MATZ SHOULD BE SET TO .TRUE. IF THE RIGHT HAND TRANSFORMATIONS
10884	*/
10885	/* ARE TO BE ACCUMULATED FOR LATER USE IN COMPUTING */
10886	/* EIGENVECTORS, AND TO .FALSE. OTHERWISE. */
10887
10888	/* Z CONTAINS, IF MATZ HAS BEEN SET TO .TRUE., THE */
10889	/* TRANSFORMATION MATRIX PRODUCED IN THE REDUCTION */
10890	/* BY QZHES, IF PERFORMED, OR ELSE THE IDENTITY MATRIX. */
10891	/* IF MATZ HAS BEEN SET TO .FALSE., Z IS NOT REFERENCED. */
10892
10893	/* ON OUTPUT */
10894
10895	/* A HAS BEEN REDUCED TO QUASI-TRIANGULAR FORM. THE ELEMENTS */
10896	/* BELOW THE FIRST SUBDIAGONAL ARE STILL ZERO AND NO TWO */
10897	/* CONSECUTIVE SUBDIAGONAL ELEMENTS ARE NONZERO. */
10898
10899	/* B IS STILL IN UPPER TRIANGULAR FORM, ALTHOUGH ITS ELEMENTS */
10900	/* HAVE BEEN ALTERED. THE LOCATION B(N,1) IS USED TO STORE */
10901	/* EPS1 TIMES THE NORM OF B FOR LATER USE BY QZVAL AND QZVEC.
10902	*/
10903
10904	/* Z CONTAINS THE PRODUCT OF THE RIGHT HAND TRANSFORMATIONS */
10905	/* (FOR BOTH STEPS) IF MATZ HAS BEEN SET TO .TRUE.. */
10906
10907	/* IERR IS SET TO */
10908	/* ZERO FOR NORMAL RETURN, */
10909	/* J IF THE LIMIT OF 30N ITERATIONS IS EXHAUSTED /
10910	/* WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. */
10911
10912	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
10913	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
10914	*/
10915
10916	/* THIS VERSION DATED AUGUST 1983. */
10917
10918	/* ------------------------------------------------------------------
10919	*/
10920
10921	/* Parameter adjustments */
10922	z_dim1 = *nm;
10923	z_offset = z_dim1 + 1;
10924	z -= z_offset;
10925	b_dim1 = *nm;
10926	b_offset = b_dim1 + 1;
10927	b -= b_offset;
10928	a_dim1 = *nm;
10929	a_offset = a_dim1 + 1;
10930	a -= a_offset;
10931
10932	/* Function Body */
10933	*ierr = 0;
10934	/* .......... COMPUTE EPSA,EPSB .......... */
10935	anorm = 0.;
10936	bnorm = 0.;
10937
10938	i_1 = *n;
10939	for (i = 1; i <= i_1; ++i) {
10940	ani = 0.;
10941	if (i != 1) {
10942	ani = (d_1 = a[i + (i - 1) * a_dim1], abs(d_1));
10943	}
10944	bni = 0.;
10945
10946	i_2 = *n;
10947	for (j = i; j <= i_2; ++j) {
10948	ani += (d_1 = a[i + j * a_dim1], abs(d_1));
10949	bni += (d_1 = b[i + j * b_dim1], abs(d_1));
10950	/* L20: */
10951	}
10952
10953	if (ani > anorm) {
10954	anorm = ani;
10955	}
10956	if (bni > bnorm) {
10957	bnorm = bni;
10958	}
10959	/* L30: */
10960	}
10961
10962	if (anorm == 0.) {
10963	anorm = 1.;
10964	}
10965	if (bnorm == 0.) {
10966	bnorm = 1.;
10967	}
10968	ep = *eps1;
10969	if (ep > 0.) {
10970	goto L50;
10971	}
10972	/* .......... USE ROUNDOFF LEVEL IF EPS1 IS ZERO .......... */
10973	ep = epslon_(&c_b141);
10974	L50:
10975	epsa = ep * anorm;
10976	epsb = ep * bnorm;
10977	/* .......... REDUCE A TO QUASI-TRIANGULAR FORM, WHILE */
10978	/* KEEPING B TRIANGULAR .......... */
10979	lor1 = 1;
10980	enorn = *n;
10981	en = *n;
10982	itn = n 30;
10983	/* .......... BEGIN QZ STEP .......... */
10984	L60:
10985	if (en <= 2) {
10986	goto L1001;
10987	}
10988	if (! (*matz)) {
10989	enorn = en;
10990	}
10991	its = 0;
10992	na = en - 1;
10993	enm2 = na - 1;
10994	L70:
10995	ish = 2;
10996	/* .......... CHECK FOR CONVERGENCE OR REDUCIBILITY. */
10997	/* FOR L=EN STEP -1 UNTIL 1 DO -- .......... */
10998	i_1 = en;
10999	for (ll = 1; ll <= i_1; ++ll) {
11000	lm1 = en - ll;
11001	l = lm1 + 1;
11002	if (l == 1) {
11003	goto L95;
11004	}
11005	if ((d_1 = a[l + lm1 * a_dim1], abs(d_1)) <= epsa) {
11006	goto L90;
11007	}
11008	/* L80: */
11009	}
11010
11011	L90:
11012	a[l + lm1 * a_dim1] = 0.;
11013	if (l < na) {
11014	goto L95;
11015	}
11016	/* .......... 1-BY-1 OR 2-BY-2 BLOCK ISOLATED .......... */
11017	en = lm1;
11018	goto L60;
11019	/* .......... CHECK FOR SMALL TOP OF B .......... */
11020	L95:
11021	ld = l;
11022	L100:
11023	l1 = l + 1;
11024	b11 = b[l + l * b_dim1];
11025	if (abs(b11) > epsb) {
11026	goto L120;
11027	}
11028	b[l + l * b_dim1] = 0.;
11029	s = (d_1 = a[l + l * a_dim1], abs(d_1)) + (d_2 = a[l1 + l * a_dim1],
11030	abs(d_2));
11031	u1 = a[l + l * a_dim1] / s;
11032	u2 = a[l1 + l * a_dim1] / s;
11033	d_1 = sqrt(u1 * u1 + u2 * u2);
11034	r = d_sign(&d_1, &u1);
11035	v1 = -(u1 + r) / r;
11036	v2 = -u2 / r;
11037	u2 = v2 / v1;
11038
11039	i_1 = enorn;
11040	for (j = l; j <= i_1; ++j) {
11041	t = a[l + j * a_dim1] + u2 * a[l1 + j * a_dim1];
11042	a[l + j * a_dim1] += t * v1;
11043	a[l1 + j * a_dim1] += t * v2;
11044	t = b[l + j * b_dim1] + u2 * b[l1 + j * b_dim1];
11045	b[l + j * b_dim1] += t * v1;
11046	b[l1 + j * b_dim1] += t * v2;
11047	/* L110: */
11048	}
11049
11050	if (l != 1) {
11051	a[l + lm1 * a_dim1] = -a[l + lm1 * a_dim1];
11052	}
11053	lm1 = l;
11054	l = l1;
11055	goto L90;
11056	L120:
11057	a11 = a[l + l * a_dim1] / b11;
11058	a21 = a[l1 + l * a_dim1] / b11;
11059	if (ish == 1) {
11060	goto L140;
11061	}
11062	/* .......... ITERATION STRATEGY .......... */
11063	if (itn == 0) {
11064	goto L1000;
11065	}
11066	if (its == 10) {
11067	goto L155;
11068	}
11069	/* .......... DETERMINE TYPE OF SHIFT .......... */
11070	b22 = b[l1 + l1 * b_dim1];
11071	if (abs(b22) < epsb) {
11072	b22 = epsb;
11073	}
11074	b33 = b[na + na * b_dim1];
11075	if (abs(b33) < epsb) {
11076	b33 = epsb;
11077	}
11078	b44 = b[en + en * b_dim1];
11079	if (abs(b44) < epsb) {
11080	b44 = epsb;
11081	}
11082	a33 = a[na + na * a_dim1] / b33;
11083	a34 = a[na + en * a_dim1] / b44;
11084	a43 = a[en + na * a_dim1] / b33;
11085	a44 = a[en + en * a_dim1] / b44;
11086	b34 = b[na + en * b_dim1] / b44;
11087	t = (a43 * b34 - a33 - a44) * .5;
11088	r = t * t + a34 * a43 - a33 * a44;
11089	if (r < 0.) {
11090	goto L150;
11091	}
11092	/* .......... DETERMINE SINGLE SHIFT ZEROTH COLUMN OF A .......... */
11093	ish = 1;
11094	r = sqrt(r);
11095	sh = -t + r;
11096	s = -t - r;
11097	if ((d_1 = s - a44, abs(d_1)) < (d_2 = sh - a44, abs(d_2))) {
11098	sh = s;
11099	}
11100	/* .......... LOOK FOR TWO CONSECUTIVE SMALL */
11101	/* SUB-DIAGONAL ELEMENTS OF A. */
11102	/* FOR L=EN-2 STEP -1 UNTIL LD DO -- .......... */
11103	i_1 = enm2;
11104	for (ll = ld; ll <= i_1; ++ll) {
11105	l = enm2 + ld - ll;
11106	if (l == ld) {
11107	goto L140;
11108	}
11109	lm1 = l - 1;
11110	l1 = l + 1;
11111	t = a[l + l * a_dim1];
11112	if ((d_1 = b[l + l * b_dim1], abs(d_1)) > epsb) {
11113	t -= sh * b[l + l * b_dim1];
11114	}
11115	if ((d_1 = a[l + lm1 * a_dim1], abs(d_1)) <= (d_2 = t / a[l1 + l *
11116	a_dim1], abs(d_2)) * epsa) {
11117	goto L100;
11118	}
11119	/* L130: */
11120	}
11121
11122	L140:
11123	a1 = a11 - sh;
11124	a2 = a21;
11125	if (l != ld) {
11126	a[l + lm1 * a_dim1] = -a[l + lm1 * a_dim1];
11127	}
11128	goto L160;
11129	/* .......... DETERMINE DOUBLE SHIFT ZEROTH COLUMN OF A .......... */
11130	L150:
11131	a12 = a[l + l1 * a_dim1] / b22;
11132	a22 = a[l1 + l1 * a_dim1] / b22;
11133	b12 = b[l + l1 * b_dim1] / b22;
11134	a1 = ((a33 - a11) * (a44 - a11) - a34 * a43 + a43 * b34 * a11) / a21 +
11135	a12 - a11 * b12;
11136	a2 = a22 - a11 - a21 * b12 - (a33 - a11) - (a44 - a11) + a43 * b34;
11137	a3 = a[l1 + 1 + l1 * a_dim1] / b22;
11138	goto L160;
11139	/* .......... AD HOC SHIFT .......... */
11140	L155:
11141	a1 = 0.;
11142	a2 = 1.;
11143	a3 = 1.1605;
11144	L160:
11145	++its;
11146	--itn;
11147	if (! (*matz)) {
11148	lor1 = ld;
11149	}
11150	/* .......... MAIN LOOP .......... */
11151	i_1 = na;
11152	for (k = l; k <= i_1; ++k) {
11153	notlas = k != na && ish == 2;
11154	k1 = k + 1;
11155	k2 = k + 2;
11156	/* Computing MAX */
11157	i_2 = k - 1;
11158	km1 = max(i_2,l);
11159	/* Computing MIN */
11160	i_2 = en, i_3 = k1 + ish;
11161	ll = min(i_2,i_3);
11162	if (notlas) {
11163	goto L190;
11164	}
11165	/* .......... ZERO A(K+1,K-1) .......... */
11166	if (k == l) {
11167	goto L170;
11168	}
11169	a1 = a[k + km1 * a_dim1];
11170	a2 = a[k1 + km1 * a_dim1];
11171	L170:
11172	s = abs(a1) + abs(a2);
11173	if (s == 0.) {
11174	goto L70;
11175	}
11176	u1 = a1 / s;
11177	u2 = a2 / s;
11178	d_1 = sqrt(u1 * u1 + u2 * u2);
11179	r = d_sign(&d_1, &u1);
11180	v1 = -(u1 + r) / r;
11181	v2 = -u2 / r;
11182	u2 = v2 / v1;
11183
11184	i_2 = enorn;
11185	for (j = km1; j <= i_2; ++j) {
11186	t = a[k + j * a_dim1] + u2 * a[k1 + j * a_dim1];
11187	a[k + j * a_dim1] += t * v1;
11188	a[k1 + j * a_dim1] += t * v2;
11189	t = b[k + j * b_dim1] + u2 * b[k1 + j * b_dim1];
11190	b[k + j * b_dim1] += t * v1;
11191	b[k1 + j * b_dim1] += t * v2;
11192	/* L180: */
11193	}
11194
11195	if (k != l) {
11196	a[k1 + km1 * a_dim1] = 0.;
11197	}
11198	goto L240;
11199	/* .......... ZERO A(K+1,K-1) AND A(K+2,K-1) .......... */
11200	L190:
11201	if (k == l) {
11202	goto L200;
11203	}
11204	a1 = a[k + km1 * a_dim1];
11205	a2 = a[k1 + km1 * a_dim1];
11206	a3 = a[k2 + km1 * a_dim1];
11207	L200:
11208	s = abs(a1) + abs(a2) + abs(a3);
11209	if (s == 0.) {
11210	goto L260;
11211	}
11212	u1 = a1 / s;
11213	u2 = a2 / s;
11214	u3 = a3 / s;
11215	d_1 = sqrt(u1 * u1 + u2 * u2 + u3 * u3);
11216	r = d_sign(&d_1, &u1);
11217	v1 = -(u1 + r) / r;
11218	v2 = -u2 / r;
11219	v3 = -u3 / r;
11220	u2 = v2 / v1;
11221	u3 = v3 / v1;
11222
11223	i_2 = enorn;
11224	for (j = km1; j <= i_2; ++j) {
11225	t = a[k + j * a_dim1] + u2 * a[k1 + j * a_dim1] + u3 * a[k2 + j *
11226	a_dim1];
11227	a[k + j * a_dim1] += t * v1;
11228	a[k1 + j * a_dim1] += t * v2;
11229	a[k2 + j * a_dim1] += t * v3;
11230	t = b[k + j * b_dim1] + u2 * b[k1 + j * b_dim1] + u3 * b[k2 + j *
11231	b_dim1];
11232	b[k + j * b_dim1] += t * v1;
11233	b[k1 + j * b_dim1] += t * v2;
11234	b[k2 + j * b_dim1] += t * v3;
11235	/* L210: */
11236	}
11237
11238	if (k == l) {
11239	goto L220;
11240	}
11241	a[k1 + km1 * a_dim1] = 0.;
11242	a[k2 + km1 * a_dim1] = 0.;
11243	/* .......... ZERO B(K+2,K+1) AND B(K+2,K) .......... */
11244	L220:
11245	s = (d_1 = b[k2 + k2 * b_dim1], abs(d_1)) + (d_2 = b[k2 + k1 *
11246	b_dim1], abs(d_2)) + (d_3 = b[k2 + k * b_dim1], abs(d_3));
11247	if (s == 0.) {
11248	goto L240;
11249	}
11250	u1 = b[k2 + k2 * b_dim1] / s;
11251	u2 = b[k2 + k1 * b_dim1] / s;
11252	u3 = b[k2 + k * b_dim1] / s;
11253	d_1 = sqrt(u1 * u1 + u2 * u2 + u3 * u3);
11254	r = d_sign(&d_1, &u1);
11255	v1 = -(u1 + r) / r;
11256	v2 = -u2 / r;
11257	v3 = -u3 / r;
11258	u2 = v2 / v1;
11259	u3 = v3 / v1;
11260
11261	i_2 = ll;
11262	for (i = lor1; i <= i_2; ++i) {
11263	t = a[i + k2 * a_dim1] + u2 * a[i + k1 * a_dim1] + u3 * a[i + k *
11264	a_dim1];
11265	a[i + k2 * a_dim1] += t * v1;
11266	a[i + k1 * a_dim1] += t * v2;
11267	a[i + k * a_dim1] += t * v3;
11268	t = b[i + k2 * b_dim1] + u2 * b[i + k1 * b_dim1] + u3 * b[i + k *
11269	b_dim1];
11270	b[i + k2 * b_dim1] += t * v1;
11271	b[i + k1 * b_dim1] += t * v2;
11272	b[i + k * b_dim1] += t * v3;
11273	/* L230: */
11274	}
11275
11276	b[k2 + k * b_dim1] = 0.;
11277	b[k2 + k1 * b_dim1] = 0.;
11278	if (! (*matz)) {
11279	goto L240;
11280	}
11281
11282	i_2 = *n;
11283	for (i = 1; i <= i_2; ++i) {
11284	t = z[i + k2 * z_dim1] + u2 * z[i + k1 * z_dim1] + u3 * z[i + k *
11285	z_dim1];
11286	z[i + k2 * z_dim1] += t * v1;
11287	z[i + k1 * z_dim1] += t * v2;
11288	z[i + k * z_dim1] += t * v3;
11289	/* L235: */
11290	}
11291	/* .......... ZERO B(K+1,K) .......... */
11292	L240:
11293	s = (d_1 = b[k1 + k1 * b_dim1], abs(d_1)) + (d_2 = b[k1 + k *
11294	b_dim1], abs(d_2));
11295	if (s == 0.) {
11296	goto L260;
11297	}
11298	u1 = b[k1 + k1 * b_dim1] / s;
11299	u2 = b[k1 + k * b_dim1] / s;
11300	d_1 = sqrt(u1 * u1 + u2 * u2);
11301	r = d_sign(&d_1, &u1);
11302	v1 = -(u1 + r) / r;
11303	v2 = -u2 / r;
11304	u2 = v2 / v1;
11305
11306	i_2 = ll;
11307	for (i = lor1; i <= i_2; ++i) {
11308	t = a[i + k1 * a_dim1] + u2 * a[i + k * a_dim1];
11309	a[i + k1 * a_dim1] += t * v1;
11310	a[i + k * a_dim1] += t * v2;
11311	t = b[i + k1 * b_dim1] + u2 * b[i + k * b_dim1];
11312	b[i + k1 * b_dim1] += t * v1;
11313	b[i + k * b_dim1] += t * v2;
11314	/* L250: */
11315	}
11316
11317	b[k1 + k * b_dim1] = 0.;
11318	if (! (*matz)) {
11319	goto L260;
11320	}
11321
11322	i_2 = *n;
11323	for (i = 1; i <= i_2; ++i) {
11324	t = z[i + k1 * z_dim1] + u2 * z[i + k * z_dim1];
11325	z[i + k1 * z_dim1] += t * v1;
11326	z[i + k * z_dim1] += t * v2;
11327	/* L255: */
11328	}
11329
11330	L260:
11331	;
11332	}
11333	/* .......... END QZ STEP .......... */
11334	goto L70;
11335	/* .......... SET ERROR -- ALL EIGENVALUES HAVE NOT */
11336	/* CONVERGED AFTER 30N ITERATIONS .......... /
11337	L1000:
11338	*ierr = en;
11339	/* .......... SAVE EPSB FOR USE BY QZVAL AND QZVEC .......... */
11340	L1001:
11341	if (*n > 1) {
11342	b[*n + b_dim1] = epsb;
11343	}
11344	return 0;
11345	} /* qzit_ */
11346
11347	/* Subroutine / int qzval_(integer nm, integer n, doublereal a,
11348	doublereal b, doublereal alfr, doublereal alfi, doublereal beta,
11349	logical matz, doublereal z)
11350	{
11351	/* System generated locals */
11352	integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i_1, i_2;
11353	doublereal d_1, d_2, d_3, d_4;
11354
11355	/* Builtin functions */
11356	double sqrt(doublereal), d_sign(doublereal , doublereal );
11357
11358	/* Local variables */
11359	static doublereal epsb, c, d, e;
11360	static integer i, j;
11361	static doublereal r, s, t, a1, a2, u1, u2, v1, v2, a11, a12, a21, a22,
11362	b11, b12, b22, di, ei;
11363	static integer na;
11364	static doublereal an, bn;
11365	static integer en;
11366	static doublereal cq, dr;
11367	static integer nn;
11368	static doublereal cz, ti, tr, a1i, a2i, a11i, a12i, a22i, a11r, a12r,
11369	a22r, sqi, ssi;
11370	static integer isw;
11371	static doublereal sqr, szi, ssr, szr;
11372
11373
11374
11375	/* THIS SUBROUTINE IS THE THIRD STEP OF THE QZ ALGORITHM */
11376	/* FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS, */
11377	/* SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART. */
11378
11379	/* THIS SUBROUTINE ACCEPTS A PAIR OF REAL MATRICES, ONE OF THEM */
11380	/* IN QUASI-TRIANGULAR FORM AND THE OTHER IN UPPER TRIANGULAR FORM. */
11381	/* IT REDUCES THE QUASI-TRIANGULAR MATRIX FURTHER, SO THAT ANY */
11382	/* REMAINING 2-BY-2 BLOCKS CORRESPOND TO PAIRS OF COMPLEX */
11383	/* EIGENVALUES, AND RETURNS QUANTITIES WHOSE RATIOS GIVE THE */
11384	/* GENERALIZED EIGENVALUES. IT IS USUALLY PRECEDED BY QZHES */
11385	/* AND QZIT AND MAY BE FOLLOWED BY QZVEC. */
11386
11387	/* ON INPUT */
11388
11389	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
11390	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
11391	/* DIMENSION STATEMENT. */
11392
11393	/* N IS THE ORDER OF THE MATRICES. */
11394
11395	/* A CONTAINS A REAL UPPER QUASI-TRIANGULAR MATRIX. */
11396
11397	/* B CONTAINS A REAL UPPER TRIANGULAR MATRIX. IN ADDITION, */
11398	/* LOCATION B(N,1) CONTAINS THE TOLERANCE QUANTITY (EPSB) */
11399	/* COMPUTED AND SAVED IN QZIT. */
11400
11401	/* MATZ SHOULD BE SET TO .TRUE. IF THE RIGHT HAND TRANSFORMATIONS
11402	*/
11403	/* ARE TO BE ACCUMULATED FOR LATER USE IN COMPUTING */
11404	/* EIGENVECTORS, AND TO .FALSE. OTHERWISE. */
11405
11406	/* Z CONTAINS, IF MATZ HAS BEEN SET TO .TRUE., THE */
11407	/* TRANSFORMATION MATRIX PRODUCED IN THE REDUCTIONS BY QZHES */
11408	/* AND QZIT, IF PERFORMED, OR ELSE THE IDENTITY MATRIX. */
11409	/* IF MATZ HAS BEEN SET TO .FALSE., Z IS NOT REFERENCED. */
11410
11411	/* ON OUTPUT */
11412
11413	/* A HAS BEEN REDUCED FURTHER TO A QUASI-TRIANGULAR MATRIX */
11414	/* IN WHICH ALL NONZERO SUBDIAGONAL ELEMENTS CORRESPOND TO */
11415	/* PAIRS OF COMPLEX EIGENVALUES. */
11416
11417	/* B IS STILL IN UPPER TRIANGULAR FORM, ALTHOUGH ITS ELEMENTS */
11418	/* HAVE BEEN ALTERED. B(N,1) IS UNALTERED. */
11419
11420	/* ALFR AND ALFI CONTAIN THE REAL AND IMAGINARY PARTS OF THE */
11421	/* DIAGONAL ELEMENTS OF THE TRIANGULAR MATRIX THAT WOULD BE */
11422	/* OBTAINED IF A WERE REDUCED COMPLETELY TO TRIANGULAR FORM */
11423	/* BY UNITARY TRANSFORMATIONS. NON-ZERO VALUES OF ALFI OCCUR */
11424	/* IN PAIRS, THE FIRST MEMBER POSITIVE AND THE SECOND NEGATIVE.
11425	*/
11426
11427	/* BETA CONTAINS THE DIAGONAL ELEMENTS OF THE CORRESPONDING B, */
11428	/* NORMALIZED TO BE REAL AND NON-NEGATIVE. THE GENERALIZED */
11429	/* EIGENVALUES ARE THEN THE RATIOS ((ALFR+IALFI)/BETA). /
11430
11431	/* Z CONTAINS THE PRODUCT OF THE RIGHT HAND TRANSFORMATIONS */
11432	/* (FOR ALL THREE STEPS) IF MATZ HAS BEEN SET TO .TRUE. */
11433
11434	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
11435	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
11436	*/
11437
11438	/* THIS VERSION DATED AUGUST 1983. */
11439
11440	/* ------------------------------------------------------------------
11441	*/
11442
11443	/* Parameter adjustments */
11444	z_dim1 = *nm;
11445	z_offset = z_dim1 + 1;
11446	z -= z_offset;
11447	--beta;
11448	--alfi;
11449	--alfr;
11450	b_dim1 = *nm;
11451	b_offset = b_dim1 + 1;
11452	b -= b_offset;
11453	a_dim1 = *nm;
11454	a_offset = a_dim1 + 1;
11455	a -= a_offset;
11456
11457	/* Function Body */
11458	epsb = b[*n + b_dim1];
11459	isw = 1;
11460	/* .......... FIND EIGENVALUES OF QUASI-TRIANGULAR MATRICES. */
11461	/* FOR EN=N STEP -1 UNTIL 1 DO -- .......... */
11462	i_1 = *n;
11463	for (nn = 1; nn <= i_1; ++nn) {
11464	en = *n + 1 - nn;
11465	na = en - 1;
11466	if (isw == 2) {
11467	goto L505;
11468	}
11469	if (en == 1) {
11470	goto L410;
11471	}
11472	if (a[en + na * a_dim1] != 0.) {
11473	goto L420;
11474	}
11475	/* .......... 1-BY-1 BLOCK, ONE REAL ROOT .......... */
11476	L410:
11477	alfr[en] = a[en + en * a_dim1];
11478	if (b[en + en * b_dim1] < 0.) {
11479	alfr[en] = -alfr[en];
11480	}
11481	beta[en] = (d_1 = b[en + en * b_dim1], abs(d_1));
11482	alfi[en] = 0.;
11483	goto L510;
11484	/* .......... 2-BY-2 BLOCK .......... */
11485	L420:
11486	if ((d_1 = b[na + na * b_dim1], abs(d_1)) <= epsb) {
11487	goto L455;
11488	}
11489	if ((d_1 = b[en + en * b_dim1], abs(d_1)) > epsb) {
11490	goto L430;
11491	}
11492	a1 = a[en + en * a_dim1];
11493	a2 = a[en + na * a_dim1];
11494	bn = 0.;
11495	goto L435;
11496	L430:
11497	an = (d_1 = a[na + na * a_dim1], abs(d_1)) + (d_2 = a[na + en *
11498	a_dim1], abs(d_2)) + (d_3 = a[en + na * a_dim1], abs(d_3))
11499	+ (d_4 = a[en + en * a_dim1], abs(d_4));
11500	bn = (d_1 = b[na + na * b_dim1], abs(d_1)) + (d_2 = b[na + en *
11501	b_dim1], abs(d_2)) + (d_3 = b[en + en * b_dim1], abs(d_3));
11502	a11 = a[na + na * a_dim1] / an;
11503	a12 = a[na + en * a_dim1] / an;
11504	a21 = a[en + na * a_dim1] / an;
11505	a22 = a[en + en * a_dim1] / an;
11506	b11 = b[na + na * b_dim1] / bn;
11507	b12 = b[na + en * b_dim1] / bn;
11508	b22 = b[en + en * b_dim1] / bn;
11509	e = a11 / b11;
11510	ei = a22 / b22;
11511	s = a21 / (b11 * b22);
11512	t = (a22 - e * b22) / b22;
11513	if (abs(e) <= abs(ei)) {
11514	goto L431;
11515	}
11516	e = ei;
11517	t = (a11 - e * b11) / b11;
11518	L431:
11519	c = (t - s * b12) * .5;
11520	d = c * c + s * (a12 - e * b12);
11521	if (d < 0.) {
11522	goto L480;
11523	}
11524	/* .......... TWO REAL ROOTS. */
11525	/* ZERO BOTH A(EN,NA) AND B(EN,NA) .......... */
11526	d_1 = sqrt(d);
11527	e += c + d_sign(&d_1, &c);
11528	a11 -= e * b11;
11529	a12 -= e * b12;
11530	a22 -= e * b22;
11531	if (abs(a11) + abs(a12) < abs(a21) + abs(a22)) {
11532	goto L432;
11533	}
11534	a1 = a12;
11535	a2 = a11;
11536	goto L435;
11537	L432:
11538	a1 = a22;
11539	a2 = a21;
11540	/* .......... CHOOSE AND APPLY REAL Z .......... */
11541	L435:
11542	s = abs(a1) + abs(a2);
11543	u1 = a1 / s;
11544	u2 = a2 / s;
11545	d_1 = sqrt(u1 * u1 + u2 * u2);
11546	r = d_sign(&d_1, &u1);
11547	v1 = -(u1 + r) / r;
11548	v2 = -u2 / r;
11549	u2 = v2 / v1;
11550
11551	i_2 = en;
11552	for (i = 1; i <= i_2; ++i) {
11553	t = a[i + en * a_dim1] + u2 * a[i + na * a_dim1];
11554	a[i + en * a_dim1] += t * v1;
11555	a[i + na * a_dim1] += t * v2;
11556	t = b[i + en * b_dim1] + u2 * b[i + na * b_dim1];
11557	b[i + en * b_dim1] += t * v1;
11558	b[i + na * b_dim1] += t * v2;
11559	/* L440: */
11560	}
11561
11562	if (! (*matz)) {
11563	goto L450;
11564	}
11565
11566	i_2 = *n;
11567	for (i = 1; i <= i_2; ++i) {
11568	t = z[i + en * z_dim1] + u2 * z[i + na * z_dim1];
11569	z[i + en * z_dim1] += t * v1;
11570	z[i + na * z_dim1] += t * v2;
11571	/* L445: */
11572	}
11573
11574	L450:
11575	if (bn == 0.) {
11576	goto L475;
11577	}
11578	if (an < abs(e) * bn) {
11579	goto L455;
11580	}
11581	a1 = b[na + na * b_dim1];
11582	a2 = b[en + na * b_dim1];
11583	goto L460;
11584	L455:
11585	a1 = a[na + na * a_dim1];
11586	a2 = a[en + na * a_dim1];
11587	/* .......... CHOOSE AND APPLY REAL Q .......... */
11588	L460:
11589	s = abs(a1) + abs(a2);
11590	if (s == 0.) {
11591	goto L475;
11592	}
11593	u1 = a1 / s;
11594	u2 = a2 / s;
11595	d_1 = sqrt(u1 * u1 + u2 * u2);
11596	r = d_sign(&d_1, &u1);
11597	v1 = -(u1 + r) / r;
11598	v2 = -u2 / r;
11599	u2 = v2 / v1;
11600
11601	i_2 = *n;
11602	for (j = na; j <= i_2; ++j) {
11603	t = a[na + j * a_dim1] + u2 * a[en + j * a_dim1];
11604	a[na + j * a_dim1] += t * v1;
11605	a[en + j * a_dim1] += t * v2;
11606	t = b[na + j * b_dim1] + u2 * b[en + j * b_dim1];
11607	b[na + j * b_dim1] += t * v1;
11608	b[en + j * b_dim1] += t * v2;
11609	/* L470: */
11610	}
11611
11612	L475:
11613	a[en + na * a_dim1] = 0.;
11614	b[en + na * b_dim1] = 0.;
11615	alfr[na] = a[na + na * a_dim1];
11616	alfr[en] = a[en + en * a_dim1];
11617	if (b[na + na * b_dim1] < 0.) {
11618	alfr[na] = -alfr[na];
11619	}
11620	if (b[en + en * b_dim1] < 0.) {
11621	alfr[en] = -alfr[en];
11622	}
11623	beta[na] = (d_1 = b[na + na * b_dim1], abs(d_1));
11624	beta[en] = (d_1 = b[en + en * b_dim1], abs(d_1));
11625	alfi[en] = 0.;
11626	alfi[na] = 0.;
11627	goto L505;
11628	/* .......... TWO COMPLEX ROOTS .......... */
11629	L480:
11630	e += c;
11631	ei = sqrt(-d);
11632	a11r = a11 - e * b11;
11633	a11i = ei * b11;
11634	a12r = a12 - e * b12;
11635	a12i = ei * b12;
11636	a22r = a22 - e * b22;
11637	a22i = ei * b22;
11638	if (abs(a11r) + abs(a11i) + abs(a12r) + abs(a12i) < abs(a21) + abs(
11639	a22r) + abs(a22i)) {
11640	goto L482;
11641	}
11642	a1 = a12r;
11643	a1i = a12i;
11644	a2 = -a11r;
11645	a2i = -a11i;
11646	goto L485;
11647	L482:
11648	a1 = a22r;
11649	a1i = a22i;
11650	a2 = -a21;
11651	a2i = 0.;
11652	/* .......... CHOOSE COMPLEX Z .......... */
11653	L485:
11654	cz = sqrt(a1 * a1 + a1i * a1i);
11655	if (cz == 0.) {
11656	goto L487;
11657	}
11658	szr = (a1 * a2 + a1i * a2i) / cz;
11659	szi = (a1 * a2i - a1i * a2) / cz;
11660	r = sqrt(cz * cz + szr * szr + szi * szi);
11661	cz /= r;
11662	szr /= r;
11663	szi /= r;
11664	goto L490;
11665	L487:
11666	szr = 1.;
11667	szi = 0.;
11668	L490:
11669	if (an < (abs(e) + ei) * bn) {
11670	goto L492;
11671	}
11672	a1 = cz * b11 + szr * b12;
11673	a1i = szi * b12;
11674	a2 = szr * b22;
11675	a2i = szi * b22;
11676	goto L495;
11677	L492:
11678	a1 = cz * a11 + szr * a12;
11679	a1i = szi * a12;
11680	a2 = cz * a21 + szr * a22;
11681	a2i = szi * a22;
11682	/* .......... CHOOSE COMPLEX Q .......... */
11683	L495:
11684	cq = sqrt(a1 * a1 + a1i * a1i);
11685	if (cq == 0.) {
11686	goto L497;
11687	}
11688	sqr = (a1 * a2 + a1i * a2i) / cq;
11689	sqi = (a1 * a2i - a1i * a2) / cq;
11690	r = sqrt(cq * cq + sqr * sqr + sqi * sqi);
11691	cq /= r;
11692	sqr /= r;
11693	sqi /= r;
11694	goto L500;
11695	L497:
11696	sqr = 1.;
11697	sqi = 0.;
11698	/* .......... COMPUTE DIAGONAL ELEMENTS THAT WOULD RESULT */
11699	/* IF TRANSFORMATIONS WERE APPLIED .......... */
11700	L500:
11701	ssr = sqr * szr + sqi * szi;
11702	ssi = sqr * szi - sqi * szr;
11703	i = 1;
11704	tr = cq * cz * a11 + cq * szr * a12 + sqr * cz * a21 + ssr * a22;
11705	ti = cq * szi * a12 - sqi * cz * a21 + ssi * a22;
11706	dr = cq * cz * b11 + cq * szr * b12 + ssr * b22;
11707	di = cq * szi * b12 + ssi * b22;
11708	goto L503;
11709	L502:
11710	i = 2;
11711	tr = ssr * a11 - sqr * cz * a12 - cq * szr * a21 + cq * cz * a22;
11712	ti = -ssi * a11 - sqi * cz * a12 + cq * szi * a21;
11713	dr = ssr * b11 - sqr * cz * b12 + cq * cz * b22;
11714	di = -ssi * b11 - sqi * cz * b12;
11715	L503:
11716	t = ti * dr - tr * di;
11717	j = na;
11718	if (t < 0.) {
11719	j = en;
11720	}
11721	r = sqrt(dr * dr + di * di);
11722	beta[j] = bn * r;
11723	alfr[j] = an * (tr * dr + ti * di) / r;
11724	alfi[j] = an * t / r;
11725	if (i == 1) {
11726	goto L502;
11727	}
11728	L505:
11729	isw = 3 - isw;
11730	L510:
11731	;
11732	}
11733	b[*n + b_dim1] = epsb;
11734
11735	return 0;
11736	} /* qzval_ */
11737
11738	/* Subroutine / int qzvec_(integer nm, integer n, doublereal a,
11739	doublereal b, doublereal alfr, doublereal alfi, doublereal beta,
11740	doublereal *z)
11741	{
11742	/* System generated locals */
11743	integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i_1, i_2,
11744	i_3;
11745	doublereal d_1, d_2;
11746
11747	/* Builtin functions */
11748	double sqrt(doublereal);
11749
11750	/* Local variables */
11751	static doublereal alfm, almi, betm, epsb, almr, d;
11752	static integer i, j, k, m;
11753	static doublereal q, r, s, t, w, x, y, t1, t2, w1, x1, z1, di;
11754	static integer na, ii, en, jj;
11755	static doublereal ra, dr, sa;
11756	static integer nn;
11757	static doublereal ti, rr, tr, zz;
11758	static integer isw, enm2;
11759
11760
11761
11762	/* THIS SUBROUTINE IS THE OPTIONAL FOURTH STEP OF THE QZ ALGORITHM */
11763	/* FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS, */
11764	/* SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART. */
11765
11766	/* THIS SUBROUTINE ACCEPTS A PAIR OF REAL MATRICES, ONE OF THEM IN */
11767	/* QUASI-TRIANGULAR FORM (IN WHICH EACH 2-BY-2 BLOCK CORRESPONDS TO */
11768	/* A PAIR OF COMPLEX EIGENVALUES) AND THE OTHER IN UPPER TRIANGULAR */
11769	/* FORM. IT COMPUTES THE EIGENVECTORS OF THE TRIANGULAR PROBLEM AND
11770	*/
11771	/* TRANSFORMS THE RESULTS BACK TO THE ORIGINAL COORDINATE SYSTEM. */
11772	/* IT IS USUALLY PRECEDED BY QZHES, QZIT, AND QZVAL. */
11773
11774	/* ON INPUT */
11775
11776	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
11777	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
11778	/* DIMENSION STATEMENT. */
11779
11780	/* N IS THE ORDER OF THE MATRICES. */
11781
11782	/* A CONTAINS A REAL UPPER QUASI-TRIANGULAR MATRIX. */
11783
11784	/* B CONTAINS A REAL UPPER TRIANGULAR MATRIX. IN ADDITION, */
11785	/* LOCATION B(N,1) CONTAINS THE TOLERANCE QUANTITY (EPSB) */
11786	/* COMPUTED AND SAVED IN QZIT. */
11787
11788	/* ALFR, ALFI, AND BETA ARE VECTORS WITH COMPONENTS WHOSE */
11789	/* RATIOS ((ALFR+IALFI)/BETA) ARE THE GENERALIZED /
11790	/* EIGENVALUES. THEY ARE USUALLY OBTAINED FROM QZVAL. */
11791
11792	/* Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE */
11793	/* REDUCTIONS BY QZHES, QZIT, AND QZVAL, IF PERFORMED. */
11794	/* IF THE EIGENVECTORS OF THE TRIANGULAR PROBLEM ARE */
11795	/* DESIRED, Z MUST CONTAIN THE IDENTITY MATRIX. */
11796
11797	/* ON OUTPUT */
11798
11799	/* A IS UNALTERED. ITS SUBDIAGONAL ELEMENTS PROVIDE INFORMATION */
11800	/* ABOUT THE STORAGE OF THE COMPLEX EIGENVECTORS. */
11801
11802	/* B HAS BEEN DESTROYED. */
11803
11804	/* ALFR, ALFI, AND BETA ARE UNALTERED. */
11805
11806	/* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS. */
11807	/* IF ALFI(I) .EQ. 0.0, THE I-TH EIGENVALUE IS REAL AND */
11808	/* THE I-TH COLUMN OF Z CONTAINS ITS EIGENVECTOR. */
11809	/* IF ALFI(I) .NE. 0.0, THE I-TH EIGENVALUE IS COMPLEX. */
11810	/* IF ALFI(I) .GT. 0.0, THE EIGENVALUE IS THE FIRST OF */
11811	/* A COMPLEX PAIR AND THE I-TH AND (I+1)-TH COLUMNS */
11812	/* OF Z CONTAIN ITS EIGENVECTOR. */
11813	/* IF ALFI(I) .LT. 0.0, THE EIGENVALUE IS THE SECOND OF */
11814	/* A COMPLEX PAIR AND THE (I-1)-TH AND I-TH COLUMNS */
11815	/* OF Z CONTAIN THE CONJUGATE OF ITS EIGENVECTOR. */
11816	/* EACH EIGENVECTOR IS NORMALIZED SO THAT THE MODULUS */
11817	/* OF ITS LARGEST COMPONENT IS 1.0 . */
11818
11819	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
11820	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
11821	*/
11822
11823	/* THIS VERSION DATED AUGUST 1983. */
11824
11825	/* ------------------------------------------------------------------
11826	*/
11827
11828	/* Parameter adjustments */
11829	z_dim1 = *nm;
11830	z_offset = z_dim1 + 1;
11831	z -= z_offset;
11832	--beta;
11833	--alfi;
11834	--alfr;
11835	b_dim1 = *nm;
11836	b_offset = b_dim1 + 1;
11837	b -= b_offset;
11838	a_dim1 = *nm;
11839	a_offset = a_dim1 + 1;
11840	a -= a_offset;
11841
11842	/* Function Body */
11843	epsb = b[*n + b_dim1];
11844	isw = 1;
11845	/* .......... FOR EN=N STEP -1 UNTIL 1 DO -- .......... */
11846	i_1 = *n;
11847	for (nn = 1; nn <= i_1; ++nn) {
11848	en = *n + 1 - nn;
11849	na = en - 1;
11850	if (isw == 2) {
11851	goto L795;
11852	}
11853	if (alfi[en] != 0.) {
11854	goto L710;
11855	}
11856	/* .......... REAL VECTOR .......... */
11857	m = en;
11858	b[en + en * b_dim1] = 1.;
11859	if (na == 0) {
11860	goto L800;
11861	}
11862	alfm = alfr[m];
11863	betm = beta[m];
11864	/* .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... */
11865	i_2 = na;
11866	for (ii = 1; ii <= i_2; ++ii) {
11867	i = en - ii;
11868	w = betm * a[i + i * a_dim1] - alfm * b[i + i * b_dim1];
11869	r = 0.;
11870
11871	i_3 = en;
11872	for (j = m; j <= i_3; ++j) {
11873	/* L610: */
11874	r += (betm * a[i + j * a_dim1] - alfm * b[i + j * b_dim1]) *
11875	b[j + en * b_dim1];
11876	}
11877
11878	if (i == 1 \|\| isw == 2) {
11879	goto L630;
11880	}
11881	if (betm * a[i + (i - 1) * a_dim1] == 0.) {
11882	goto L630;
11883	}
11884	zz = w;
11885	s = r;
11886	goto L690;
11887	L630:
11888	m = i;
11889	if (isw == 2) {
11890	goto L640;
11891	}
11892	/* .......... REAL 1-BY-1 BLOCK .......... */
11893	t = w;
11894	if (w == 0.) {
11895	t = epsb;
11896	}
11897	b[i + en * b_dim1] = -r / t;
11898	goto L700;
11899	/* .......... REAL 2-BY-2 BLOCK .......... */
11900	L640:
11901	x = betm * a[i + (i + 1) * a_dim1] - alfm * b[i + (i + 1) *
11902	b_dim1];
11903	y = betm * a[i + 1 + i * a_dim1];
11904	q = w * zz - x * y;
11905	t = (x * s - zz * r) / q;
11906	b[i + en * b_dim1] = t;
11907	if (abs(x) <= abs(zz)) {
11908	goto L650;
11909	}
11910	b[i + 1 + en * b_dim1] = (-r - w * t) / x;
11911	goto L690;
11912	L650:
11913	b[i + 1 + en * b_dim1] = (-s - y * t) / zz;
11914	L690:
11915	isw = 3 - isw;
11916	L700:
11917	;
11918	}
11919	/* .......... END REAL VECTOR .......... */
11920	goto L800;
11921	/* .......... COMPLEX VECTOR .......... */
11922	L710:
11923	m = na;
11924	almr = alfr[m];
11925	almi = alfi[m];
11926	betm = beta[m];
11927	/* .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT */
11928	/* EIGENVECTOR MATRIX IS TRIANGULAR .......... */
11929	y = betm * a[en + na * a_dim1];
11930	b[na + na * b_dim1] = -almi * b[en + en * b_dim1] / y;
11931	b[na + en * b_dim1] = (almr * b[en + en * b_dim1] - betm * a[en + en *
11932	a_dim1]) / y;
11933	b[en + na * b_dim1] = 0.;
11934	b[en + en * b_dim1] = 1.;
11935	enm2 = na - 1;
11936	if (enm2 == 0) {
11937	goto L795;
11938	}
11939	/* .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- .......... */
11940	i_2 = enm2;
11941	for (ii = 1; ii <= i_2; ++ii) {
11942	i = na - ii;
11943	w = betm * a[i + i * a_dim1] - almr * b[i + i * b_dim1];
11944	w1 = -almi * b[i + i * b_dim1];
11945	ra = 0.;
11946	sa = 0.;
11947
11948	i_3 = en;
11949	for (j = m; j <= i_3; ++j) {
11950	x = betm * a[i + j * a_dim1] - almr * b[i + j * b_dim1];
11951	x1 = -almi * b[i + j * b_dim1];
11952	ra = ra + x * b[j + na * b_dim1] - x1 * b[j + en * b_dim1];
11953	sa = sa + x * b[j + en * b_dim1] + x1 * b[j + na * b_dim1];
11954	/* L760: */
11955	}
11956
11957	if (i == 1 \|\| isw == 2) {
11958	goto L770;
11959	}
11960	if (betm * a[i + (i - 1) * a_dim1] == 0.) {
11961	goto L770;
11962	}
11963	zz = w;
11964	z1 = w1;
11965	r = ra;
11966	s = sa;
11967	isw = 2;
11968	goto L790;
11969	L770:
11970	m = i;
11971	if (isw == 2) {
11972	goto L780;
11973	}
11974	/* .......... COMPLEX 1-BY-1 BLOCK .......... */
11975	tr = -ra;
11976	ti = -sa;
11977	L773:
11978	dr = w;
11979	di = w1;
11980	/* .......... COMPLEX DIVIDE (T1,T2) = (TR,TI) / (DR,DI) .....
11981	..... */
11982	L775:
11983	if (abs(di) > abs(dr)) {
11984	goto L777;
11985	}
11986	rr = di / dr;
11987	d = dr + di * rr;
11988	t1 = (tr + ti * rr) / d;
11989	t2 = (ti - tr * rr) / d;
11990	switch (isw) {
11991	case 1: goto L787;
11992	case 2: goto L782;
11993	}
11994	L777:
11995	rr = dr / di;
11996	d = dr * rr + di;
11997	t1 = (tr * rr + ti) / d;
11998	t2 = (ti * rr - tr) / d;
11999	switch (isw) {
12000	case 1: goto L787;
12001	case 2: goto L782;
12002	}
12003	/* .......... COMPLEX 2-BY-2 BLOCK .......... */
12004	L780:
12005	x = betm * a[i + (i + 1) * a_dim1] - almr * b[i + (i + 1) *
12006	b_dim1];
12007	x1 = -almi * b[i + (i + 1) * b_dim1];
12008	y = betm * a[i + 1 + i * a_dim1];
12009	tr = y * ra - w * r + w1 * s;
12010	ti = y * sa - w * s - w1 * r;
12011	dr = w * zz - w1 * z1 - x * y;
12012	di = w * z1 + w1 * zz - x1 * y;
12013	if (dr == 0. && di == 0.) {
12014	dr = epsb;
12015	}
12016	goto L775;
12017	L782:
12018	b[i + 1 + na * b_dim1] = t1;
12019	b[i + 1 + en * b_dim1] = t2;
12020	isw = 1;
12021	if (abs(y) > abs(w) + abs(w1)) {
12022	goto L785;
12023	}
12024	tr = -ra - x * b[i + 1 + na * b_dim1] + x1 * b[i + 1 + en *
12025	b_dim1];
12026	ti = -sa - x * b[i + 1 + en * b_dim1] - x1 * b[i + 1 + na *
12027	b_dim1];
12028	goto L773;
12029	L785:
12030	t1 = (-r - zz * b[i + 1 + na * b_dim1] + z1 * b[i + 1 + en *
12031	b_dim1]) / y;
12032	t2 = (-s - zz * b[i + 1 + en * b_dim1] - z1 * b[i + 1 + na *
12033	b_dim1]) / y;
12034	L787:
12035	b[i + na * b_dim1] = t1;
12036	b[i + en * b_dim1] = t2;
12037	L790:
12038	;
12039	}
12040	/* .......... END COMPLEX VECTOR .......... */
12041	L795:
12042	isw = 3 - isw;
12043	L800:
12044	;
12045	}
12046	/* .......... END BACK SUBSTITUTION. */
12047	/* TRANSFORM TO ORIGINAL COORDINATE SYSTEM. */
12048	/* FOR J=N STEP -1 UNTIL 1 DO -- .......... */
12049	i_1 = *n;
12050	for (jj = 1; jj <= i_1; ++jj) {
12051	j = *n + 1 - jj;
12052
12053	i_2 = *n;
12054	for (i = 1; i <= i_2; ++i) {
12055	zz = 0.;
12056
12057	i_3 = j;
12058	for (k = 1; k <= i_3; ++k) {
12059	/* L860: */
12060	zz += z[i + k * z_dim1] * b[k + j * b_dim1];
12061	}
12062
12063	z[i + j * z_dim1] = zz;
12064	/* L880: */
12065	}
12066	}
12067	/* .......... NORMALIZE SO THAT MODULUS OF LARGEST */
12068	/* COMPONENT OF EACH VECTOR IS 1. */
12069	/* (ISW IS 1 INITIALLY FROM BEFORE) .......... */
12070	i_2 = *n;
12071	for (j = 1; j <= i_2; ++j) {
12072	d = 0.;
12073	if (isw == 2) {
12074	goto L920;
12075	}
12076	if (alfi[j] != 0.) {
12077	goto L945;
12078	}
12079
12080	i_1 = *n;
12081	for (i = 1; i <= i_1; ++i) {
12082	if ((d_1 = z[i + j * z_dim1], abs(d_1)) > d) {
12083	d = (d_2 = z[i + j * z_dim1], abs(d_2));
12084	}
12085	/* L890: */
12086	}
12087
12088	i_1 = *n;
12089	for (i = 1; i <= i_1; ++i) {
12090	/* L900: */
12091	z[i + j * z_dim1] /= d;
12092	}
12093
12094	goto L950;
12095
12096	L920:
12097	i_1 = *n;
12098	for (i = 1; i <= i_1; ++i) {
12099	r = (d_1 = z[i + (j - 1) * z_dim1], abs(d_1)) + (d_2 = z[i + j
12100	* z_dim1], abs(d_2));
12101	if (r != 0.) {
12102	/* Computing 2nd power */
12103	d_1 = z[i + (j - 1) * z_dim1] / r;
12104	/* Computing 2nd power */
12105	d_2 = z[i + j * z_dim1] / r;
12106	r = sqrt(d_1 d_1 + d_2 * d_2);
12107	}
12108	if (r > d) {
12109	d = r;
12110	}
12111	/* L930: */
12112	}
12113
12114	i_1 = *n;
12115	for (i = 1; i <= i_1; ++i) {
12116	z[i + (j - 1) * z_dim1] /= d;
12117	z[i + j * z_dim1] /= d;
12118	/* L940: */
12119	}
12120
12121	L945:
12122	isw = 3 - isw;
12123	L950:
12124	;
12125	}
12126
12127	return 0;
12128	} /* qzvec_ */
12129
12130	/* Subroutine / int ratqr_(integer n, doublereal eps1, doublereal d,
12131	doublereal e, doublereal e2, integer m, doublereal w, integer *
12132	ind, doublereal bd, logical type, integer idef, integer ierr)
12133	{
12134	/* System generated locals */
12135	integer i_1, i_2;
12136	doublereal d_1, d_2, d_3;
12137
12138	/* Local variables */
12139	static integer jdef;
12140	static doublereal f;
12141	static integer i, j, k;
12142	static doublereal p, q, r, s, delta;
12143	static integer k1, ii, jj;
12144	static doublereal ep, qp;
12145	extern doublereal epslon_(doublereal *);
12146	static doublereal err, tot;
12147
12148
12149
12150	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE RATQR, */
12151	/* NUM. MATH. 11, 264-272(1968) BY REINSCH AND BAUER. */
12152	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 257-265(1971). */
12153
12154	/* THIS SUBROUTINE FINDS THE ALGEBRAICALLY SMALLEST OR LARGEST */
12155	/* EIGENVALUES OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE */
12156	/* RATIONAL QR METHOD WITH NEWTON CORRECTIONS. */
12157
12158	/* ON INPUT */
12159
12160	/* N IS THE ORDER OF THE MATRIX. */
12161
12162	/* EPS1 IS A THEORETICAL ABSOLUTE ERROR TOLERANCE FOR THE */
12163	/* COMPUTED EIGENVALUES. IF THE INPUT EPS1 IS NON-POSITIVE, */
12164	/* OR INDEED SMALLER THAN ITS DEFAULT VALUE, IT IS RESET */
12165	/* AT EACH ITERATION TO THE RESPECTIVE DEFAULT VALUE, */
12166	/* NAMELY, THE PRODUCT OF THE RELATIVE MACHINE PRECISION */
12167	/* AND THE MAGNITUDE OF THE CURRENT EIGENVALUE ITERATE. */
12168	/* THE THEORETICAL ABSOLUTE ERROR IN THE K-TH EIGENVALUE */
12169	/* IS USUALLY NOT GREATER THAN K TIMES EPS1. */
12170
12171	/* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */
12172
12173	/* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */
12174	/* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */
12175
12176	/* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */
12177	/* E2(1) IS ARBITRARY. */
12178
12179	/* M IS THE NUMBER OF EIGENVALUES TO BE FOUND. */
12180
12181	/* IDEF SHOULD BE SET TO 1 IF THE INPUT MATRIX IS KNOWN TO BE */
12182	/* POSITIVE DEFINITE, TO -1 IF THE INPUT MATRIX IS KNOWN TO */
12183	/* BE NEGATIVE DEFINITE, AND TO 0 OTHERWISE. */
12184
12185	/* TYPE SHOULD BE SET TO .TRUE. IF THE SMALLEST EIGENVALUES */
12186	/* ARE TO BE FOUND, AND TO .FALSE. IF THE LARGEST EIGENVALUES */
12187	/* ARE TO BE FOUND. */
12188
12189	/* ON OUTPUT */
12190
12191	/* EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS */
12192	/* (LAST) DEFAULT VALUE. */
12193
12194	/* D AND E ARE UNALTERED (UNLESS W OVERWRITES D). */
12195
12196	/* ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED */
12197	/* AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE */
12198	/* MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES. */
12199	/* E2(1) IS SET TO 0.0D0 IF THE SMALLEST EIGENVALUES HAVE BEEN */
12200	/* FOUND, AND TO 2.0D0 IF THE LARGEST EIGENVALUES HAVE BEEN */
12201	/* FOUND. E2 IS OTHERWISE UNALTERED (UNLESS OVERWRITTEN BY BD).
12202	*/
12203
12204	/* W CONTAINS THE M ALGEBRAICALLY SMALLEST EIGENVALUES IN */
12205	/* ASCENDING ORDER, OR THE M LARGEST EIGENVALUES IN */
12206	/* DESCENDING ORDER. IF AN ERROR EXIT IS MADE BECAUSE OF */
12207	/* AN INCORRECT SPECIFICATION OF IDEF, NO EIGENVALUES */
12208	/* ARE FOUND. IF THE NEWTON ITERATES FOR A PARTICULAR */
12209	/* EIGENVALUE ARE NOT MONOTONE, THE BEST ESTIMATE OBTAINED */
12210	/* IS RETURNED AND IERR IS SET. W MAY COINCIDE WITH D. */
12211
12212	/* IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES */
12213	/* ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W -- */
12214	/* 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM */
12215	/* THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC..
12216	*/
12217
12218	/* BD CONTAINS REFINED BOUNDS FOR THE THEORETICAL ERRORS OF THE */
12219	/* CORRESPONDING EIGENVALUES IN W. THESE BOUNDS ARE USUALLY */
12220	/* WITHIN THE TOLERANCE SPECIFIED BY EPS1. BD MAY COINCIDE */
12221	/* WITH E2. */
12222
12223	/* IERR IS SET TO */
12224	/* ZERO FOR NORMAL RETURN, */
12225	/* 6N+1 IF IDEF IS SET TO 1 AND TYPE TO .TRUE. /
12226	/* WHEN THE MATRIX IS NOT POSITIVE DEFINITE, OR */
12227	/* IF IDEF IS SET TO -1 AND TYPE TO .FALSE. */
12228	/* WHEN THE MATRIX IS NOT NEGATIVE DEFINITE, */
12229	/* 5N+K IF SUCCESSIVE ITERATES TO THE K-TH EIGENVALUE /
12230	/* ARE NOT MONOTONE INCREASING, WHERE K REFERS */
12231	/* TO THE LAST SUCH OCCURRENCE. */
12232
12233	/* NOTE THAT SUBROUTINE TRIDIB IS GENERALLY FASTER AND MORE */
12234	/* ACCURATE THAN RATQR IF THE EIGENVALUES ARE CLUSTERED. */
12235
12236	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
12237	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
12238	*/
12239
12240	/* THIS VERSION DATED AUGUST 1983. */
12241
12242	/* ------------------------------------------------------------------
12243	*/
12244
12245	/* Parameter adjustments */
12246	--bd;
12247	--ind;
12248	--w;
12249	--e2;
12250	--e;
12251	--d;
12252
12253	/* Function Body */
12254	*ierr = 0;
12255	jdef = *idef;
12256	/* .......... COPY D ARRAY INTO W .......... */
12257	i_1 = *n;
12258	for (i = 1; i <= i_1; ++i) {
12259	/* L20: */
12260	w[i] = d[i];
12261	}
12262
12263	if (*type) {
12264	goto L40;
12265	}
12266	j = 1;
12267	goto L400;
12268	L40:
12269	err = 0.;
12270	s = 0.;
12271	/* .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES AND DEFINE */
12272	/* INITIAL SHIFT FROM LOWER GERSCHGORIN BOUND. */
12273	/* COPY E2 ARRAY INTO BD .......... */
12274	tot = w[1];
12275	q = 0.;
12276	j = 0;
12277
12278	i_1 = *n;
12279	for (i = 1; i <= i_1; ++i) {
12280	p = q;
12281	if (i == 1) {
12282	goto L60;
12283	}
12284	d_3 = (d_1 = d[i], abs(d_1)) + (d_2 = d[i - 1], abs(d_2));
12285	if (p > epslon_(&d_3)) {
12286	goto L80;
12287	}
12288	L60:
12289	e2[i] = 0.;
12290	L80:
12291	bd[i] = e2[i];
12292	/* .......... COUNT ALSO IF ELEMENT OF E2 HAS UNDERFLOWED ........
12293	.. */
12294	if (e2[i] == 0.) {
12295	++j;
12296	}
12297	ind[i] = j;
12298	q = 0.;
12299	if (i != *n) {
12300	q = (d_1 = e[i + 1], abs(d_1));
12301	}
12302	/* Computing MIN */
12303	d_1 = w[i] - p - q;
12304	tot = min(d_1,tot);
12305	/* L100: */
12306	}
12307
12308	if (jdef == 1 && tot < 0.) {
12309	goto L140;
12310	}
12311
12312	i_1 = *n;
12313	for (i = 1; i <= i_1; ++i) {
12314	/* L110: */
12315	w[i] -= tot;
12316	}
12317
12318	goto L160;
12319	L140:
12320	tot = 0.;
12321
12322	L160:
12323	i_1 = *m;
12324	for (k = 1; k <= i_1; ++k) {
12325	/* .......... NEXT QR TRANSFORMATION .......... */
12326	L180:
12327	tot += s;
12328	delta = w[*n] - s;
12329	i = *n;
12330	f = (d_1 = epslon_(&tot), abs(d_1));
12331	if (*eps1 < f) {
12332	*eps1 = f;
12333	}
12334	if (delta > *eps1) {
12335	goto L190;
12336	}
12337	if (delta < -(*eps1)) {
12338	goto L1000;
12339	}
12340	goto L300;
12341	/* .......... REPLACE SMALL SUB-DIAGONAL SQUARES BY ZERO */
12342	/* TO REDUCE THE INCIDENCE OF UNDERFLOWS .......... */
12343	L190:
12344	if (k == *n) {
12345	goto L210;
12346	}
12347	k1 = k + 1;
12348	i_2 = *n;
12349	for (j = k1; j <= i_2; ++j) {
12350	d_2 = w[j] + w[j - 1];
12351	/* Computing 2nd power */
12352	d_1 = epslon_(&d_2);
12353	if (bd[j] <= d_1 * d_1) {
12354	bd[j] = 0.;
12355	}
12356	/* L200: */
12357	}
12358
12359	L210:
12360	f = bd[*n] / delta;
12361	qp = delta + f;
12362	p = 1.;
12363	if (k == *n) {
12364	goto L260;
12365	}
12366	k1 = *n - k;
12367	/* .......... FOR I=N-1 STEP -1 UNTIL K DO -- .......... */
12368	i_2 = k1;
12369	for (ii = 1; ii <= i_2; ++ii) {
12370	i = *n - ii;
12371	q = w[i] - s - f;
12372	r = q / qp;
12373	p = p * r + 1.;
12374	ep = f * r;
12375	w[i + 1] = qp + ep;
12376	delta = q - ep;
12377	if (delta > *eps1) {
12378	goto L220;
12379	}
12380	if (delta < -(*eps1)) {
12381	goto L1000;
12382	}
12383	goto L300;
12384	L220:
12385	f = bd[i] / q;
12386	qp = delta + f;
12387	bd[i + 1] = qp * ep;
12388	/* L240: */
12389	}
12390
12391	L260:
12392	w[k] = qp;
12393	s = qp / p;
12394	if (tot + s > tot) {
12395	goto L180;
12396	}
12397	/* .......... SET ERROR -- IRREGULAR END OF ITERATION. */
12398	/* DEFLATE MINIMUM DIAGONAL ELEMENT .......... */
12399	ierr = n * 5 + k;
12400	s = 0.;
12401	delta = qp;
12402
12403	i_2 = *n;
12404	for (j = k; j <= i_2; ++j) {
12405	if (w[j] > delta) {
12406	goto L280;
12407	}
12408	i = j;
12409	delta = w[j];
12410	L280:
12411	;
12412	}
12413	/* .......... CONVERGENCE .......... */
12414	L300:
12415	if (i < *n) {
12416	bd[i + 1] = bd[i] * f / qp;
12417	}
12418	ii = ind[i];
12419	if (i == k) {
12420	goto L340;
12421	}
12422	k1 = i - k;
12423	/* .......... FOR J=I-1 STEP -1 UNTIL K DO -- .......... */
12424	i_2 = k1;
12425	for (jj = 1; jj <= i_2; ++jj) {
12426	j = i - jj;
12427	w[j + 1] = w[j] - s;
12428	bd[j + 1] = bd[j];
12429	ind[j + 1] = ind[j];
12430	/* L320: */
12431	}
12432
12433	L340:
12434	w[k] = tot;
12435	err += abs(delta);
12436	bd[k] = err;
12437	ind[k] = ii;
12438	/* L360: */
12439	}
12440
12441	if (*type) {
12442	goto L1001;
12443	}
12444	f = bd[1];
12445	e2[1] = 2.;
12446	bd[1] = f;
12447	j = 2;
12448	/* .......... NEGATE ELEMENTS OF W FOR LARGEST VALUES .......... */
12449	L400:
12450	i_1 = *n;
12451	for (i = 1; i <= i_1; ++i) {
12452	/* L500: */
12453	w[i] = -w[i];
12454	}
12455
12456	jdef = -jdef;
12457	switch (j) {
12458	case 1: goto L40;
12459	case 2: goto L1001;
12460	}
12461	/* .......... SET ERROR -- IDEF SPECIFIED INCORRECTLY .......... */
12462	L1000:
12463	ierr = n * 6 + 1;
12464	L1001:
12465	return 0;
12466	} /* ratqr_ */
12467
12468	/* Subroutine / int rebak_(integer nm, integer n, doublereal b,
12469	doublereal dl, integer m, doublereal *z)
12470	{
12471	/* System generated locals */
12472	integer b_dim1, b_offset, z_dim1, z_offset, i_1, i_2, i_3;
12473
12474	/* Local variables */
12475	static integer i, j, k;
12476	static doublereal x;
12477	static integer i1, ii;
12478
12479
12480
12481	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE REBAKA, */
12482	/* NUM. MATH. 11, 99-110(1968) BY MARTIN AND WILKINSON. */
12483	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971). */
12484
12485	/* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A GENERALIZED */
12486	/* SYMMETRIC EIGENSYSTEM BY BACK TRANSFORMING THOSE OF THE */
12487	/* DERIVED SYMMETRIC MATRIX DETERMINED BY REDUC. */
12488
12489	/* ON INPUT */
12490
12491	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
12492	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
12493	/* DIMENSION STATEMENT. */
12494
12495	/* N IS THE ORDER OF THE MATRIX SYSTEM. */
12496
12497	/* B CONTAINS INFORMATION ABOUT THE SIMILARITY TRANSFORMATION */
12498	/* (CHOLESKY DECOMPOSITION) USED IN THE REDUCTION BY REDUC */
12499	/* IN ITS STRICT LOWER TRIANGLE. */
12500
12501	/* DL CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATION. */
12502
12503	/* M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. */
12504
12505	/* Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED */
12506	/* IN ITS FIRST M COLUMNS. */
12507
12508	/* ON OUTPUT */
12509
12510	/* Z CONTAINS THE TRANSFORMED EIGENVECTORS */
12511	/* IN ITS FIRST M COLUMNS. */
12512
12513	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
12514	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
12515	*/
12516
12517	/* THIS VERSION DATED AUGUST 1983. */
12518
12519	/* ------------------------------------------------------------------
12520	*/
12521
12522	/* Parameter adjustments */
12523	--dl;
12524	b_dim1 = *nm;
12525	b_offset = b_dim1 + 1;
12526	b -= b_offset;
12527	z_dim1 = *nm;
12528	z_offset = z_dim1 + 1;
12529	z -= z_offset;
12530
12531	/* Function Body */
12532	if (*m == 0) {
12533	goto L200;
12534	}
12535
12536	i_1 = *m;
12537	for (j = 1; j <= i_1; ++j) {
12538	/* .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... */
12539	i_2 = *n;
12540	for (ii = 1; ii <= i_2; ++ii) {
12541	i = *n + 1 - ii;
12542	i1 = i + 1;
12543	x = z[i + j * z_dim1];
12544	if (i == *n) {
12545	goto L80;
12546	}
12547
12548	i_3 = *n;
12549	for (k = i1; k <= i_3; ++k) {
12550	/* L60: */
12551	x -= b[k + i * b_dim1] * z[k + j * z_dim1];
12552	}
12553
12554	L80:
12555	z[i + j * z_dim1] = x / dl[i];
12556	/* L100: */
12557	}
12558	}
12559
12560	L200:
12561	return 0;
12562	} /* rebak_ */
12563
12564	/* Subroutine / int rebakb_(integer nm, integer n, doublereal b,
12565	doublereal dl, integer m, doublereal *z)
12566	{
12567	/* System generated locals */
12568	integer b_dim1, b_offset, z_dim1, z_offset, i_1, i_2, i_3;
12569
12570	/* Local variables */
12571	static integer i, j, k;
12572	static doublereal x;
12573	static integer i1, ii;
12574
12575
12576
12577	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE REBAKB, */
12578	/* NUM. MATH. 11, 99-110(1968) BY MARTIN AND WILKINSON. */
12579	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971). */
12580
12581	/* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A GENERALIZED */
12582	/* SYMMETRIC EIGENSYSTEM BY BACK TRANSFORMING THOSE OF THE */
12583	/* DERIVED SYMMETRIC MATRIX DETERMINED BY REDUC2. */
12584
12585	/* ON INPUT */
12586
12587	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
12588	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
12589	/* DIMENSION STATEMENT. */
12590
12591	/* N IS THE ORDER OF THE MATRIX SYSTEM. */
12592
12593	/* B CONTAINS INFORMATION ABOUT THE SIMILARITY TRANSFORMATION */
12594	/* (CHOLESKY DECOMPOSITION) USED IN THE REDUCTION BY REDUC2 */
12595	/* IN ITS STRICT LOWER TRIANGLE. */
12596
12597	/* DL CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATION. */
12598
12599	/* M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. */
12600
12601	/* Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED */
12602	/* IN ITS FIRST M COLUMNS. */
12603
12604	/* ON OUTPUT */
12605
12606	/* Z CONTAINS THE TRANSFORMED EIGENVECTORS */
12607	/* IN ITS FIRST M COLUMNS. */
12608
12609	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
12610	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
12611	*/
12612
12613	/* THIS VERSION DATED AUGUST 1983. */
12614
12615	/* ------------------------------------------------------------------
12616	*/
12617
12618	/* Parameter adjustments */
12619	--dl;
12620	b_dim1 = *nm;
12621	b_offset = b_dim1 + 1;
12622	b -= b_offset;
12623	z_dim1 = *nm;
12624	z_offset = z_dim1 + 1;
12625	z -= z_offset;
12626
12627	/* Function Body */
12628	if (*m == 0) {
12629	goto L200;
12630	}
12631
12632	i_1 = *m;
12633	for (j = 1; j <= i_1; ++j) {
12634	/* .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... */
12635	i_2 = *n;
12636	for (ii = 1; ii <= i_2; ++ii) {
12637	i1 = *n - ii;
12638	i = i1 + 1;
12639	x = dl[i] * z[i + j * z_dim1];
12640	if (i == 1) {
12641	goto L80;
12642	}
12643
12644	i_3 = i1;
12645	for (k = 1; k <= i_3; ++k) {
12646	/* L60: */
12647	x += b[i + k * b_dim1] * z[k + j * z_dim1];
12648	}
12649
12650	L80:
12651	z[i + j * z_dim1] = x;
12652	/* L100: */
12653	}
12654	}
12655
12656	L200:
12657	return 0;
12658	} /* rebakb_ */
12659
12660	/* Subroutine / int reduc_(integer nm, integer n, doublereal a,
12661	doublereal b, doublereal dl, integer *ierr)
12662	{
12663	/* System generated locals */
12664	integer a_dim1, a_offset, b_dim1, b_offset, i_1, i_2, i_3;
12665
12666	/* Builtin functions */
12667	double sqrt(doublereal);
12668
12669	/* Local variables */
12670	static integer i, j, k;
12671	static doublereal x, y;
12672	static integer i1, j1, nn;
12673
12674
12675
12676	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE REDUC1, */
12677	/* NUM. MATH. 11, 99-110(1968) BY MARTIN AND WILKINSON. */
12678	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971). */
12679
12680	/* THIS SUBROUTINE REDUCES THE GENERALIZED SYMMETRIC EIGENPROBLEM */
12681	/* AX=(LAMBDA)BX, WHERE B IS POSITIVE DEFINITE, TO THE STANDARD */
12682	/* SYMMETRIC EIGENPROBLEM USING THE CHOLESKY FACTORIZATION OF B. */
12683
12684	/* ON INPUT */
12685
12686	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
12687	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
12688	/* DIMENSION STATEMENT. */
12689
12690	/* N IS THE ORDER OF THE MATRICES A AND B. IF THE CHOLESKY */
12691	/* FACTOR L OF B IS ALREADY AVAILABLE, N SHOULD BE PREFIXED */
12692	/* WITH A MINUS SIGN. */
12693
12694	/* A AND B CONTAIN THE REAL SYMMETRIC INPUT MATRICES. ONLY THE */
12695	/* FULL UPPER TRIANGLES OF THE MATRICES NEED BE SUPPLIED. IF */
12696	/* N IS NEGATIVE, THE STRICT LOWER TRIANGLE OF B CONTAINS, */
12697	/* INSTEAD, THE STRICT LOWER TRIANGLE OF ITS CHOLESKY FACTOR L.
12698	*/
12699
12700	/* DL CONTAINS, IF N IS NEGATIVE, THE DIAGONAL ELEMENTS OF L. */
12701
12702	/* ON OUTPUT */
12703
12704	/* A CONTAINS IN ITS FULL LOWER TRIANGLE THE FULL LOWER TRIANGLE */
12705	/* OF THE SYMMETRIC MATRIX DERIVED FROM THE REDUCTION TO THE */
12706	/* STANDARD FORM. THE STRICT UPPER TRIANGLE OF A IS UNALTERED.
12707	*/
12708
12709	/* B CONTAINS IN ITS STRICT LOWER TRIANGLE THE STRICT LOWER */
12710	/* TRIANGLE OF ITS CHOLESKY FACTOR L. THE FULL UPPER */
12711	/* TRIANGLE OF B IS UNALTERED. */
12712
12713	/* DL CONTAINS THE DIAGONAL ELEMENTS OF L. */
12714
12715	/* IERR IS SET TO */
12716	/* ZERO FOR NORMAL RETURN, */
12717	/* 7N+1 IF B IS NOT POSITIVE DEFINITE. /
12718
12719	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
12720	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
12721	*/
12722
12723	/* THIS VERSION DATED AUGUST 1983. */
12724
12725	/* ------------------------------------------------------------------
12726	*/
12727
12728	/* Parameter adjustments */
12729	--dl;
12730	b_dim1 = *nm;
12731	b_offset = b_dim1 + 1;
12732	b -= b_offset;
12733	a_dim1 = *nm;
12734	a_offset = a_dim1 + 1;
12735	a -= a_offset;
12736
12737	/* Function Body */
12738	*ierr = 0;
12739	nn = abs(*n);
12740	if (*n < 0) {
12741	goto L100;
12742	}
12743	/* .......... FORM L IN THE ARRAYS B AND DL .......... */
12744	i_1 = *n;
12745	for (i = 1; i <= i_1; ++i) {
12746	i1 = i - 1;
12747
12748	i_2 = *n;
12749	for (j = i; j <= i_2; ++j) {
12750	x = b[i + j * b_dim1];
12751	if (i == 1) {
12752	goto L40;
12753	}
12754
12755	i_3 = i1;
12756	for (k = 1; k <= i_3; ++k) {
12757	/* L20: */
12758	x -= b[i + k * b_dim1] * b[j + k * b_dim1];
12759	}
12760
12761	L40:
12762	if (j != i) {
12763	goto L60;
12764	}
12765	if (x <= 0.) {
12766	goto L1000;
12767	}
12768	y = sqrt(x);
12769	dl[i] = y;
12770	goto L80;
12771	L60:
12772	b[j + i * b_dim1] = x / y;
12773	L80:
12774	;
12775	}
12776	}
12777	/* .......... FORM THE TRANSPOSE OF THE UPPER TRIANGLE OF INV(L)A /
12778	/* IN THE LOWER TRIANGLE OF THE ARRAY A .......... */
12779	L100:
12780	i_2 = nn;
12781	for (i = 1; i <= i_2; ++i) {
12782	i1 = i - 1;
12783	y = dl[i];
12784
12785	i_1 = nn;
12786	for (j = i; j <= i_1; ++j) {
12787	x = a[i + j * a_dim1];
12788	if (i == 1) {
12789	goto L180;
12790	}
12791
12792	i_3 = i1;
12793	for (k = 1; k <= i_3; ++k) {
12794	/* L160: */
12795	x -= b[i + k * b_dim1] * a[j + k * a_dim1];
12796	}
12797
12798	L180:
12799	a[j + i * a_dim1] = x / y;
12800	/* L200: */
12801	}
12802	}
12803	/* .......... PRE-MULTIPLY BY INV(L) AND OVERWRITE .......... */
12804	i_1 = nn;
12805	for (j = 1; j <= i_1; ++j) {
12806	j1 = j - 1;
12807
12808	i_2 = nn;
12809	for (i = j; i <= i_2; ++i) {
12810	x = a[i + j * a_dim1];
12811	if (i == j) {
12812	goto L240;
12813	}
12814	i1 = i - 1;
12815
12816	i_3 = i1;
12817	for (k = j; k <= i_3; ++k) {
12818	/* L220: */
12819	x -= a[k + j * a_dim1] * b[i + k * b_dim1];
12820	}
12821
12822	L240:
12823	if (j == 1) {
12824	goto L280;
12825	}
12826
12827	i_3 = j1;
12828	for (k = 1; k <= i_3; ++k) {
12829	/* L260: */
12830	x -= a[j + k * a_dim1] * b[i + k * b_dim1];
12831	}
12832
12833	L280:
12834	a[i + j * a_dim1] = x / dl[i];
12835	/* L300: */
12836	}
12837	}
12838
12839	goto L1001;
12840	/* .......... SET ERROR -- B IS NOT POSITIVE DEFINITE .......... */
12841	L1000:
12842	ierr = n * 7 + 1;
12843	L1001:
12844	return 0;
12845	} /* reduc_ */
12846
12847	/* Subroutine / int reduc2_(integer nm, integer n, doublereal a,
12848	doublereal b, doublereal dl, integer *ierr)
12849	{
12850	/* System generated locals */
12851	integer a_dim1, a_offset, b_dim1, b_offset, i_1, i_2, i_3;
12852
12853	/* Builtin functions */
12854	double sqrt(doublereal);
12855
12856	/* Local variables */
12857	static integer i, j, k;
12858	static doublereal x, y;
12859	static integer i1, j1, nn;
12860
12861
12862
12863	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE REDUC2, */
12864	/* NUM. MATH. 11, 99-110(1968) BY MARTIN AND WILKINSON. */
12865	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971). */
12866
12867	/* THIS SUBROUTINE REDUCES THE GENERALIZED SYMMETRIC EIGENPROBLEMS */
12868	/* ABX=(LAMBDA)X OR BAY=(LAMBDA)Y, WHERE B IS POSITIVE DEFINITE, */
12869	/* TO THE STANDARD SYMMETRIC EIGENPROBLEM USING THE CHOLESKY */
12870	/* FACTORIZATION OF B. */
12871
12872	/* ON INPUT */
12873
12874	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
12875	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
12876	/* DIMENSION STATEMENT. */
12877
12878	/* N IS THE ORDER OF THE MATRICES A AND B. IF THE CHOLESKY */
12879	/* FACTOR L OF B IS ALREADY AVAILABLE, N SHOULD BE PREFIXED */
12880	/* WITH A MINUS SIGN. */
12881
12882	/* A AND B CONTAIN THE REAL SYMMETRIC INPUT MATRICES. ONLY THE */
12883	/* FULL UPPER TRIANGLES OF THE MATRICES NEED BE SUPPLIED. IF */
12884	/* N IS NEGATIVE, THE STRICT LOWER TRIANGLE OF B CONTAINS, */
12885	/* INSTEAD, THE STRICT LOWER TRIANGLE OF ITS CHOLESKY FACTOR L.
12886	*/
12887
12888	/* DL CONTAINS, IF N IS NEGATIVE, THE DIAGONAL ELEMENTS OF L. */
12889
12890	/* ON OUTPUT */
12891
12892	/* A CONTAINS IN ITS FULL LOWER TRIANGLE THE FULL LOWER TRIANGLE */
12893	/* OF THE SYMMETRIC MATRIX DERIVED FROM THE REDUCTION TO THE */
12894	/* STANDARD FORM. THE STRICT UPPER TRIANGLE OF A IS UNALTERED.
12895	*/
12896
12897	/* B CONTAINS IN ITS STRICT LOWER TRIANGLE THE STRICT LOWER */
12898	/* TRIANGLE OF ITS CHOLESKY FACTOR L. THE FULL UPPER */
12899	/* TRIANGLE OF B IS UNALTERED. */
12900
12901	/* DL CONTAINS THE DIAGONAL ELEMENTS OF L. */
12902
12903	/* IERR IS SET TO */
12904	/* ZERO FOR NORMAL RETURN, */
12905	/* 7N+1 IF B IS NOT POSITIVE DEFINITE. /
12906
12907	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
12908	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
12909	*/
12910
12911	/* THIS VERSION DATED AUGUST 1983. */
12912
12913	/* ------------------------------------------------------------------
12914	*/
12915
12916	/* Parameter adjustments */
12917	--dl;
12918	b_dim1 = *nm;
12919	b_offset = b_dim1 + 1;
12920	b -= b_offset;
12921	a_dim1 = *nm;
12922	a_offset = a_dim1 + 1;
12923	a -= a_offset;
12924
12925	/* Function Body */
12926	*ierr = 0;
12927	nn = abs(*n);
12928	if (*n < 0) {
12929	goto L100;
12930	}
12931	/* .......... FORM L IN THE ARRAYS B AND DL .......... */
12932	i_1 = *n;
12933	for (i = 1; i <= i_1; ++i) {
12934	i1 = i - 1;
12935
12936	i_2 = *n;
12937	for (j = i; j <= i_2; ++j) {
12938	x = b[i + j * b_dim1];
12939	if (i == 1) {
12940	goto L40;
12941	}
12942
12943	i_3 = i1;
12944	for (k = 1; k <= i_3; ++k) {
12945	/* L20: */
12946	x -= b[i + k * b_dim1] * b[j + k * b_dim1];
12947	}
12948
12949	L40:
12950	if (j != i) {
12951	goto L60;
12952	}
12953	if (x <= 0.) {
12954	goto L1000;
12955	}
12956	y = sqrt(x);
12957	dl[i] = y;
12958	goto L80;
12959	L60:
12960	b[j + i * b_dim1] = x / y;
12961	L80:
12962	;
12963	}
12964	}
12965	/* .......... FORM THE LOWER TRIANGLE OF AL /
12966	/* IN THE LOWER TRIANGLE OF THE ARRAY A .......... */
12967	L100:
12968	i_2 = nn;
12969	for (i = 1; i <= i_2; ++i) {
12970	i1 = i + 1;
12971
12972	i_1 = i;
12973	for (j = 1; j <= i_1; ++j) {
12974	x = a[j + i * a_dim1] * dl[j];
12975	if (j == i) {
12976	goto L140;
12977	}
12978	j1 = j + 1;
12979
12980	i_3 = i;
12981	for (k = j1; k <= i_3; ++k) {
12982	/* L120: */
12983	x += a[k + i * a_dim1] * b[k + j * b_dim1];
12984	}
12985
12986	L140:
12987	if (i == nn) {
12988	goto L180;
12989	}
12990
12991	i_3 = nn;
12992	for (k = i1; k <= i_3; ++k) {
12993	/* L160: */
12994	x += a[i + k * a_dim1] * b[k + j * b_dim1];
12995	}
12996
12997	L180:
12998	a[i + j * a_dim1] = x;
12999	/* L200: */
13000	}
13001	}
13002	/* .......... PRE-MULTIPLY BY TRANSPOSE(L) AND OVERWRITE .......... */
13003	i_1 = nn;
13004	for (i = 1; i <= i_1; ++i) {
13005	i1 = i + 1;
13006	y = dl[i];
13007
13008	i_2 = i;
13009	for (j = 1; j <= i_2; ++j) {
13010	x = y * a[i + j * a_dim1];
13011	if (i == nn) {
13012	goto L280;
13013	}
13014
13015	i_3 = nn;
13016	for (k = i1; k <= i_3; ++k) {
13017	/* L260: */
13018	x += a[k + j * a_dim1] * b[k + i * b_dim1];
13019	}
13020
13021	L280:
13022	a[i + j * a_dim1] = x;
13023	/* L300: */
13024	}
13025	}
13026
13027	goto L1001;
13028	/* .......... SET ERROR -- B IS NOT POSITIVE DEFINITE .......... */
13029	L1000:
13030	ierr = n * 7 + 1;
13031	L1001:
13032	return 0;
13033	} /* reduc2_ */
13034
13035	/* Subroutine / int rg_(integer nm, integer n, doublereal a, doublereal *
13036	wr, doublereal wi, integer matz, doublereal z, integer iv1,
13037	doublereal fv1, integer ierr)
13038	{
13039	/* System generated locals */
13040	integer a_dim1, a_offset, z_dim1, z_offset;
13041
13042	/* Local variables */
13043	extern /* Subroutine / int balbak_(integer , integer , integer ,
13044	integer , doublereal , integer , doublereal ), balanc_(
13045	integer , integer , doublereal , integer , integer *,
13046	doublereal ), elmhes_(integer , integer , integer , integer *,
13047	doublereal , integer ), eltran_(integer , integer , integer *
13048	, integer , doublereal , integer , doublereal );
13049	static integer is1, is2;
13050	extern /* Subroutine / int hqr_(integer , integer , integer , integer
13051	, doublereal , doublereal , doublereal , integer *), hqr2_(
13052	integer , integer , integer , integer , doublereal *,
13053	doublereal , doublereal , doublereal , integer );
13054
13055
13056
13057	/* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */
13058	/* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */
13059	/* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */
13060	/* OF A REAL GENERAL MATRIX. */
13061
13062	/* ON INPUT */
13063
13064	/* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */
13065	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
13066	/* DIMENSION STATEMENT. */
13067
13068	/* N IS THE ORDER OF THE MATRIX A. */
13069
13070	/* A CONTAINS THE REAL GENERAL MATRIX. */
13071
13072	/* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */
13073	/* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */
13074	/* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */
13075
13076	/* ON OUTPUT */
13077
13078	/* WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, */
13079	/* RESPECTIVELY, OF THE EIGENVALUES. COMPLEX CONJUGATE */
13080	/* PAIRS OF EIGENVALUES APPEAR CONSECUTIVELY WITH THE */
13081	/* EIGENVALUE HAVING THE POSITIVE IMAGINARY PART FIRST. */
13082
13083	/* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS */
13084	/* IF MATZ IS NOT ZERO. IF THE J-TH EIGENVALUE IS REAL, THE */
13085	/* J-TH COLUMN OF Z CONTAINS ITS EIGENVECTOR. IF THE J-TH */
13086	/* EIGENVALUE IS COMPLEX WITH POSITIVE IMAGINARY PART, THE */
13087	/* J-TH AND (J+1)-TH COLUMNS OF Z CONTAIN THE REAL AND */
13088	/* IMAGINARY PARTS OF ITS EIGENVECTOR. THE CONJUGATE OF THIS */
13089	/* VECTOR IS THE EIGENVECTOR FOR THE CONJUGATE EIGENVALUE. */
13090
13091	/* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */
13092	/* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR HQR */
13093	/* AND HQR2. THE NORMAL COMPLETION CODE IS ZERO. */
13094
13095	/* IV1 AND FV1 ARE TEMPORARY STORAGE ARRAYS. */
13096
13097	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
13098	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
13099	*/
13100
13101	/* THIS VERSION DATED AUGUST 1983. */
13102
13103	/* ------------------------------------------------------------------
13104	*/
13105
13106	/* Parameter adjustments */
13107	--fv1;
13108	--iv1;
13109	z_dim1 = *nm;
13110	z_offset = z_dim1 + 1;
13111	z -= z_offset;
13112	--wi;
13113	--wr;
13114	a_dim1 = *nm;
13115	a_offset = a_dim1 + 1;
13116	a -= a_offset;
13117
13118	/* Function Body */
13119	if (n <= nm) {
13120	goto L10;
13121	}
13122	ierr = n * 10;
13123	goto L50;
13124
13125	L10:
13126	balanc_(nm, n, &a[a_offset], &is1, &is2, &fv1[1]);
13127	elmhes_(nm, n, &is1, &is2, &a[a_offset], &iv1[1]);
13128	if (*matz != 0) {
13129	goto L20;
13130	}
13131	/* .......... FIND EIGENVALUES ONLY .......... */
13132	hqr_(nm, n, &is1, &is2, &a[a_offset], &wr[1], &wi[1], ierr);
13133	goto L50;
13134	/* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */
13135	L20:
13136	eltran_(nm, n, &is1, &is2, &a[a_offset], &iv1[1], &z[z_offset]);
13137	hqr2_(nm, n, &is1, &is2, &a[a_offset], &wr[1], &wi[1], &z[z_offset], ierr)
13138	;
13139	if (*ierr != 0) {
13140	goto L50;
13141	}
13142	balbak_(nm, n, &is1, &is2, &fv1[1], n, &z[z_offset]);
13143	L50:
13144	return 0;
13145	} /* rg_ */
13146
13147	/* Subroutine / int rgg_(integer nm, integer n, doublereal a, doublereal *
13148	b, doublereal alfr, doublereal alfi, doublereal beta, integer
13149	matz, doublereal z, integer ierr)
13150	{
13151	/* System generated locals */
13152	integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset;
13153
13154	/* Local variables */
13155	extern /* Subroutine / int qzit_(integer , integer , doublereal ,
13156	doublereal , doublereal , logical , doublereal , integer *),
13157	qzvec_(integer , integer , doublereal , doublereal ,
13158	doublereal , doublereal , doublereal , doublereal ), qzhes_(
13159	integer , integer , doublereal , doublereal , logical *,
13160	doublereal ), qzval_(integer , integer , doublereal ,
13161	doublereal , doublereal , doublereal , doublereal , logical *,
13162	doublereal *);
13163	static logical tf;
13164
13165
13166
13167	/* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */
13168	/* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */
13169	/* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */
13170	/* FOR THE REAL GENERAL GENERALIZED EIGENPROBLEM AX = (LAMBDA)BX. */
13171
13172	/* ON INPUT */
13173
13174	/* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */
13175	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
13176	/* DIMENSION STATEMENT. */
13177
13178	/* N IS THE ORDER OF THE MATRICES A AND B. */
13179
13180	/* A CONTAINS A REAL GENERAL MATRIX. */
13181
13182	/* B CONTAINS A REAL GENERAL MATRIX. */
13183
13184	/* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */
13185	/* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */
13186	/* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */
13187
13188	/* ON OUTPUT */
13189
13190	/* ALFR AND ALFI CONTAIN THE REAL AND IMAGINARY PARTS, */
13191	/* RESPECTIVELY, OF THE NUMERATORS OF THE EIGENVALUES. */
13192
13193	/* BETA CONTAINS THE DENOMINATORS OF THE EIGENVALUES, */
13194	/* WHICH ARE THUS GIVEN BY THE RATIOS (ALFR+IALFI)/BETA. /
13195	/* COMPLEX CONJUGATE PAIRS OF EIGENVALUES APPEAR CONSECUTIVELY */
13196	/* WITH THE EIGENVALUE HAVING THE POSITIVE IMAGINARY PART FIRST. */
13197
13198	/* Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS */
13199	/* IF MATZ IS NOT ZERO. IF THE J-TH EIGENVALUE IS REAL, THE */
13200	/* J-TH COLUMN OF Z CONTAINS ITS EIGENVECTOR. IF THE J-TH */
13201	/* EIGENVALUE IS COMPLEX WITH POSITIVE IMAGINARY PART, THE */
13202	/* J-TH AND (J+1)-TH COLUMNS OF Z CONTAIN THE REAL AND */
13203	/* IMAGINARY PARTS OF ITS EIGENVECTOR. THE CONJUGATE OF THIS */
13204	/* VECTOR IS THE EIGENVECTOR FOR THE CONJUGATE EIGENVALUE. */
13205
13206	/* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */
13207	/* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR QZIT. */
13208	/* THE NORMAL COMPLETION CODE IS ZERO. */
13209
13210	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
13211	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
13212	*/
13213
13214	/* THIS VERSION DATED AUGUST 1983. */
13215
13216	/* ------------------------------------------------------------------
13217	*/
13218
13219	/* Parameter adjustments */
13220	z_dim1 = *nm;
13221	z_offset = z_dim1 + 1;
13222	z -= z_offset;
13223	--beta;
13224	--alfi;
13225	--alfr;
13226	b_dim1 = *nm;
13227	b_offset = b_dim1 + 1;
13228	b -= b_offset;
13229	a_dim1 = *nm;
13230	a_offset = a_dim1 + 1;
13231	a -= a_offset;
13232
13233	/* Function Body */
13234	if (n <= nm) {
13235	goto L10;
13236	}
13237	ierr = n * 10;
13238	goto L50;
13239
13240	L10:
13241	if (*matz != 0) {
13242	goto L20;
13243	}
13244	/* .......... FIND EIGENVALUES ONLY .......... */
13245	tf = FALSE_;
13246	qzhes_(nm, n, &a[a_offset], &b[b_offset], &tf, &z[z_offset]);
13247	qzit_(nm, n, &a[a_offset], &b[b_offset], &c_b550, &tf, &z[z_offset], ierr)
13248	;
13249	qzval_(nm, n, &a[a_offset], &b[b_offset], &alfr[1], &alfi[1], &beta[1], &
13250	tf, &z[z_offset]);
13251	goto L50;
13252	/* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */
13253	L20:
13254	tf = TRUE_;
13255	qzhes_(nm, n, &a[a_offset], &b[b_offset], &tf, &z[z_offset]);
13256	qzit_(nm, n, &a[a_offset], &b[b_offset], &c_b550, &tf, &z[z_offset], ierr)
13257	;
13258	qzval_(nm, n, &a[a_offset], &b[b_offset], &alfr[1], &alfi[1], &beta[1], &
13259	tf, &z[z_offset]);
13260	if (*ierr != 0) {
13261	goto L50;
13262	}
13263	qzvec_(nm, n, &a[a_offset], &b[b_offset], &alfr[1], &alfi[1], &beta[1], &
13264	z[z_offset]);
13265	L50:
13266	return 0;
13267	} /* rgg_ */
13268
13269	/* Subroutine / int rs_(integer nm, integer n, doublereal a, doublereal *
13270	w, integer matz, doublereal z, doublereal fv1, doublereal fv2,
13271	integer *ierr)
13272	{
13273	/* System generated locals */
13274	integer a_dim1, a_offset, z_dim1, z_offset;
13275
13276	/* Local variables */
13277	extern /* Subroutine / int tred1_(integer , integer , doublereal ,
13278	doublereal , doublereal , doublereal ), tred2_(integer ,
13279	integer , doublereal , doublereal , doublereal , doublereal *)
13280	, tqlrat_(integer , doublereal , doublereal , integer ),
13281	tql2_(integer , integer , doublereal , doublereal ,
13282	doublereal , integer );
13283
13284
13285
13286	/* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */
13287	/* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */
13288	/* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */
13289	/* OF A REAL SYMMETRIC MATRIX. */
13290
13291	/* ON INPUT */
13292
13293	/* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */
13294	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
13295	/* DIMENSION STATEMENT. */
13296
13297	/* N IS THE ORDER OF THE MATRIX A. */
13298
13299	/* A CONTAINS THE REAL SYMMETRIC MATRIX. */
13300
13301	/* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */
13302	/* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */
13303	/* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */
13304
13305	/* ON OUTPUT */
13306
13307	/* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */
13308
13309	/* Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. */
13310
13311	/* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */
13312	/* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT */
13313	/* AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. */
13314
13315	/* FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS. */
13316
13317	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
13318	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
13319	*/
13320
13321	/* THIS VERSION DATED AUGUST 1983. */
13322
13323	/* ------------------------------------------------------------------
13324	*/
13325
13326	/* Parameter adjustments */
13327	--fv2;
13328	--fv1;
13329	z_dim1 = *nm;
13330	z_offset = z_dim1 + 1;
13331	z -= z_offset;
13332	--w;
13333	a_dim1 = *nm;
13334	a_offset = a_dim1 + 1;
13335	a -= a_offset;
13336
13337	/* Function Body */
13338	if (n <= nm) {
13339	goto L10;
13340	}
13341	ierr = n * 10;
13342	goto L50;
13343
13344	L10:
13345	if (*matz != 0) {
13346	goto L20;
13347	}
13348	/* .......... FIND EIGENVALUES ONLY .......... */
13349	tred1_(nm, n, &a[a_offset], &w[1], &fv1[1], &fv2[1]);
13350	tqlrat_(n, &w[1], &fv2[1], ierr);
13351	goto L50;
13352	/* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */
13353	L20:
13354	tred2_(nm, n, &a[a_offset], &w[1], &fv1[1], &z[z_offset]);
13355	tql2_(nm, n, &w[1], &fv1[1], &z[z_offset], ierr);
13356	L50:
13357	return 0;
13358	} /* rs_ */
13359
13360	/* Subroutine / int rsb_(integer nm, integer n, integer mb, doublereal *a,
13361	doublereal w, integer matz, doublereal z, doublereal fv1,
13362	doublereal fv2, integer ierr)
13363	{
13364	/* System generated locals */
13365	integer a_dim1, a_offset, z_dim1, z_offset;
13366
13367	/* Local variables */
13368	extern /* Subroutine / int bandr_(integer , integer , integer ,
13369	doublereal , doublereal , doublereal , doublereal , logical *,
13370	doublereal *);
13371	static logical tf;
13372	extern /* Subroutine / int tqlrat_(integer , doublereal , doublereal ,
13373	integer ), tql2_(integer , integer , doublereal , doublereal
13374	, doublereal , integer *);
13375
13376
13377
13378	/* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */
13379	/* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */
13380	/* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */
13381	/* OF A REAL SYMMETRIC BAND MATRIX. */
13382
13383	/* ON INPUT */
13384
13385	/* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */
13386	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
13387	/* DIMENSION STATEMENT. */
13388
13389	/* N IS THE ORDER OF THE MATRIX A. */
13390
13391	/* MB IS THE HALF BAND WIDTH OF THE MATRIX, DEFINED AS THE */
13392	/* NUMBER OF ADJACENT DIAGONALS, INCLUDING THE PRINCIPAL */
13393	/* DIAGONAL, REQUIRED TO SPECIFY THE NON-ZERO PORTION OF THE */
13394	/* LOWER TRIANGLE OF THE MATRIX. */
13395
13396	/* A CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC */
13397	/* BAND MATRIX. ITS LOWEST SUBDIAGONAL IS STORED IN THE */
13398	/* LAST N+1-MB POSITIONS OF THE FIRST COLUMN, ITS NEXT */
13399	/* SUBDIAGONAL IN THE LAST N+2-MB POSITIONS OF THE */
13400	/* SECOND COLUMN, FURTHER SUBDIAGONALS SIMILARLY, AND */
13401	/* FINALLY ITS PRINCIPAL DIAGONAL IN THE N POSITIONS */
13402	/* OF THE LAST COLUMN. CONTENTS OF STORAGES NOT PART */
13403	/* OF THE MATRIX ARE ARBITRARY. */
13404
13405	/* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */
13406	/* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */
13407	/* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */
13408
13409	/* ON OUTPUT */
13410
13411	/* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */
13412
13413	/* Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. */
13414
13415	/* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */
13416	/* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT */
13417	/* AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. */
13418
13419	/* FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS. */
13420
13421	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
13422	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
13423	*/
13424
13425	/* THIS VERSION DATED AUGUST 1983. */
13426
13427	/* ------------------------------------------------------------------
13428	*/
13429
13430	/* Parameter adjustments */
13431	--fv2;
13432	--fv1;
13433	z_dim1 = *nm;
13434	z_offset = z_dim1 + 1;
13435	z -= z_offset;
13436	--w;
13437	a_dim1 = *nm;
13438	a_offset = a_dim1 + 1;
13439	a -= a_offset;
13440
13441	/* Function Body */
13442	if (n <= nm) {
13443	goto L5;
13444	}
13445	ierr = n * 10;
13446	goto L50;
13447	L5:
13448	if (*mb > 0) {
13449	goto L10;
13450	}
13451	ierr = n * 12;
13452	goto L50;
13453	L10:
13454	if (mb <= n) {
13455	goto L15;
13456	}
13457	ierr = n * 12;
13458	goto L50;
13459
13460	L15:
13461	if (*matz != 0) {
13462	goto L20;
13463	}
13464	/* .......... FIND EIGENVALUES ONLY .......... */
13465	tf = FALSE_;
13466	bandr_(nm, n, mb, &a[a_offset], &w[1], &fv1[1], &fv2[1], &tf, &z[z_offset]
13467	);
13468	tqlrat_(n, &w[1], &fv2[1], ierr);
13469	goto L50;
13470	/* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */
13471	L20:
13472	tf = TRUE_;
13473	bandr_(nm, n, mb, &a[a_offset], &w[1], &fv1[1], &fv1[1], &tf, &z[z_offset]
13474	);
13475	tql2_(nm, n, &w[1], &fv1[1], &z[z_offset], ierr);
13476	L50:
13477	return 0;
13478	} /* rsb_ */
13479
13480	/* Subroutine / int rsg_(integer nm, integer n, doublereal a, doublereal *
13481	b, doublereal w, integer matz, doublereal z, doublereal fv1,
13482	doublereal fv2, integer ierr)
13483	{
13484	/* System generated locals */
13485	integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset;
13486
13487	/* Local variables */
13488	extern /* Subroutine / int tred1_(integer , integer , doublereal ,
13489	doublereal , doublereal , doublereal ), tred2_(integer ,
13490	integer , doublereal , doublereal , doublereal , doublereal *)
13491	, rebak_(integer , integer , doublereal , doublereal ,
13492	integer , doublereal ), reduc_(integer , integer , doublereal
13493	, doublereal , doublereal , integer ), tqlrat_(integer *,
13494	doublereal , doublereal , integer ), tql2_(integer , integer *
13495	, doublereal , doublereal , doublereal , integer );
13496
13497
13498
13499	/* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */
13500	/* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */
13501	/* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */
13502	/* FOR THE REAL SYMMETRIC GENERALIZED EIGENPROBLEM AX = (LAMBDA)BX.
13503	*/
13504
13505	/* ON INPUT */
13506
13507	/* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */
13508	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
13509	/* DIMENSION STATEMENT. */
13510
13511	/* N IS THE ORDER OF THE MATRICES A AND B. */
13512
13513	/* A CONTAINS A REAL SYMMETRIC MATRIX. */
13514
13515	/* B CONTAINS A POSITIVE DEFINITE REAL SYMMETRIC MATRIX. */
13516
13517	/* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */
13518	/* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */
13519	/* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */
13520
13521	/* ON OUTPUT */
13522
13523	/* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */
13524
13525	/* Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. */
13526
13527	/* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */
13528	/* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT */
13529	/* AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. */
13530
13531	/* FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS. */
13532
13533	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
13534	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
13535	*/
13536
13537	/* THIS VERSION DATED AUGUST 1983. */
13538
13539	/* ------------------------------------------------------------------
13540	*/
13541
13542	/* Parameter adjustments */
13543	--fv2;
13544	--fv1;
13545	z_dim1 = *nm;
13546	z_offset = z_dim1 + 1;
13547	z -= z_offset;
13548	--w;
13549	b_dim1 = *nm;
13550	b_offset = b_dim1 + 1;
13551	b -= b_offset;
13552	a_dim1 = *nm;
13553	a_offset = a_dim1 + 1;
13554	a -= a_offset;
13555
13556	/* Function Body */
13557	if (n <= nm) {
13558	goto L10;
13559	}
13560	ierr = n * 10;
13561	goto L50;
13562
13563	L10:
13564	reduc_(nm, n, &a[a_offset], &b[b_offset], &fv2[1], ierr);
13565	if (*ierr != 0) {
13566	goto L50;
13567	}
13568	if (*matz != 0) {
13569	goto L20;
13570	}
13571	/* .......... FIND EIGENVALUES ONLY .......... */
13572	tred1_(nm, n, &a[a_offset], &w[1], &fv1[1], &fv2[1]);
13573	tqlrat_(n, &w[1], &fv2[1], ierr);
13574	goto L50;
13575	/* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */
13576	L20:
13577	tred2_(nm, n, &a[a_offset], &w[1], &fv1[1], &z[z_offset]);
13578	tql2_(nm, n, &w[1], &fv1[1], &z[z_offset], ierr);
13579	if (*ierr != 0) {
13580	goto L50;
13581	}
13582	rebak_(nm, n, &b[b_offset], &fv2[1], n, &z[z_offset]);
13583	L50:
13584	return 0;
13585	} /* rsg_ */
13586
13587	/* Subroutine / int rsgab_(integer nm, integer n, doublereal a,
13588	doublereal b, doublereal w, integer matz, doublereal z,
13589	doublereal fv1, doublereal fv2, integer *ierr)
13590	{
13591	/* System generated locals */
13592	integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset;
13593
13594	/* Local variables */
13595	extern /* Subroutine / int tred1_(integer , integer , doublereal ,
13596	doublereal , doublereal , doublereal ), tred2_(integer ,
13597	integer , doublereal , doublereal , doublereal , doublereal *)
13598	, rebak_(integer , integer , doublereal , doublereal ,
13599	integer , doublereal ), reduc2_(integer , integer ,
13600	doublereal , doublereal , doublereal , integer ), tqlrat_(
13601	integer , doublereal , doublereal , integer ), tql2_(integer *
13602	, integer , doublereal , doublereal , doublereal , integer *);
13603
13604
13605
13606	/* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */
13607	/* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */
13608	/* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */
13609	/* FOR THE REAL SYMMETRIC GENERALIZED EIGENPROBLEM ABX = (LAMBDA)X.
13610	*/
13611
13612	/* ON INPUT */
13613
13614	/* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */
13615	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
13616	/* DIMENSION STATEMENT. */
13617
13618	/* N IS THE ORDER OF THE MATRICES A AND B. */
13619
13620	/* A CONTAINS A REAL SYMMETRIC MATRIX. */
13621
13622	/* B CONTAINS A POSITIVE DEFINITE REAL SYMMETRIC MATRIX. */
13623
13624	/* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */
13625	/* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */
13626	/* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */
13627
13628	/* ON OUTPUT */
13629
13630	/* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */
13631
13632	/* Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. */
13633
13634	/* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */
13635	/* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT */
13636	/* AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. */
13637
13638	/* FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS. */
13639
13640	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
13641	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
13642	*/
13643
13644	/* THIS VERSION DATED AUGUST 1983. */
13645
13646	/* ------------------------------------------------------------------
13647	*/
13648
13649	/* Parameter adjustments */
13650	--fv2;
13651	--fv1;
13652	z_dim1 = *nm;
13653	z_offset = z_dim1 + 1;
13654	z -= z_offset;
13655	--w;
13656	b_dim1 = *nm;
13657	b_offset = b_dim1 + 1;
13658	b -= b_offset;
13659	a_dim1 = *nm;
13660	a_offset = a_dim1 + 1;
13661	a -= a_offset;
13662
13663	/* Function Body */
13664	if (n <= nm) {
13665	goto L10;
13666	}
13667	ierr = n * 10;
13668	goto L50;
13669
13670	L10:
13671	reduc2_(nm, n, &a[a_offset], &b[b_offset], &fv2[1], ierr);
13672	if (*ierr != 0) {
13673	goto L50;
13674	}
13675	if (*matz != 0) {
13676	goto L20;
13677	}
13678	/* .......... FIND EIGENVALUES ONLY .......... */
13679	tred1_(nm, n, &a[a_offset], &w[1], &fv1[1], &fv2[1]);
13680	tqlrat_(n, &w[1], &fv2[1], ierr);
13681	goto L50;
13682	/* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */
13683	L20:
13684	tred2_(nm, n, &a[a_offset], &w[1], &fv1[1], &z[z_offset]);
13685	tql2_(nm, n, &w[1], &fv1[1], &z[z_offset], ierr);
13686	if (*ierr != 0) {
13687	goto L50;
13688	}
13689	rebak_(nm, n, &b[b_offset], &fv2[1], n, &z[z_offset]);
13690	L50:
13691	return 0;
13692	} /* rsgab_ */
13693
13694	/* Subroutine / int rsgba_(integer nm, integer n, doublereal a,
13695	doublereal b, doublereal w, integer matz, doublereal z,
13696	doublereal fv1, doublereal fv2, integer *ierr)
13697	{
13698	/* System generated locals */
13699	integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset;
13700
13701	/* Local variables */
13702	extern /* Subroutine / int tred1_(integer , integer , doublereal ,
13703	doublereal , doublereal , doublereal ), tred2_(integer ,
13704	integer , doublereal , doublereal , doublereal , doublereal *)
13705	, reduc2_(integer , integer , doublereal , doublereal ,
13706	doublereal , integer ), rebakb_(integer , integer ,
13707	doublereal , doublereal , integer , doublereal ), tqlrat_(
13708	integer , doublereal , doublereal , integer ), tql2_(integer *
13709	, integer , doublereal , doublereal , doublereal , integer *);
13710
13711
13712
13713	/* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */
13714	/* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */
13715	/* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */
13716	/* FOR THE REAL SYMMETRIC GENERALIZED EIGENPROBLEM BAX = (LAMBDA)X.
13717	*/
13718
13719	/* ON INPUT */
13720
13721	/* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */
13722	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
13723	/* DIMENSION STATEMENT. */
13724
13725	/* N IS THE ORDER OF THE MATRICES A AND B. */
13726
13727	/* A CONTAINS A REAL SYMMETRIC MATRIX. */
13728
13729	/* B CONTAINS A POSITIVE DEFINITE REAL SYMMETRIC MATRIX. */
13730
13731	/* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */
13732	/* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */
13733	/* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */
13734
13735	/* ON OUTPUT */
13736
13737	/* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */
13738
13739	/* Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. */
13740
13741	/* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */
13742	/* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT */
13743	/* AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. */
13744
13745	/* FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS. */
13746
13747	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
13748	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
13749	*/
13750
13751	/* THIS VERSION DATED AUGUST 1983. */
13752
13753	/* ------------------------------------------------------------------
13754	*/
13755
13756	/* Parameter adjustments */
13757	--fv2;
13758	--fv1;
13759	z_dim1 = *nm;
13760	z_offset = z_dim1 + 1;
13761	z -= z_offset;
13762	--w;
13763	b_dim1 = *nm;
13764	b_offset = b_dim1 + 1;
13765	b -= b_offset;
13766	a_dim1 = *nm;
13767	a_offset = a_dim1 + 1;
13768	a -= a_offset;
13769
13770	/* Function Body */
13771	if (n <= nm) {
13772	goto L10;
13773	}
13774	ierr = n * 10;
13775	goto L50;
13776
13777	L10:
13778	reduc2_(nm, n, &a[a_offset], &b[b_offset], &fv2[1], ierr);
13779	if (*ierr != 0) {
13780	goto L50;
13781	}
13782	if (*matz != 0) {
13783	goto L20;
13784	}
13785	/* .......... FIND EIGENVALUES ONLY .......... */
13786	tred1_(nm, n, &a[a_offset], &w[1], &fv1[1], &fv2[1]);
13787	tqlrat_(n, &w[1], &fv2[1], ierr);
13788	goto L50;
13789	/* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */
13790	L20:
13791	tred2_(nm, n, &a[a_offset], &w[1], &fv1[1], &z[z_offset]);
13792	tql2_(nm, n, &w[1], &fv1[1], &z[z_offset], ierr);
13793	if (*ierr != 0) {
13794	goto L50;
13795	}
13796	rebakb_(nm, n, &b[b_offset], &fv2[1], n, &z[z_offset]);
13797	L50:
13798	return 0;
13799	} /* rsgba_ */
13800
13801	/* Subroutine / int rsm_(integer nm, integer n, doublereal a, doublereal *
13802	w, integer m, doublereal z, doublereal fwork, integer iwork,
13803	integer *ierr)
13804	{
13805	/* System generated locals */
13806	integer a_dim1, a_offset, z_dim1, z_offset;
13807
13808	/* Local variables */
13809	extern /* Subroutine / int tred1_(integer , integer , doublereal ,
13810	doublereal , doublereal , doublereal *);
13811	static integer k1, k2, k3, k4, k5, k6, k7, k8;
13812	extern /* Subroutine / int trbak1_(integer , integer , doublereal ,
13813	doublereal , integer , doublereal ), tqlrat_(integer ,
13814	doublereal , doublereal , integer ), imtqlv_(integer ,
13815	doublereal , doublereal , doublereal , doublereal , integer *,
13816	integer , doublereal ), tinvit_(integer , integer ,
13817	doublereal , doublereal , doublereal , integer , doublereal *,
13818	integer , doublereal , integer , doublereal , doublereal *,
13819	doublereal , doublereal , doublereal *);
13820
13821
13822
13823	/* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */
13824	/* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */
13825	/* TO FIND ALL OF THE EIGENVALUES AND SOME OF THE EIGENVECTORS */
13826	/* OF A REAL SYMMETRIC MATRIX. */
13827
13828	/* ON INPUT */
13829
13830	/* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */
13831	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
13832	/* DIMENSION STATEMENT. */
13833
13834	/* N IS THE ORDER OF THE MATRIX A. */
13835
13836	/* A CONTAINS THE REAL SYMMETRIC MATRIX. */
13837
13838	/* M THE EIGENVECTORS CORRESPONDING TO THE FIRST M EIGENVALUES */
13839	/* ARE TO BE COMPUTED. */
13840	/* IF M = 0 THEN NO EIGENVECTORS ARE COMPUTED. */
13841	/* IF M = N THEN ALL OF THE EIGENVECTORS ARE COMPUTED. */
13842
13843	/* ON OUTPUT */
13844
13845	/* W CONTAINS ALL N EIGENVALUES IN ASCENDING ORDER. */
13846
13847	/* Z CONTAINS THE ORTHONORMAL EIGENVECTORS ASSOCIATED WITH */
13848	/* THE FIRST M EIGENVALUES. */
13849
13850	/* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */
13851	/* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT, */
13852	/* IMTQLV AND TINVIT. THE NORMAL COMPLETION CODE IS ZERO. */
13853
13854	/* FWORK IS A TEMPORARY STORAGE ARRAY OF DIMENSION 8N. /
13855
13856	/* IWORK IS AN INTEGER TEMPORARY STORAGE ARRAY OF DIMENSION N. */
13857
13858	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
13859	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
13860	*/
13861
13862	/* THIS VERSION DATED AUGUST 1983. */
13863
13864	/* ------------------------------------------------------------------
13865	*/
13866
13867	/* Parameter adjustments */
13868	--iwork;
13869	--w;
13870	a_dim1 = *nm;
13871	a_offset = a_dim1 + 1;
13872	a -= a_offset;
13873	z_dim1 = *nm;
13874	z_offset = z_dim1 + 1;
13875	z -= z_offset;
13876	--fwork;
13877
13878	/* Function Body */
13879	ierr = n * 10;
13880	if (n > nm \|\| m > nm) {
13881	goto L50;
13882	}
13883	k1 = 1;
13884	k2 = k1 + *n;
13885	k3 = k2 + *n;
13886	k4 = k3 + *n;
13887	k5 = k4 + *n;
13888	k6 = k5 + *n;
13889	k7 = k6 + *n;
13890	k8 = k7 + *n;
13891	if (*m > 0) {
13892	goto L10;
13893	}
13894	/* .......... FIND EIGENVALUES ONLY .......... */
13895	tred1_(nm, n, &a[a_offset], &w[1], &fwork[k1], &fwork[k2]);
13896	tqlrat_(n, &w[1], &fwork[k2], ierr);
13897	goto L50;
13898	/* .......... FIND ALL EIGENVALUES AND M EIGENVECTORS .......... */
13899	L10:
13900	tred1_(nm, n, &a[a_offset], &fwork[k1], &fwork[k2], &fwork[k3]);
13901	imtqlv_(n, &fwork[k1], &fwork[k2], &fwork[k3], &w[1], &iwork[1], ierr, &
13902	fwork[k4]);
13903	tinvit_(nm, n, &fwork[k1], &fwork[k2], &fwork[k3], m, &w[1], &iwork[1], &
13904	z[z_offset], ierr, &fwork[k4], &fwork[k5], &fwork[k6], &fwork[k7],
13905	&fwork[k8]);
13906	trbak1_(nm, n, &a[a_offset], &fwork[k2], m, &z[z_offset]);
13907	L50:
13908	return 0;
13909	} /* rsm_ */
13910
13911	/* Subroutine / int rsp_(integer nm, integer n, integer nv, doublereal *a,
13912	doublereal w, integer matz, doublereal z, doublereal fv1,
13913	doublereal fv2, integer ierr)
13914	{
13915	/* System generated locals */
13916	integer z_dim1, z_offset, i_1, i_2;
13917
13918	/* Local variables */
13919	extern /* Subroutine / int tred3_(integer , integer , doublereal ,
13920	doublereal , doublereal , doublereal *);
13921	static integer i, j;
13922	extern /* Subroutine / int trbak3_(integer , integer , integer ,
13923	doublereal , integer , doublereal ), tqlrat_(integer ,
13924	doublereal , doublereal , integer ), tql2_(integer , integer *
13925	, doublereal , doublereal , doublereal , integer );
13926
13927
13928
13929	/* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */
13930	/* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */
13931	/* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */
13932	/* OF A REAL SYMMETRIC PACKED MATRIX. */
13933
13934	/* ON INPUT */
13935
13936	/* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */
13937	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
13938	/* DIMENSION STATEMENT. */
13939
13940	/* N IS THE ORDER OF THE MATRIX A. */
13941
13942	/* NV IS AN INTEGER VARIABLE SET EQUAL TO THE */
13943	/* DIMENSION OF THE ARRAY A AS SPECIFIED FOR */
13944	/* A IN THE CALLING PROGRAM. NV MUST NOT BE */
13945	/* LESS THAN N(N+1)/2. /
13946
13947	/* A CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC */
13948	/* PACKED MATRIX STORED ROW-WISE. */
13949
13950	/* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */
13951	/* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */
13952	/* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */
13953
13954	/* ON OUTPUT */
13955
13956	/* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */
13957
13958	/* Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. */
13959
13960	/* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */
13961	/* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT */
13962	/* AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. */
13963
13964	/* FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS. */
13965
13966	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
13967	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
13968	*/
13969
13970	/* THIS VERSION DATED AUGUST 1983. */
13971
13972	/* ------------------------------------------------------------------
13973	*/
13974
13975	/* Parameter adjustments */
13976	--fv2;
13977	--fv1;
13978	z_dim1 = *nm;
13979	z_offset = z_dim1 + 1;
13980	z -= z_offset;
13981	--w;
13982	--a;
13983
13984	/* Function Body */
13985	if (n <= nm) {
13986	goto L5;
13987	}
13988	ierr = n * 10;
13989	goto L50;
13990	L5:
13991	if (nv >= n * (*n + 1) / 2) {
13992	goto L10;
13993	}
13994	ierr = n * 20;
13995	goto L50;
13996
13997	L10:
13998	tred3_(n, nv, &a[1], &w[1], &fv1[1], &fv2[1]);
13999	if (*matz != 0) {
14000	goto L20;
14001	}
14002	/* .......... FIND EIGENVALUES ONLY .......... */
14003	tqlrat_(n, &w[1], &fv2[1], ierr);
14004	goto L50;
14005	/* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */
14006	L20:
14007	i_1 = *n;
14008	for (i = 1; i <= i_1; ++i) {
14009
14010	i_2 = *n;
14011	for (j = 1; j <= i_2; ++j) {
14012	z[j + i * z_dim1] = 0.;
14013	/* L30: */
14014	}
14015
14016	z[i + i * z_dim1] = 1.;
14017	/* L40: */
14018	}
14019
14020	tql2_(nm, n, &w[1], &fv1[1], &z[z_offset], ierr);
14021	if (*ierr != 0) {
14022	goto L50;
14023	}
14024	trbak3_(nm, n, nv, &a[1], n, &z[z_offset]);
14025	L50:
14026	return 0;
14027	} /* rsp_ */
14028
14029	/* Subroutine / int rst_(integer nm, integer n, doublereal w, doublereal *
14030	e, integer matz, doublereal z, integer *ierr)
14031	{
14032	/* System generated locals */
14033	integer z_dim1, z_offset, i_1, i_2;
14034
14035	/* Local variables */
14036	static integer i, j;
14037	extern /* Subroutine / int imtql1_(integer , doublereal , doublereal ,
14038	integer ), imtql2_(integer , integer , doublereal ,
14039	doublereal , doublereal , integer *);
14040
14041
14042
14043	/* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */
14044	/* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */
14045	/* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */
14046	/* OF A REAL SYMMETRIC TRIDIAGONAL MATRIX. */
14047
14048	/* ON INPUT */
14049
14050	/* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */
14051	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
14052	/* DIMENSION STATEMENT. */
14053
14054	/* N IS THE ORDER OF THE MATRIX. */
14055
14056	/* W CONTAINS THE DIAGONAL ELEMENTS OF THE REAL */
14057	/* SYMMETRIC TRIDIAGONAL MATRIX. */
14058
14059	/* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE MATRIX IN */
14060	/* ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */
14061
14062	/* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */
14063	/* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */
14064	/* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */
14065
14066	/* ON OUTPUT */
14067
14068	/* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */
14069
14070	/* Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. */
14071
14072	/* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */
14073	/* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR IMTQL1 */
14074	/* AND IMTQL2. THE NORMAL COMPLETION CODE IS ZERO. */
14075
14076	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
14077	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
14078	*/
14079
14080	/* THIS VERSION DATED AUGUST 1983. */
14081
14082	/* ------------------------------------------------------------------
14083	*/
14084
14085	/* Parameter adjustments */
14086	z_dim1 = *nm;
14087	z_offset = z_dim1 + 1;
14088	z -= z_offset;
14089	--e;
14090	--w;
14091
14092	/* Function Body */
14093	if (n <= nm) {
14094	goto L10;
14095	}
14096	ierr = n * 10;
14097	goto L50;
14098
14099	L10:
14100	if (*matz != 0) {
14101	goto L20;
14102	}
14103	/* .......... FIND EIGENVALUES ONLY .......... */
14104	imtql1_(n, &w[1], &e[1], ierr);
14105	goto L50;
14106	/* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */
14107	L20:
14108	i_1 = *n;
14109	for (i = 1; i <= i_1; ++i) {
14110
14111	i_2 = *n;
14112	for (j = 1; j <= i_2; ++j) {
14113	z[j + i * z_dim1] = 0.;
14114	/* L30: */
14115	}
14116
14117	z[i + i * z_dim1] = 1.;
14118	/* L40: */
14119	}
14120
14121	imtql2_(nm, n, &w[1], &e[1], &z[z_offset], ierr);
14122	L50:
14123	return 0;
14124	} /* rst_ */
14125
14126	/* Subroutine / int rt_(integer nm, integer n, doublereal a, doublereal *
14127	w, integer matz, doublereal z, doublereal fv1, integer ierr)
14128	{
14129	/* System generated locals */
14130	integer a_dim1, a_offset, z_dim1, z_offset;
14131
14132	/* Local variables */
14133	extern /* Subroutine / int figi_(integer , integer , doublereal ,
14134	doublereal , doublereal , doublereal , integer ), figi2_(
14135	integer , integer , doublereal , doublereal , doublereal *,
14136	doublereal , integer ), imtql1_(integer , doublereal ,
14137	doublereal , integer ), imtql2_(integer , integer ,
14138	doublereal , doublereal , doublereal , integer );
14139
14140
14141
14142	/* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */
14143	/* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */
14144	/* TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) */
14145	/* OF A SPECIAL REAL TRIDIAGONAL MATRIX. */
14146
14147	/* ON INPUT */
14148
14149	/* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */
14150	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
14151	/* DIMENSION STATEMENT. */
14152
14153	/* N IS THE ORDER OF THE MATRIX A. */
14154
14155	/* A CONTAINS THE SPECIAL REAL TRIDIAGONAL MATRIX IN ITS */
14156	/* FIRST THREE COLUMNS. THE SUBDIAGONAL ELEMENTS ARE STORED */
14157	/* IN THE LAST N-1 POSITIONS OF THE FIRST COLUMN, THE */
14158	/* DIAGONAL ELEMENTS IN THE SECOND COLUMN, AND THE SUPERDIAGONAL */
14159	/* ELEMENTS IN THE FIRST N-1 POSITIONS OF THE THIRD COLUMN. */
14160	/* ELEMENTS A(1,1) AND A(N,3) ARE ARBITRARY. */
14161
14162	/* MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF */
14163	/* ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO */
14164	/* ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. */
14165
14166	/* ON OUTPUT */
14167
14168	/* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */
14169
14170	/* Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. */
14171
14172	/* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */
14173	/* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR IMTQL1 */
14174	/* AND IMTQL2. THE NORMAL COMPLETION CODE IS ZERO. */
14175
14176	/* FV1 IS A TEMPORARY STORAGE ARRAY. */
14177
14178	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
14179	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
14180	*/
14181
14182	/* THIS VERSION DATED AUGUST 1983. */
14183
14184	/* ------------------------------------------------------------------
14185	*/
14186
14187	/* Parameter adjustments */
14188	a_dim1 = *nm;
14189	a_offset = a_dim1 + 1;
14190	a -= a_offset;
14191	--fv1;
14192	z_dim1 = *nm;
14193	z_offset = z_dim1 + 1;
14194	z -= z_offset;
14195	--w;
14196
14197	/* Function Body */
14198	if (n <= nm) {
14199	goto L10;
14200	}
14201	ierr = n * 10;
14202	goto L50;
14203
14204	L10:
14205	if (*matz != 0) {
14206	goto L20;
14207	}
14208	/* .......... FIND EIGENVALUES ONLY .......... */
14209	figi_(nm, n, &a[a_offset], &w[1], &fv1[1], &fv1[1], ierr);
14210	if (*ierr > 0) {
14211	goto L50;
14212	}
14213	imtql1_(n, &w[1], &fv1[1], ierr);
14214	goto L50;
14215	/* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */
14216	L20:
14217	figi2_(nm, n, &a[a_offset], &w[1], &fv1[1], &z[z_offset], ierr);
14218	if (*ierr != 0) {
14219	goto L50;
14220	}
14221	imtql2_(nm, n, &w[1], &fv1[1], &z[z_offset], ierr);
14222	L50:
14223	return 0;
14224	} /* rt_ */
14225
14226	/* Subroutine / int svd_(integer nm, integer m, integer n, doublereal *a,
14227	doublereal w, logical matu, doublereal u, logical matv,
14228	doublereal v, integer ierr, doublereal *rv1)
14229	{
14230	/* System generated locals */
14231	integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, i_1, i_2,
14232	i_3;
14233	doublereal d_1, d_2, d_3, d_4;
14234
14235	/* Builtin functions */
14236	double sqrt(doublereal), d_sign(doublereal , doublereal );
14237
14238	/* Local variables */
14239	static doublereal c, f, g, h;
14240	static integer i, j, k, l;
14241	static doublereal s, x, y, z, scale;
14242	static integer i1, k1, l1, ii, kk, ll, mn;
14243	extern doublereal pythag_(doublereal , doublereal );
14244	static integer its;
14245	static doublereal tst1, tst2;
14246
14247
14248
14249	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE SVD, */
14250	/* NUM. MATH. 14, 403-420(1970) BY GOLUB AND REINSCH. */
14251	/* HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 134-151(1971). */
14252
14253	/* THIS SUBROUTINE DETERMINES THE SINGULAR VALUE DECOMPOSITION */
14254	/* T */
14255	/* A=USV OF A REAL M BY N RECTANGULAR MATRIX. HOUSEHOLDER */
14256	/* BIDIAGONALIZATION AND A VARIANT OF THE QR ALGORITHM ARE USED. */
14257
14258	/* ON INPUT */
14259
14260	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
14261	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
14262	/* DIMENSION STATEMENT. NOTE THAT NM MUST BE AT LEAST */
14263	/* AS LARGE AS THE MAXIMUM OF M AND N. */
14264
14265	/* M IS THE NUMBER OF ROWS OF A (AND U). */
14266
14267	/* N IS THE NUMBER OF COLUMNS OF A (AND U) AND THE ORDER OF V. */
14268
14269	/* A CONTAINS THE RECTANGULAR INPUT MATRIX TO BE DECOMPOSED. */
14270
14271	/* MATU SHOULD BE SET TO .TRUE. IF THE U MATRIX IN THE */
14272	/* DECOMPOSITION IS DESIRED, AND TO .FALSE. OTHERWISE. */
14273
14274	/* MATV SHOULD BE SET TO .TRUE. IF THE V MATRIX IN THE */
14275	/* DECOMPOSITION IS DESIRED, AND TO .FALSE. OTHERWISE. */
14276
14277	/* ON OUTPUT */
14278
14279	/* A IS UNALTERED (UNLESS OVERWRITTEN BY U OR V). */
14280
14281	/* W CONTAINS THE N (NON-NEGATIVE) SINGULAR VALUES OF A (THE */
14282	/* DIAGONAL ELEMENTS OF S). THEY ARE UNORDERED. IF AN */
14283	/* ERROR EXIT IS MADE, THE SINGULAR VALUES SHOULD BE CORRECT */
14284	/* FOR INDICES IERR+1,IERR+2,...,N. */
14285
14286	/* U CONTAINS THE MATRIX U (ORTHOGONAL COLUMN VECTORS) OF THE */
14287	/* DECOMPOSITION IF MATU HAS BEEN SET TO .TRUE. OTHERWISE */
14288	/* U IS USED AS A TEMPORARY ARRAY. U MAY COINCIDE WITH A. */
14289	/* IF AN ERROR EXIT IS MADE, THE COLUMNS OF U CORRESPONDING */
14290	/* TO INDICES OF CORRECT SINGULAR VALUES SHOULD BE CORRECT. */
14291
14292	/* V CONTAINS THE MATRIX V (ORTHOGONAL) OF THE DECOMPOSITION IF */
14293	/* MATV HAS BEEN SET TO .TRUE. OTHERWISE V IS NOT REFERENCED. */
14294	/* V MAY ALSO COINCIDE WITH A IF U IS NOT NEEDED. IF AN ERROR */
14295	/* EXIT IS MADE, THE COLUMNS OF V CORRESPONDING TO INDICES OF */
14296	/* CORRECT SINGULAR VALUES SHOULD BE CORRECT. */
14297
14298	/* IERR IS SET TO */
14299	/* ZERO FOR NORMAL RETURN, */
14300	/* K IF THE K-TH SINGULAR VALUE HAS NOT BEEN */
14301	/* DETERMINED AFTER 30 ITERATIONS. */
14302
14303	/* RV1 IS A TEMPORARY STORAGE ARRAY. */
14304
14305	/* CALLS PYTHAG FOR DSQRT(AA + BB) . */
14306
14307	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
14308	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
14309	*/
14310
14311	/* THIS VERSION DATED AUGUST 1983. */
14312
14313	/* ------------------------------------------------------------------
14314	*/
14315
14316	/* Parameter adjustments */
14317	--rv1;
14318	v_dim1 = *nm;
14319	v_offset = v_dim1 + 1;
14320	v -= v_offset;
14321	u_dim1 = *nm;
14322	u_offset = u_dim1 + 1;
14323	u -= u_offset;
14324	--w;
14325	a_dim1 = *nm;
14326	a_offset = a_dim1 + 1;
14327	a -= a_offset;
14328
14329	/* Function Body */
14330	*ierr = 0;
14331
14332	i_1 = *m;
14333	for (i = 1; i <= i_1; ++i) {
14334
14335	i_2 = *n;
14336	for (j = 1; j <= i_2; ++j) {
14337	u[i + j * u_dim1] = a[i + j * a_dim1];
14338	/* L100: */
14339	}
14340	}
14341	/* .......... HOUSEHOLDER REDUCTION TO BIDIAGONAL FORM .......... */
14342	g = 0.;
14343	scale = 0.;
14344	x = 0.;
14345
14346	i_2 = *n;
14347	for (i = 1; i <= i_2; ++i) {
14348	l = i + 1;
14349	rv1[i] = scale * g;
14350	g = 0.;
14351	s = 0.;
14352	scale = 0.;
14353	if (i > *m) {
14354	goto L210;
14355	}
14356
14357	i_1 = *m;
14358	for (k = i; k <= i_1; ++k) {
14359	/* L120: */
14360	scale += (d_1 = u[k + i * u_dim1], abs(d_1));
14361	}
14362
14363	if (scale == 0.) {
14364	goto L210;
14365	}
14366
14367	i_1 = *m;
14368	for (k = i; k <= i_1; ++k) {
14369	u[k + i * u_dim1] /= scale;
14370	/* Computing 2nd power */
14371	d_1 = u[k + i * u_dim1];
14372	s += d_1 * d_1;
14373	/* L130: */
14374	}
14375
14376	f = u[i + i * u_dim1];
14377	d_1 = sqrt(s);
14378	g = -d_sign(&d_1, &f);
14379	h = f * g - s;
14380	u[i + i * u_dim1] = f - g;
14381	if (i == *n) {
14382	goto L190;
14383	}
14384
14385	i_1 = *n;
14386	for (j = l; j <= i_1; ++j) {
14387	s = 0.;
14388
14389	i_3 = *m;
14390	for (k = i; k <= i_3; ++k) {
14391	/* L140: */
14392	s += u[k + i * u_dim1] * u[k + j * u_dim1];
14393	}
14394
14395	f = s / h;
14396
14397	i_3 = *m;
14398	for (k = i; k <= i_3; ++k) {
14399	u[k + j * u_dim1] += f * u[k + i * u_dim1];
14400	/* L150: */
14401	}
14402	}
14403
14404	L190:
14405	i_3 = *m;
14406	for (k = i; k <= i_3; ++k) {
14407	/* L200: */
14408	u[k + i * u_dim1] = scale * u[k + i * u_dim1];
14409	}
14410
14411	L210:
14412	w[i] = scale * g;
14413	g = 0.;
14414	s = 0.;
14415	scale = 0.;
14416	if (i > m \|\| i == n) {
14417	goto L290;
14418	}
14419
14420	i_3 = *n;
14421	for (k = l; k <= i_3; ++k) {
14422	/* L220: */
14423	scale += (d_1 = u[i + k * u_dim1], abs(d_1));
14424	}
14425
14426	if (scale == 0.) {
14427	goto L290;
14428	}
14429
14430	i_3 = *n;
14431	for (k = l; k <= i_3; ++k) {
14432	u[i + k * u_dim1] /= scale;
14433	/* Computing 2nd power */
14434	d_1 = u[i + k * u_dim1];
14435	s += d_1 * d_1;
14436	/* L230: */
14437	}
14438
14439	f = u[i + l * u_dim1];
14440	d_1 = sqrt(s);
14441	g = -d_sign(&d_1, &f);
14442	h = f * g - s;
14443	u[i + l * u_dim1] = f - g;
14444
14445	i_3 = *n;
14446	for (k = l; k <= i_3; ++k) {
14447	/* L240: */
14448	rv1[k] = u[i + k * u_dim1] / h;
14449	}
14450
14451	if (i == *m) {
14452	goto L270;
14453	}
14454
14455	i_3 = *m;
14456	for (j = l; j <= i_3; ++j) {
14457	s = 0.;
14458
14459	i_1 = *n;
14460	for (k = l; k <= i_1; ++k) {
14461	/* L250: */
14462	s += u[j + k * u_dim1] * u[i + k * u_dim1];
14463	}
14464
14465	i_1 = *n;
14466	for (k = l; k <= i_1; ++k) {
14467	u[j + k * u_dim1] += s * rv1[k];
14468	/* L260: */
14469	}
14470	}
14471
14472	L270:
14473	i_1 = *n;
14474	for (k = l; k <= i_1; ++k) {
14475	/* L280: */
14476	u[i + k * u_dim1] = scale * u[i + k * u_dim1];
14477	}
14478
14479	L290:
14480	/* Computing MAX */
14481	d_3 = x, d_4 = (d_1 = w[i], abs(d_1)) + (d_2 = rv1[i], abs(d_2))
14482	;
14483	x = max(d_3,d_4);
14484	/* L300: */
14485	}
14486	/* .......... ACCUMULATION OF RIGHT-HAND TRANSFORMATIONS .......... */
14487	if (! (*matv)) {
14488	goto L410;
14489	}
14490	/* .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... */
14491	i_2 = *n;
14492	for (ii = 1; ii <= i_2; ++ii) {
14493	i = *n + 1 - ii;
14494	if (i == *n) {
14495	goto L390;
14496	}
14497	if (g == 0.) {
14498	goto L360;
14499	}
14500
14501	i_1 = *n;
14502	for (j = l; j <= i_1; ++j) {
14503	/* .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ......
14504	.... */
14505	/* L320: */
14506	v[j + i * v_dim1] = u[i + j * u_dim1] / u[i + l * u_dim1] / g;
14507	}
14508
14509	i_1 = *n;
14510	for (j = l; j <= i_1; ++j) {
14511	s = 0.;
14512
14513	i_3 = *n;
14514	for (k = l; k <= i_3; ++k) {
14515	/* L340: */
14516	s += u[i + k * u_dim1] * v[k + j * v_dim1];
14517	}
14518
14519	i_3 = *n;
14520	for (k = l; k <= i_3; ++k) {
14521	v[k + j * v_dim1] += s * v[k + i * v_dim1];
14522	/* L350: */
14523	}
14524	}
14525
14526	L360:
14527	i_3 = *n;
14528	for (j = l; j <= i_3; ++j) {
14529	v[i + j * v_dim1] = 0.;
14530	v[j + i * v_dim1] = 0.;
14531	/* L380: */
14532	}
14533
14534	L390:
14535	v[i + i * v_dim1] = 1.;
14536	g = rv1[i];
14537	l = i;
14538	/* L400: */
14539	}
14540	/* .......... ACCUMULATION OF LEFT-HAND TRANSFORMATIONS .......... */
14541	L410:
14542	if (! (*matu)) {
14543	goto L510;
14544	}
14545	/* ..........FOR I=MIN(M,N) STEP -1 UNTIL 1 DO -- .......... */
14546	mn = *n;
14547	if (m < n) {
14548	mn = *m;
14549	}
14550
14551	i_2 = mn;
14552	for (ii = 1; ii <= i_2; ++ii) {
14553	i = mn + 1 - ii;
14554	l = i + 1;
14555	g = w[i];
14556	if (i == *n) {
14557	goto L430;
14558	}
14559
14560	i_3 = *n;
14561	for (j = l; j <= i_3; ++j) {
14562	/* L420: */
14563	u[i + j * u_dim1] = 0.;
14564	}
14565
14566	L430:
14567	if (g == 0.) {
14568	goto L475;
14569	}
14570	if (i == mn) {
14571	goto L460;
14572	}
14573
14574	i_3 = *n;
14575	for (j = l; j <= i_3; ++j) {
14576	s = 0.;
14577
14578	i_1 = *m;
14579	for (k = l; k <= i_1; ++k) {
14580	/* L440: */
14581	s += u[k + i * u_dim1] * u[k + j * u_dim1];
14582	}
14583	/* .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ......
14584	.... */
14585	f = s / u[i + i * u_dim1] / g;
14586
14587	i_1 = *m;
14588	for (k = i; k <= i_1; ++k) {
14589	u[k + j * u_dim1] += f * u[k + i * u_dim1];
14590	/* L450: */
14591	}
14592	}
14593
14594	L460:
14595	i_1 = *m;
14596	for (j = i; j <= i_1; ++j) {
14597	/* L470: */
14598	u[j + i * u_dim1] /= g;
14599	}
14600
14601	goto L490;
14602
14603	L475:
14604	i_1 = *m;
14605	for (j = i; j <= i_1; ++j) {
14606	/* L480: */
14607	u[j + i * u_dim1] = 0.;
14608	}
14609
14610	L490:
14611	u[i + i * u_dim1] += 1.;
14612	/* L500: */
14613	}
14614	/* .......... DIAGONALIZATION OF THE BIDIAGONAL FORM .......... */
14615	L510:
14616	tst1 = x;
14617	/* .......... FOR K=N STEP -1 UNTIL 1 DO -- .......... */
14618	i_2 = *n;
14619	for (kk = 1; kk <= i_2; ++kk) {
14620	k1 = *n - kk;
14621	k = k1 + 1;
14622	its = 0;
14623	/* .......... TEST FOR SPLITTING. */
14624	/* FOR L=K STEP -1 UNTIL 1 DO -- .......... */
14625	L520:
14626	i_1 = k;
14627	for (ll = 1; ll <= i_1; ++ll) {
14628	l1 = k - ll;
14629	l = l1 + 1;
14630	tst2 = tst1 + (d_1 = rv1[l], abs(d_1));
14631	if (tst2 == tst1) {
14632	goto L565;
14633	}
14634	/* .......... RV1(1) IS ALWAYS ZERO, SO THERE IS NO EXIT */
14635	/* THROUGH THE BOTTOM OF THE LOOP .......... */
14636	tst2 = tst1 + (d_1 = w[l1], abs(d_1));
14637	if (tst2 == tst1) {
14638	goto L540;
14639	}
14640	/* L530: */
14641	}
14642	/* .......... CANCELLATION OF RV1(L) IF L GREATER THAN 1 .........
14643	. */
14644	L540:
14645	c = 0.;
14646	s = 1.;
14647
14648	i_1 = k;
14649	for (i = l; i <= i_1; ++i) {
14650	f = s * rv1[i];
14651	rv1[i] = c * rv1[i];
14652	tst2 = tst1 + abs(f);
14653	if (tst2 == tst1) {
14654	goto L565;
14655	}
14656	g = w[i];
14657	h = pythag_(&f, &g);
14658	w[i] = h;
14659	c = g / h;
14660	s = -f / h;
14661	if (! (*matu)) {
14662	goto L560;
14663	}
14664
14665	i_3 = *m;
14666	for (j = 1; j <= i_3; ++j) {
14667	y = u[j + l1 * u_dim1];
14668	z = u[j + i * u_dim1];
14669	u[j + l1 * u_dim1] = y * c + z * s;
14670	u[j + i * u_dim1] = -y * s + z * c;
14671	/* L550: */
14672	}
14673
14674	L560:
14675	;
14676	}
14677	/* .......... TEST FOR CONVERGENCE .......... */
14678	L565:
14679	z = w[k];
14680	if (l == k) {
14681	goto L650;
14682	}
14683	/* .......... SHIFT FROM BOTTOM 2 BY 2 MINOR .......... */
14684	if (its == 30) {
14685	goto L1000;
14686	}
14687	++its;
14688	x = w[l];
14689	y = w[k1];
14690	g = rv1[k1];
14691	h = rv1[k];
14692	f = ((g + z) / h * ((g - z) / y) + y / h - h / y) * .5;
14693	g = pythag_(&f, &c_b141);
14694	f = x - z / x * z + h / x * (y / (f + d_sign(&g, &f)) - h);
14695	/* .......... NEXT QR TRANSFORMATION .......... */
14696	c = 1.;
14697	s = 1.;
14698
14699	i_1 = k1;
14700	for (i1 = l; i1 <= i_1; ++i1) {
14701	i = i1 + 1;
14702	g = rv1[i];
14703	y = w[i];
14704	h = s * g;
14705	g = c * g;
14706	z = pythag_(&f, &h);
14707	rv1[i1] = z;
14708	c = f / z;
14709	s = h / z;
14710	f = x * c + g * s;
14711	g = -x * s + g * c;
14712	h = y * s;
14713	y *= c;
14714	if (! (*matv)) {
14715	goto L575;
14716	}
14717
14718	i_3 = *n;
14719	for (j = 1; j <= i_3; ++j) {
14720	x = v[j + i1 * v_dim1];
14721	z = v[j + i * v_dim1];
14722	v[j + i1 * v_dim1] = x * c + z * s;
14723	v[j + i * v_dim1] = -x * s + z * c;
14724	/* L570: */
14725	}
14726
14727	L575:
14728	z = pythag_(&f, &h);
14729	w[i1] = z;
14730	/* .......... ROTATION CAN BE ARBITRARY IF Z IS ZERO .........
14731	. */
14732	if (z == 0.) {
14733	goto L580;
14734	}
14735	c = f / z;
14736	s = h / z;
14737	L580:
14738	f = c * g + s * y;
14739	x = -s * g + c * y;
14740	if (! (*matu)) {
14741	goto L600;
14742	}
14743
14744	i_3 = *m;
14745	for (j = 1; j <= i_3; ++j) {
14746	y = u[j + i1 * u_dim1];
14747	z = u[j + i * u_dim1];
14748	u[j + i1 * u_dim1] = y * c + z * s;
14749	u[j + i * u_dim1] = -y * s + z * c;
14750	/* L590: */
14751	}
14752
14753	L600:
14754	;
14755	}
14756
14757	rv1[l] = 0.;
14758	rv1[k] = f;
14759	w[k] = x;
14760	goto L520;
14761	/* .......... CONVERGENCE .......... */
14762	L650:
14763	if (z >= 0.) {
14764	goto L700;
14765	}
14766	/* .......... W(K) IS MADE NON-NEGATIVE .......... */
14767	w[k] = -z;
14768	if (! (*matv)) {
14769	goto L700;
14770	}
14771
14772	i_1 = *n;
14773	for (j = 1; j <= i_1; ++j) {
14774	/* L690: */
14775	v[j + k * v_dim1] = -v[j + k * v_dim1];
14776	}
14777
14778	L700:
14779	;
14780	}
14781
14782	goto L1001;
14783	/* .......... SET ERROR -- NO CONVERGENCE TO A */
14784	/* SINGULAR VALUE AFTER 30 ITERATIONS .......... */
14785	L1000:
14786	*ierr = k;
14787	L1001:
14788	return 0;
14789	} /* svd_ */
14790
14791	/* Subroutine / int tinvit_(integer nm, integer n, doublereal d,
14792	doublereal e, doublereal e2, integer m, doublereal w, integer *
14793	ind, doublereal z, integer ierr, doublereal rv1, doublereal rv2,
14794	doublereal rv3, doublereal rv4, doublereal *rv6)
14795	{
14796	/* System generated locals */
14797	integer z_dim1, z_offset, i_1, i_2, i_3;
14798	doublereal d_1, d_2, d_3, d_4;
14799
14800	/* Builtin functions */
14801	double sqrt(doublereal);
14802
14803	/* Local variables */
14804	static doublereal norm;
14805	static integer i, j, p, q, r, s;
14806	static doublereal u, v, order;
14807	static integer group;
14808	static doublereal x0, x1;
14809	static integer ii, jj, ip;
14810	static doublereal uk, xu;
14811	extern doublereal pythag_(doublereal , doublereal ), epslon_(doublereal
14812	*);
14813	static integer tag, its;
14814	static doublereal eps2, eps3, eps4;
14815
14816
14817
14818	/* THIS SUBROUTINE IS A TRANSLATION OF THE INVERSE ITERATION TECH- */
14819	/* NIQUE IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON. */
14820	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). */
14821
14822	/* THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A TRIDIAGONAL */
14823	/* SYMMETRIC MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES, */
14824	/* USING INVERSE ITERATION. */
14825
14826	/* ON INPUT */
14827
14828	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
14829	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
14830	/* DIMENSION STATEMENT. */
14831
14832	/* N IS THE ORDER OF THE MATRIX. */
14833
14834	/* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */
14835
14836	/* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */
14837	/* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */
14838
14839	/* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E, */
14840	/* WITH ZEROS CORRESPONDING TO NEGLIGIBLE ELEMENTS OF E. */
14841	/* E(I) IS CONSIDERED NEGLIGIBLE IF IT IS NOT LARGER THAN */
14842	/* THE PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE SUM */
14843	/* OF THE MAGNITUDES OF D(I) AND D(I-1). E2(1) MUST CONTAIN */
14844	/* 0.0D0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, OR 2.0D0 */
14845	/* IF THE EIGENVALUES ARE IN DESCENDING ORDER. IF BISECT, */
14846	/* TRIDIB, OR IMTQLV HAS BEEN USED TO FIND THE EIGENVALUES, */
14847	/* THEIR OUTPUT E2 ARRAY IS EXACTLY WHAT IS EXPECTED HERE. */
14848
14849	/* M IS THE NUMBER OF SPECIFIED EIGENVALUES. */
14850
14851	/* W CONTAINS THE M EIGENVALUES IN ASCENDING OR DESCENDING ORDER.
14852	*/
14853
14854	/* IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES */
14855	/* ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W -- */
14856	/* 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM */
14857	/* THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC.
14858	*/
14859
14860	/* ON OUTPUT */
14861
14862	/* ALL INPUT ARRAYS ARE UNALTERED. */
14863
14864	/* Z CONTAINS THE ASSOCIATED SET OF ORTHONORMAL EIGENVECTORS. */
14865	/* ANY VECTOR WHICH FAILS TO CONVERGE IS SET TO ZERO. */
14866
14867	/* IERR IS SET TO */
14868	/* ZERO FOR NORMAL RETURN, */
14869	/* -R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH */
14870	/* EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS. */
14871
14872	/* RV1, RV2, RV3, RV4, AND RV6 ARE TEMPORARY STORAGE ARRAYS. */
14873
14874	/* CALLS PYTHAG FOR DSQRT(AA + BB) . */
14875
14876	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
14877	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
14878	*/
14879
14880	/* THIS VERSION DATED AUGUST 1983. */
14881
14882	/* ------------------------------------------------------------------
14883	*/
14884
14885	/* Parameter adjustments */
14886	--rv6;
14887	--rv4;
14888	--rv3;
14889	--rv2;
14890	--rv1;
14891	--e2;
14892	--e;
14893	--d;
14894	z_dim1 = *nm;
14895	z_offset = z_dim1 + 1;
14896	z -= z_offset;
14897	--ind;
14898	--w;
14899
14900	/* Function Body */
14901	*ierr = 0;
14902	if (*m == 0) {
14903	goto L1001;
14904	}
14905	tag = 0;
14906	order = 1. - e2[1];
14907	q = 0;
14908	/* .......... ESTABLISH AND PROCESS NEXT SUBMATRIX .......... */
14909	L100:
14910	p = q + 1;
14911
14912	i_1 = *n;
14913	for (q = p; q <= i_1; ++q) {
14914	if (q == *n) {
14915	goto L140;
14916	}
14917	if (e2[q + 1] == 0.) {
14918	goto L140;
14919	}
14920	/* L120: */
14921	}
14922	/* .......... FIND VECTORS BY INVERSE ITERATION .......... */
14923	L140:
14924	++tag;
14925	s = 0;
14926
14927	i_1 = *m;
14928	for (r = 1; r <= i_1; ++r) {
14929	if (ind[r] != tag) {
14930	goto L920;
14931	}
14932	its = 1;
14933	x1 = w[r];
14934	if (s != 0) {
14935	goto L510;
14936	}
14937	/* .......... CHECK FOR ISOLATED ROOT .......... */
14938	xu = 1.;
14939	if (p != q) {
14940	goto L490;
14941	}
14942	rv6[p] = 1.;
14943	goto L870;
14944	L490:
14945	norm = (d_1 = d[p], abs(d_1));
14946	ip = p + 1;
14947
14948	i_2 = q;
14949	for (i = ip; i <= i_2; ++i) {
14950	/* L500: */
14951	/* Computing MAX */
14952	d_3 = norm, d_4 = (d_1 = d[i], abs(d_1)) + (d_2 = e[i], abs(
14953	d_2));
14954	norm = max(d_3,d_4);
14955	}
14956	/* .......... EPS2 IS THE CRITERION FOR GROUPING, */
14957	/* EPS3 REPLACES ZERO PIVOTS AND EQUAL */
14958	/* ROOTS ARE MODIFIED BY EPS3, */
14959	/* EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW .........
14960	. */
14961	eps2 = norm * .001;
14962	eps3 = epslon_(&norm);
14963	uk = (doublereal) (q - p + 1);
14964	eps4 = uk * eps3;
14965	uk = eps4 / sqrt(uk);
14966	s = p;
14967	L505:
14968	group = 0;
14969	goto L520;
14970	/* .......... LOOK FOR CLOSE OR COINCIDENT ROOTS .......... */
14971	L510:
14972	if ((d_1 = x1 - x0, abs(d_1)) >= eps2) {
14973	goto L505;
14974	}
14975	++group;
14976	if (order * (x1 - x0) <= 0.) {
14977	x1 = x0 + order * eps3;
14978	}
14979	/* .......... ELIMINATION WITH INTERCHANGES AND */
14980	/* INITIALIZATION OF VECTOR .......... */
14981	L520:
14982	v = 0.;
14983
14984	i_2 = q;
14985	for (i = p; i <= i_2; ++i) {
14986	rv6[i] = uk;
14987	if (i == p) {
14988	goto L560;
14989	}
14990	if ((d_1 = e[i], abs(d_1)) < abs(u)) {
14991	goto L540;
14992	}
14993	/* .......... WARNING -- A DIVIDE CHECK MAY OCCUR HERE IF */
14994	/* E2 ARRAY HAS NOT BEEN SPECIFIED CORRECTLY ......
14995	.... */
14996	xu = u / e[i];
14997	rv4[i] = xu;
14998	rv1[i - 1] = e[i];
14999	rv2[i - 1] = d[i] - x1;
15000	rv3[i - 1] = 0.;
15001	if (i != q) {
15002	rv3[i - 1] = e[i + 1];
15003	}
15004	u = v - xu * rv2[i - 1];
15005	v = -xu * rv3[i - 1];
15006	goto L580;
15007	L540:
15008	xu = e[i] / u;
15009	rv4[i] = xu;
15010	rv1[i - 1] = u;
15011	rv2[i - 1] = v;
15012	rv3[i - 1] = 0.;
15013	L560:
15014	u = d[i] - x1 - xu * v;
15015	if (i != q) {
15016	v = e[i + 1];
15017	}
15018	L580:
15019	;
15020	}
15021
15022	if (u == 0.) {
15023	u = eps3;
15024	}
15025	rv1[q] = u;
15026	rv2[q] = 0.;
15027	rv3[q] = 0.;
15028	/* .......... BACK SUBSTITUTION */
15029	/* FOR I=Q STEP -1 UNTIL P DO -- .......... */
15030	L600:
15031	i_2 = q;
15032	for (ii = p; ii <= i_2; ++ii) {
15033	i = p + q - ii;
15034	rv6[i] = (rv6[i] - u * rv2[i] - v * rv3[i]) / rv1[i];
15035	v = u;
15036	u = rv6[i];
15037	/* L620: */
15038	}
15039	/* .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS */
15040	/* MEMBERS OF GROUP .......... */
15041	if (group == 0) {
15042	goto L700;
15043	}
15044	j = r;
15045
15046	i_2 = group;
15047	for (jj = 1; jj <= i_2; ++jj) {
15048	L630:
15049	--j;
15050	if (ind[j] != tag) {
15051	goto L630;
15052	}
15053	xu = 0.;
15054
15055	i_3 = q;
15056	for (i = p; i <= i_3; ++i) {
15057	/* L640: */
15058	xu += rv6[i] * z[i + j * z_dim1];
15059	}
15060
15061	i_3 = q;
15062	for (i = p; i <= i_3; ++i) {
15063	/* L660: */
15064	rv6[i] -= xu * z[i + j * z_dim1];
15065	}
15066
15067	/* L680: */
15068	}
15069
15070	L700:
15071	norm = 0.;
15072
15073	i_2 = q;
15074	for (i = p; i <= i_2; ++i) {
15075	/* L720: */
15076	norm += (d_1 = rv6[i], abs(d_1));
15077	}
15078
15079	if (norm >= 1.) {
15080	goto L840;
15081	}
15082	/* .......... FORWARD SUBSTITUTION .......... */
15083	if (its == 5) {
15084	goto L830;
15085	}
15086	if (norm != 0.) {
15087	goto L740;
15088	}
15089	rv6[s] = eps4;
15090	++s;
15091	if (s > q) {
15092	s = p;
15093	}
15094	goto L780;
15095	L740:
15096	xu = eps4 / norm;
15097
15098	i_2 = q;
15099	for (i = p; i <= i_2; ++i) {
15100	/* L760: */
15101	rv6[i] *= xu;
15102	}
15103	/* .......... ELIMINATION OPERATIONS ON NEXT VECTOR */
15104	/* ITERATE .......... */
15105	L780:
15106	i_2 = q;
15107	for (i = ip; i <= i_2; ++i) {
15108	u = rv6[i];
15109	/* .......... IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE */
15110	/* WAS PERFORMED EARLIER IN THE */
15111	/* TRIANGULARIZATION PROCESS .......... */
15112	if (rv1[i - 1] != e[i]) {
15113	goto L800;
15114	}
15115	u = rv6[i - 1];
15116	rv6[i - 1] = rv6[i];
15117	L800:
15118	rv6[i] = u - rv4[i] * rv6[i - 1];
15119	/* L820: */
15120	}
15121
15122	++its;
15123	goto L600;
15124	/* .......... SET ERROR -- NON-CONVERGED EIGENVECTOR .......... */
15125	L830:
15126	*ierr = -r;
15127	xu = 0.;
15128	goto L870;
15129	/* .......... NORMALIZE SO THAT SUM OF SQUARES IS */
15130	/* 1 AND EXPAND TO FULL ORDER .......... */
15131	L840:
15132	u = 0.;
15133
15134	i_2 = q;
15135	for (i = p; i <= i_2; ++i) {
15136	/* L860: */
15137	u = pythag_(&u, &rv6[i]);
15138	}
15139
15140	xu = 1. / u;
15141
15142	L870:
15143	i_2 = *n;
15144	for (i = 1; i <= i_2; ++i) {
15145	/* L880: */
15146	z[i + r * z_dim1] = 0.;
15147	}
15148
15149	i_2 = q;
15150	for (i = p; i <= i_2; ++i) {
15151	/* L900: */
15152	z[i + r * z_dim1] = rv6[i] * xu;
15153	}
15154
15155	x0 = x1;
15156	L920:
15157	;
15158	}
15159
15160	if (q < *n) {
15161	goto L100;
15162	}
15163	L1001:
15164	return 0;
15165	} /* tinvit_ */
15166
15167	/* Subroutine / int tql1_(integer n, doublereal d, doublereal e, integer *
15168	ierr)
15169	{
15170	/* System generated locals */
15171	integer i_1, i_2;
15172	doublereal d_1, d_2;
15173
15174	/* Builtin functions */
15175	double d_sign(doublereal , doublereal );
15176
15177	/* Local variables */
15178	static doublereal c, f, g, h;
15179	static integer i, j, l, m;
15180	static doublereal p, r, s, c2, c3;
15181	static integer l1, l2;
15182	static doublereal s2;
15183	static integer ii;
15184	extern doublereal pythag_(doublereal , doublereal );
15185	static doublereal dl1, el1;
15186	static integer mml;
15187	static doublereal tst1, tst2;
15188
15189
15190
15191	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL1, */
15192	/* NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND */
15193	/* WILKINSON. */
15194	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). */
15195
15196	/* THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC */
15197	/* TRIDIAGONAL MATRIX BY THE QL METHOD. */
15198
15199	/* ON INPUT */
15200
15201	/* N IS THE ORDER OF THE MATRIX. */
15202
15203	/* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */
15204
15205	/* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */
15206	/* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */
15207
15208	/* ON OUTPUT */
15209
15210	/* D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN */
15211	/* ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND */
15212	/* ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE */
15213	/* THE SMALLEST EIGENVALUES. */
15214
15215	/* E HAS BEEN DESTROYED. */
15216
15217	/* IERR IS SET TO */
15218	/* ZERO FOR NORMAL RETURN, */
15219	/* J IF THE J-TH EIGENVALUE HAS NOT BEEN */
15220	/* DETERMINED AFTER 30 ITERATIONS. */
15221
15222	/* CALLS PYTHAG FOR DSQRT(AA + BB) . */
15223
15224	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
15225	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
15226	*/
15227
15228	/* THIS VERSION DATED AUGUST 1983. */
15229
15230	/* ------------------------------------------------------------------
15231	*/
15232
15233	/* Parameter adjustments */
15234	--e;
15235	--d;
15236
15237	/* Function Body */
15238	*ierr = 0;
15239	if (*n == 1) {
15240	goto L1001;
15241	}
15242
15243	i_1 = *n;
15244	for (i = 2; i <= i_1; ++i) {
15245	/* L100: */
15246	e[i - 1] = e[i];
15247	}
15248
15249	f = 0.;
15250	tst1 = 0.;
15251	e[*n] = 0.;
15252
15253	i_1 = *n;
15254	for (l = 1; l <= i_1; ++l) {
15255	j = 0;
15256	h = (d_1 = d[l], abs(d_1)) + (d_2 = e[l], abs(d_2));
15257	if (tst1 < h) {
15258	tst1 = h;
15259	}
15260	/* .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... */
15261	i_2 = *n;
15262	for (m = l; m <= i_2; ++m) {
15263	tst2 = tst1 + (d_1 = e[m], abs(d_1));
15264	if (tst2 == tst1) {
15265	goto L120;
15266	}
15267	/* .......... E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT */
15268	/* THROUGH THE BOTTOM OF THE LOOP .......... */
15269	/* L110: */
15270	}
15271
15272	L120:
15273	if (m == l) {
15274	goto L210;
15275	}
15276	L130:
15277	if (j == 30) {
15278	goto L1000;
15279	}
15280	++j;
15281	/* .......... FORM SHIFT .......... */
15282	l1 = l + 1;
15283	l2 = l1 + 1;
15284	g = d[l];
15285	p = (d[l1] - g) / (e[l] * 2.);
15286	r = pythag_(&p, &c_b141);
15287	d[l] = e[l] / (p + d_sign(&r, &p));
15288	d[l1] = e[l] * (p + d_sign(&r, &p));
15289	dl1 = d[l1];
15290	h = g - d[l];
15291	if (l2 > *n) {
15292	goto L145;
15293	}
15294
15295	i_2 = *n;
15296	for (i = l2; i <= i_2; ++i) {
15297	/* L140: */
15298	d[i] -= h;
15299	}
15300
15301	L145:
15302	f += h;
15303	/* .......... QL TRANSFORMATION .......... */
15304	p = d[m];
15305	c = 1.;
15306	c2 = c;
15307	el1 = e[l1];
15308	s = 0.;
15309	mml = m - l;
15310	/* .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... */
15311	i_2 = mml;
15312	for (ii = 1; ii <= i_2; ++ii) {
15313	c3 = c2;
15314	c2 = c;
15315	s2 = s;
15316	i = m - ii;
15317	g = c * e[i];
15318	h = c * p;
15319	r = pythag_(&p, &e[i]);
15320	e[i + 1] = s * r;
15321	s = e[i] / r;
15322	c = p / r;
15323	p = c * d[i] - s * g;
15324	d[i + 1] = h + s * (c * g + s * d[i]);
15325	/* L200: */
15326	}
15327
15328	p = -s * s2 * c3 * el1 * e[l] / dl1;
15329	e[l] = s * p;
15330	d[l] = c * p;
15331	tst2 = tst1 + (d_1 = e[l], abs(d_1));
15332	if (tst2 > tst1) {
15333	goto L130;
15334	}
15335	L210:
15336	p = d[l] + f;
15337	/* .......... ORDER EIGENVALUES .......... */
15338	if (l == 1) {
15339	goto L250;
15340	}
15341	/* .......... FOR I=L STEP -1 UNTIL 2 DO -- .......... */
15342	i_2 = l;
15343	for (ii = 2; ii <= i_2; ++ii) {
15344	i = l + 2 - ii;
15345	if (p >= d[i - 1]) {
15346	goto L270;
15347	}
15348	d[i] = d[i - 1];
15349	/* L230: */
15350	}
15351
15352	L250:
15353	i = 1;
15354	L270:
15355	d[i] = p;
15356	/* L290: */
15357	}
15358
15359	goto L1001;
15360	/* .......... SET ERROR -- NO CONVERGENCE TO AN */
15361	/* EIGENVALUE AFTER 30 ITERATIONS .......... */
15362	L1000:
15363	*ierr = l;
15364	L1001:
15365	return 0;
15366	} /* tql1_ */
15367
15368	/* Subroutine / int tql2_(integer nm, integer n, doublereal d, doublereal
15369	e, doublereal z, integer *ierr)
15370	{
15371	/* System generated locals */
15372	integer z_dim1, z_offset, i_1, i_2, i_3;
15373	doublereal d_1, d_2;
15374
15375	/* Builtin functions */
15376	double d_sign(doublereal , doublereal );
15377
15378	/* Local variables */
15379	static doublereal c, f, g, h;
15380	static integer i, j, k, l, m;
15381	static doublereal p, r, s, c2, c3;
15382	static integer l1, l2;
15383	static doublereal s2;
15384	static integer ii;
15385	extern doublereal pythag_(doublereal , doublereal );
15386	static doublereal dl1, el1;
15387	static integer mml;
15388	static doublereal tst1, tst2;
15389
15390
15391
15392	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2, */
15393	/* NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND */
15394	/* WILKINSON. */
15395	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). */
15396
15397	/* THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS */
15398	/* OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD. */
15399	/* THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO */
15400	/* BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS */
15401	/* FULL MATRIX TO TRIDIAGONAL FORM. */
15402
15403	/* ON INPUT */
15404
15405	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
15406	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
15407	/* DIMENSION STATEMENT. */
15408
15409	/* N IS THE ORDER OF THE MATRIX. */
15410
15411	/* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */
15412
15413	/* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */
15414	/* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */
15415
15416	/* Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE */
15417	/* REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS */
15418	/* OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN */
15419	/* THE IDENTITY MATRIX. */
15420
15421	/* ON OUTPUT */
15422
15423	/* D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN */
15424	/* ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT */
15425	/* UNORDERED FOR INDICES 1,2,...,IERR-1. */
15426
15427	/* E HAS BEEN DESTROYED. */
15428
15429	/* Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC */
15430	/* TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE, */
15431	/* Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED */
15432	/* EIGENVALUES. */
15433
15434	/* IERR IS SET TO */
15435	/* ZERO FOR NORMAL RETURN, */
15436	/* J IF THE J-TH EIGENVALUE HAS NOT BEEN */
15437	/* DETERMINED AFTER 30 ITERATIONS. */
15438
15439	/* CALLS PYTHAG FOR DSQRT(AA + BB) . */
15440
15441	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
15442	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
15443	*/
15444
15445	/* THIS VERSION DATED AUGUST 1983. */
15446
15447	/* ------------------------------------------------------------------
15448	*/
15449
15450	/* Parameter adjustments */
15451	z_dim1 = *nm;
15452	z_offset = z_dim1 + 1;
15453	z -= z_offset;
15454	--e;
15455	--d;
15456
15457	/* Function Body */
15458	*ierr = 0;
15459	if (*n == 1) {
15460	goto L1001;
15461	}
15462
15463	i_1 = *n;
15464	for (i = 2; i <= i_1; ++i) {
15465	/* L100: */
15466	e[i - 1] = e[i];
15467	}
15468
15469	f = 0.;
15470	tst1 = 0.;
15471	e[*n] = 0.;
15472
15473	i_1 = *n;
15474	for (l = 1; l <= i_1; ++l) {
15475	j = 0;
15476	h = (d_1 = d[l], abs(d_1)) + (d_2 = e[l], abs(d_2));
15477	if (tst1 < h) {
15478	tst1 = h;
15479	}
15480	/* .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... */
15481	i_2 = *n;
15482	for (m = l; m <= i_2; ++m) {
15483	tst2 = tst1 + (d_1 = e[m], abs(d_1));
15484	if (tst2 == tst1) {
15485	goto L120;
15486	}
15487	/* .......... E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT */
15488	/* THROUGH THE BOTTOM OF THE LOOP .......... */
15489	/* L110: */
15490	}
15491
15492	L120:
15493	if (m == l) {
15494	goto L220;
15495	}
15496	L130:
15497	if (j == 30) {
15498	goto L1000;
15499	}
15500	++j;
15501	/* .......... FORM SHIFT .......... */
15502	l1 = l + 1;
15503	l2 = l1 + 1;
15504	g = d[l];
15505	p = (d[l1] - g) / (e[l] * 2.);
15506	r = pythag_(&p, &c_b141);
15507	d[l] = e[l] / (p + d_sign(&r, &p));
15508	d[l1] = e[l] * (p + d_sign(&r, &p));
15509	dl1 = d[l1];
15510	h = g - d[l];
15511	if (l2 > *n) {
15512	goto L145;
15513	}
15514
15515	i_2 = *n;
15516	for (i = l2; i <= i_2; ++i) {
15517	/* L140: */
15518	d[i] -= h;
15519	}
15520
15521	L145:
15522	f += h;
15523	/* .......... QL TRANSFORMATION .......... */
15524	p = d[m];
15525	c = 1.;
15526	c2 = c;
15527	el1 = e[l1];
15528	s = 0.;
15529	mml = m - l;
15530	/* .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... */
15531	i_2 = mml;
15532	for (ii = 1; ii <= i_2; ++ii) {
15533	c3 = c2;
15534	c2 = c;
15535	s2 = s;
15536	i = m - ii;
15537	g = c * e[i];
15538	h = c * p;
15539	r = pythag_(&p, &e[i]);
15540	e[i + 1] = s * r;
15541	s = e[i] / r;
15542	c = p / r;
15543	p = c * d[i] - s * g;
15544	d[i + 1] = h + s * (c * g + s * d[i]);
15545	/* .......... FORM VECTOR .......... */
15546	i_3 = *n;
15547	for (k = 1; k <= i_3; ++k) {
15548	h = z[k + (i + 1) * z_dim1];
15549	z[k + (i + 1) * z_dim1] = s * z[k + i * z_dim1] + c * h;
15550	z[k + i * z_dim1] = c * z[k + i * z_dim1] - s * h;
15551	/* L180: */
15552	}
15553
15554	/* L200: */
15555	}
15556
15557	p = -s * s2 * c3 * el1 * e[l] / dl1;
15558	e[l] = s * p;
15559	d[l] = c * p;
15560	tst2 = tst1 + (d_1 = e[l], abs(d_1));
15561	if (tst2 > tst1) {
15562	goto L130;
15563	}
15564	L220:
15565	d[l] += f;
15566	/* L240: */
15567	}
15568	/* .......... ORDER EIGENVALUES AND EIGENVECTORS .......... */
15569	i_1 = *n;
15570	for (ii = 2; ii <= i_1; ++ii) {
15571	i = ii - 1;
15572	k = i;
15573	p = d[i];
15574
15575	i_2 = *n;
15576	for (j = ii; j <= i_2; ++j) {
15577	if (d[j] >= p) {
15578	goto L260;
15579	}
15580	k = j;
15581	p = d[j];
15582	L260:
15583	;
15584	}
15585
15586	if (k == i) {
15587	goto L300;
15588	}
15589	d[k] = d[i];
15590	d[i] = p;
15591
15592	i_2 = *n;
15593	for (j = 1; j <= i_2; ++j) {
15594	p = z[j + i * z_dim1];
15595	z[j + i * z_dim1] = z[j + k * z_dim1];
15596	z[j + k * z_dim1] = p;
15597	/* L280: */
15598	}
15599
15600	L300:
15601	;
15602	}
15603
15604	goto L1001;
15605	/* .......... SET ERROR -- NO CONVERGENCE TO AN */
15606	/* EIGENVALUE AFTER 30 ITERATIONS .......... */
15607	L1000:
15608	*ierr = l;
15609	L1001:
15610	return 0;
15611	} /* tql2_ */
15612
15613	/* Subroutine / int tqlrat_(integer n, doublereal d, doublereal e2,
15614	integer *ierr)
15615	{
15616	/* System generated locals */
15617	integer i_1, i_2;
15618	doublereal d_1, d_2;
15619
15620	/* Builtin functions */
15621	double sqrt(doublereal), d_sign(doublereal , doublereal );
15622
15623	/* Local variables */
15624	static doublereal b, c, f, g, h;
15625	static integer i, j, l, m;
15626	static doublereal p, r, s, t;
15627	static integer l1, ii;
15628	extern doublereal pythag_(doublereal , doublereal ), epslon_(doublereal
15629	*);
15630	static integer mml;
15631
15632
15633
15634	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQLRAT, */
15635	/* ALGORITHM 464, COMM. ACM 16, 689(1973) BY REINSCH. */
15636
15637	/* THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC */
15638	/* TRIDIAGONAL MATRIX BY THE RATIONAL QL METHOD. */
15639
15640	/* ON INPUT */
15641
15642	/* N IS THE ORDER OF THE MATRIX. */
15643
15644	/* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */
15645
15646	/* E2 CONTAINS THE SQUARES OF THE SUBDIAGONAL ELEMENTS OF THE */
15647	/* INPUT MATRIX IN ITS LAST N-1 POSITIONS. E2(1) IS ARBITRARY.
15648	*/
15649
15650	/* ON OUTPUT */
15651
15652	/* D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN */
15653	/* ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND */
15654	/* ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE */
15655	/* THE SMALLEST EIGENVALUES. */
15656
15657	/* E2 HAS BEEN DESTROYED. */
15658
15659	/* IERR IS SET TO */
15660	/* ZERO FOR NORMAL RETURN, */
15661	/* J IF THE J-TH EIGENVALUE HAS NOT BEEN */
15662	/* DETERMINED AFTER 30 ITERATIONS. */
15663
15664	/* CALLS PYTHAG FOR DSQRT(AA + BB) . */
15665
15666	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
15667	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
15668	*/
15669
15670	/* THIS VERSION DATED AUGUST 1983. */
15671
15672	/* ------------------------------------------------------------------
15673	*/
15674
15675	/* Parameter adjustments */
15676	--e2;
15677	--d;
15678
15679	/* Function Body */
15680	*ierr = 0;
15681	if (*n == 1) {
15682	goto L1001;
15683	}
15684
15685	i_1 = *n;
15686	for (i = 2; i <= i_1; ++i) {
15687	/* L100: */
15688	e2[i - 1] = e2[i];
15689	}
15690
15691	f = 0.;
15692	t = 0.;
15693	e2[*n] = 0.;
15694
15695	i_1 = *n;
15696	for (l = 1; l <= i_1; ++l) {
15697	j = 0;
15698	h = (d_1 = d[l], abs(d_1)) + sqrt(e2[l]);
15699	if (t > h) {
15700	goto L105;
15701	}
15702	t = h;
15703	b = epslon_(&t);
15704	c = b * b;
15705	/* .......... LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT ........
15706	.. */
15707	L105:
15708	i_2 = *n;
15709	for (m = l; m <= i_2; ++m) {
15710	if (e2[m] <= c) {
15711	goto L120;
15712	}
15713	/* .......... E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT */
15714	/* THROUGH THE BOTTOM OF THE LOOP .......... */
15715	/* L110: */
15716	}
15717
15718	L120:
15719	if (m == l) {
15720	goto L210;
15721	}
15722	L130:
15723	if (j == 30) {
15724	goto L1000;
15725	}
15726	++j;
15727	/* .......... FORM SHIFT .......... */
15728	l1 = l + 1;
15729	s = sqrt(e2[l]);
15730	g = d[l];
15731	p = (d[l1] - g) / (s * 2.);
15732	r = pythag_(&p, &c_b141);
15733	d[l] = s / (p + d_sign(&r, &p));
15734	h = g - d[l];
15735
15736	i_2 = *n;
15737	for (i = l1; i <= i_2; ++i) {
15738	/* L140: */
15739	d[i] -= h;
15740	}
15741
15742	f += h;
15743	/* .......... RATIONAL QL TRANSFORMATION .......... */
15744	g = d[m];
15745	if (g == 0.) {
15746	g = b;
15747	}
15748	h = g;
15749	s = 0.;
15750	mml = m - l;
15751	/* .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... */
15752	i_2 = mml;
15753	for (ii = 1; ii <= i_2; ++ii) {
15754	i = m - ii;
15755	p = g * h;
15756	r = p + e2[i];
15757	e2[i + 1] = s * r;
15758	s = e2[i] / r;
15759	d[i + 1] = h + s * (h + d[i]);
15760	g = d[i] - e2[i] / g;
15761	if (g == 0.) {
15762	g = b;
15763	}
15764	h = g * p / r;
15765	/* L200: */
15766	}
15767
15768	e2[l] = s * g;
15769	d[l] = h;
15770	/* .......... GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST ........
15771	.. */
15772	if (h == 0.) {
15773	goto L210;
15774	}
15775	if ((d_1 = e2[l], abs(d_1)) <= (d_2 = c / h, abs(d_2))) {
15776	goto L210;
15777	}
15778	e2[l] = h * e2[l];
15779	if (e2[l] != 0.) {
15780	goto L130;
15781	}
15782	L210:
15783	p = d[l] + f;
15784	/* .......... ORDER EIGENVALUES .......... */
15785	if (l == 1) {
15786	goto L250;
15787	}
15788	/* .......... FOR I=L STEP -1 UNTIL 2 DO -- .......... */
15789	i_2 = l;
15790	for (ii = 2; ii <= i_2; ++ii) {
15791	i = l + 2 - ii;
15792	if (p >= d[i - 1]) {
15793	goto L270;
15794	}
15795	d[i] = d[i - 1];
15796	/* L230: */
15797	}
15798
15799	L250:
15800	i = 1;
15801	L270:
15802	d[i] = p;
15803	/* L290: */
15804	}
15805
15806	goto L1001;
15807	/* .......... SET ERROR -- NO CONVERGENCE TO AN */
15808	/* EIGENVALUE AFTER 30 ITERATIONS .......... */
15809	L1000:
15810	*ierr = l;
15811	L1001:
15812	return 0;
15813	} /* tqlrat_ */
15814
15815	/* Subroutine / int trbak1_(integer nm, integer n, doublereal a,
15816	doublereal e, integer m, doublereal *z)
15817	{
15818	/* System generated locals */
15819	integer a_dim1, a_offset, z_dim1, z_offset, i_1, i_2, i_3;
15820
15821	/* Local variables */
15822	static integer i, j, k, l;
15823	static doublereal s;
15824
15825
15826
15827	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK1, */
15828	/* NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. */
15829	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). */
15830
15831	/* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC */
15832	/* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */
15833	/* SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY TRED1. */
15834
15835	/* ON INPUT */
15836
15837	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
15838	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
15839	/* DIMENSION STATEMENT. */
15840
15841	/* N IS THE ORDER OF THE MATRIX. */
15842
15843	/* A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- */
15844	/* FORMATIONS USED IN THE REDUCTION BY TRED1 */
15845	/* IN ITS STRICT LOWER TRIANGLE. */
15846
15847	/* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL */
15848	/* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */
15849
15850	/* M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. */
15851
15852	/* Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED */
15853	/* IN ITS FIRST M COLUMNS. */
15854
15855	/* ON OUTPUT */
15856
15857	/* Z CONTAINS THE TRANSFORMED EIGENVECTORS */
15858	/* IN ITS FIRST M COLUMNS. */
15859
15860	/* NOTE THAT TRBAK1 PRESERVES VECTOR EUCLIDEAN NORMS. */
15861
15862	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
15863	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
15864	*/
15865
15866	/* THIS VERSION DATED AUGUST 1983. */
15867
15868	/* ------------------------------------------------------------------
15869	*/
15870
15871	/* Parameter adjustments */
15872	--e;
15873	a_dim1 = *nm;
15874	a_offset = a_dim1 + 1;
15875	a -= a_offset;
15876	z_dim1 = *nm;
15877	z_offset = z_dim1 + 1;
15878	z -= z_offset;
15879
15880	/* Function Body */
15881	if (*m == 0) {
15882	goto L200;
15883	}
15884	if (*n == 1) {
15885	goto L200;
15886	}
15887
15888	i_1 = *n;
15889	for (i = 2; i <= i_1; ++i) {
15890	l = i - 1;
15891	if (e[i] == 0.) {
15892	goto L140;
15893	}
15894
15895	i_2 = *m;
15896	for (j = 1; j <= i_2; ++j) {
15897	s = 0.;
15898
15899	i_3 = l;
15900	for (k = 1; k <= i_3; ++k) {
15901	/* L110: */
15902	s += a[i + k * a_dim1] * z[k + j * z_dim1];
15903	}
15904	/* .......... DIVISOR BELOW IS NEGATIVE OF H FORMED IN TRED1.
15905	*/
15906	/* DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ......
15907	.... */
15908	s = s / a[i + l * a_dim1] / e[i];
15909
15910	i_3 = l;
15911	for (k = 1; k <= i_3; ++k) {
15912	/* L120: */
15913	z[k + j * z_dim1] += s * a[i + k * a_dim1];
15914	}
15915
15916	/* L130: */
15917	}
15918
15919	L140:
15920	;
15921	}
15922
15923	L200:
15924	return 0;
15925	} /* trbak1_ */
15926
15927	/* Subroutine / int trbak3_(integer nm, integer n, integer /nv/, doublereal
15928	a, integer m, doublereal *z)
15929	{
15930	/* System generated locals */
15931	integer z_dim1, z_offset, i_1, i_2, i_3;
15932
15933	/* Local variables */
15934	static doublereal h;
15935	static integer i, j, k, l;
15936	static doublereal s;
15937	static integer ik, iz;
15938
15939
15940
15941	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK3, */
15942	/* NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. */
15943	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). */
15944
15945	/* THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC */
15946	/* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING */
15947	/* SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY TRED3. */
15948
15949	/* ON INPUT */
15950
15951	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
15952	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
15953	/* DIMENSION STATEMENT. */
15954
15955	/* N IS THE ORDER OF THE MATRIX. */
15956
15957	/* NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A */
15958	/* AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT. */
15959
15960	/* A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANSFORMATIONS */
15961	/* USED IN THE REDUCTION BY TRED3 IN ITS FIRST */
15962	/* N(N+1)/2 POSITIONS. /
15963
15964	/* M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. */
15965
15966	/* Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED */
15967	/* IN ITS FIRST M COLUMNS. */
15968
15969	/* ON OUTPUT */
15970
15971	/* Z CONTAINS THE TRANSFORMED EIGENVECTORS */
15972	/* IN ITS FIRST M COLUMNS. */
15973
15974	/* NOTE THAT TRBAK3 PRESERVES VECTOR EUCLIDEAN NORMS. */
15975
15976	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
15977	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
15978	*/
15979
15980	/* THIS VERSION DATED AUGUST 1983. */
15981
15982	/* ------------------------------------------------------------------
15983	*/
15984
15985	/* Parameter adjustments */
15986	--a;
15987	z_dim1 = *nm;
15988	z_offset = z_dim1 + 1;
15989	z -= z_offset;
15990
15991	/* Function Body */
15992	if (*m == 0) {
15993	goto L200;
15994	}
15995	if (*n == 1) {
15996	goto L200;
15997	}
15998
15999	i_1 = *n;
16000	for (i = 2; i <= i_1; ++i) {
16001	l = i - 1;
16002	iz = i * l / 2;
16003	ik = iz + i;
16004	h = a[ik];
16005	if (h == 0.) {
16006	goto L140;
16007	}
16008
16009	i_2 = *m;
16010	for (j = 1; j <= i_2; ++j) {
16011	s = 0.;
16012	ik = iz;
16013
16014	i_3 = l;
16015	for (k = 1; k <= i_3; ++k) {
16016	++ik;
16017	s += a[ik] * z[k + j * z_dim1];
16018	/* L110: */
16019	}
16020	/* .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ......
16021	.... */
16022	s = s / h / h;
16023	ik = iz;
16024
16025	i_3 = l;
16026	for (k = 1; k <= i_3; ++k) {
16027	++ik;
16028	z[k + j * z_dim1] -= s * a[ik];
16029	/* L120: */
16030	}
16031
16032	/* L130: */
16033	}
16034
16035	L140:
16036	;
16037	}
16038
16039	L200:
16040	return 0;
16041	} /* trbak3_ */
16042
16043	/* Subroutine / int tred1_(integer nm, integer n, doublereal a,
16044	doublereal d, doublereal e, doublereal *e2)
16045	{
16046	/* System generated locals */
16047	integer a_dim1, a_offset, i_1, i_2, i_3;
16048	doublereal d_1;
16049
16050	/* Builtin functions */
16051	double sqrt(doublereal), d_sign(doublereal , doublereal );
16052
16053	/* Local variables */
16054	static doublereal f, g, h;
16055	static integer i, j, k, l;
16056	static doublereal scale;
16057	static integer ii, jp1;
16058
16059
16060
16061	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED1, */
16062	/* NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. */
16063	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). */
16064
16065	/* THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX */
16066	/* TO A SYMMETRIC TRIDIAGONAL MATRIX USING */
16067	/* ORTHOGONAL SIMILARITY TRANSFORMATIONS. */
16068
16069	/* ON INPUT */
16070
16071	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
16072	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
16073	/* DIMENSION STATEMENT. */
16074
16075	/* N IS THE ORDER OF THE MATRIX. */
16076
16077	/* A CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE */
16078	/* LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED. */
16079
16080	/* ON OUTPUT */
16081
16082	/* A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- */
16083	/* FORMATIONS USED IN THE REDUCTION IN ITS STRICT LOWER */
16084	/* TRIANGLE. THE FULL UPPER TRIANGLE OF A IS UNALTERED. */
16085
16086	/* D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. */
16087
16088	/* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL */
16089	/* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. */
16090
16091	/* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */
16092	/* E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. */
16093
16094	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
16095	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
16096	*/
16097
16098	/* THIS VERSION DATED AUGUST 1983. */
16099
16100	/* ------------------------------------------------------------------
16101	*/
16102
16103	/* Parameter adjustments */
16104	--e2;
16105	--e;
16106	--d;
16107	a_dim1 = *nm;
16108	a_offset = a_dim1 + 1;
16109	a -= a_offset;
16110
16111	/* Function Body */
16112	i_1 = *n;
16113	for (i = 1; i <= i_1; ++i) {
16114	d[i] = a[n + i a_dim1];
16115	a[n + i a_dim1] = a[i + i * a_dim1];
16116	/* L100: */
16117	}
16118	/* .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... */
16119	i_1 = *n;
16120	for (ii = 1; ii <= i_1; ++ii) {
16121	i = *n + 1 - ii;
16122	l = i - 1;
16123	h = 0.;
16124	scale = 0.;
16125	if (l < 1) {
16126	goto L130;
16127	}
16128	/* .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... */
16129	i_2 = l;
16130	for (k = 1; k <= i_2; ++k) {
16131	/* L120: */
16132	scale += (d_1 = d[k], abs(d_1));
16133	}
16134
16135	if (scale != 0.) {
16136	goto L140;
16137	}
16138
16139	i_2 = l;
16140	for (j = 1; j <= i_2; ++j) {
16141	d[j] = a[l + j * a_dim1];
16142	a[l + j * a_dim1] = a[i + j * a_dim1];
16143	a[i + j * a_dim1] = 0.;
16144	/* L125: */
16145	}
16146
16147	L130:
16148	e[i] = 0.;
16149	e2[i] = 0.;
16150	goto L300;
16151
16152	L140:
16153	i_2 = l;
16154	for (k = 1; k <= i_2; ++k) {
16155	d[k] /= scale;
16156	h += d[k] * d[k];
16157	/* L150: */
16158	}
16159
16160	e2[i] = scale * scale * h;
16161	f = d[l];
16162	d_1 = sqrt(h);
16163	g = -d_sign(&d_1, &f);
16164	e[i] = scale * g;
16165	h -= f * g;
16166	d[l] = f - g;
16167	if (l == 1) {
16168	goto L285;
16169	}
16170	/* .......... FORM AU .......... /
16171	i_2 = l;
16172	for (j = 1; j <= i_2; ++j) {
16173	/* L170: */
16174	e[j] = 0.;
16175	}
16176
16177	i_2 = l;
16178	for (j = 1; j <= i_2; ++j) {
16179	f = d[j];
16180	g = e[j] + a[j + j * a_dim1] * f;
16181	jp1 = j + 1;
16182	if (l < jp1) {
16183	goto L220;
16184	}
16185
16186	i_3 = l;
16187	for (k = jp1; k <= i_3; ++k) {
16188	g += a[k + j * a_dim1] * d[k];
16189	e[k] += a[k + j * a_dim1] * f;
16190	/* L200: */
16191	}
16192
16193	L220:
16194	e[j] = g;
16195	/* L240: */
16196	}
16197	/* .......... FORM P .......... */
16198	f = 0.;
16199
16200	i_2 = l;
16201	for (j = 1; j <= i_2; ++j) {
16202	e[j] /= h;
16203	f += e[j] * d[j];
16204	/* L245: */
16205	}
16206
16207	h = f / (h + h);
16208	/* .......... FORM Q .......... */
16209	i_2 = l;
16210	for (j = 1; j <= i_2; ++j) {
16211	/* L250: */
16212	e[j] -= h * d[j];
16213	}
16214	/* .......... FORM REDUCED A .......... */
16215	i_2 = l;
16216	for (j = 1; j <= i_2; ++j) {
16217	f = d[j];
16218	g = e[j];
16219
16220	i_3 = l;
16221	for (k = j; k <= i_3; ++k) {
16222	/* L260: */
16223	a[k + j * a_dim1] = a[k + j * a_dim1] - f * e[k] - g * d[k];
16224	}
16225
16226	/* L280: */
16227	}
16228
16229	L285:
16230	i_2 = l;
16231	for (j = 1; j <= i_2; ++j) {
16232	f = d[j];
16233	d[j] = a[l + j * a_dim1];
16234	a[l + j * a_dim1] = a[i + j * a_dim1];
16235	a[i + j * a_dim1] = f * scale;
16236	/* L290: */
16237	}
16238
16239	L300:
16240	;
16241	}
16242
16243	return 0;
16244	} /* tred1_ */
16245
16246	/* Subroutine / int tred2_(integer nm, integer n, doublereal a,
16247	doublereal d, doublereal e, doublereal *z)
16248	{
16249	/* System generated locals */
16250	integer a_dim1, a_offset, z_dim1, z_offset, i_1, i_2, i_3;
16251	doublereal d_1;
16252
16253	/* Builtin functions */
16254	double sqrt(doublereal), d_sign(doublereal , doublereal );
16255
16256	/* Local variables */
16257	static doublereal f, g, h;
16258	static integer i, j, k, l;
16259	static doublereal scale, hh;
16260	static integer ii, jp1;
16261
16262
16263
16264	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED2, */
16265	/* NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. */
16266	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). */
16267
16268	/* THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX TO A */
16269	/* SYMMETRIC TRIDIAGONAL MATRIX USING AND ACCUMULATING */
16270	/* ORTHOGONAL SIMILARITY TRANSFORMATIONS. */
16271
16272	/* ON INPUT */
16273
16274	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
16275	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
16276	/* DIMENSION STATEMENT. */
16277
16278	/* N IS THE ORDER OF THE MATRIX. */
16279
16280	/* A CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE */
16281	/* LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED. */
16282
16283	/* ON OUTPUT */
16284
16285	/* D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. */
16286
16287	/* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL */
16288	/* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. */
16289
16290	/* Z CONTAINS THE ORTHOGONAL TRANSFORMATION MATRIX */
16291	/* PRODUCED IN THE REDUCTION. */
16292
16293	/* A AND Z MAY COINCIDE. IF DISTINCT, A IS UNALTERED. */
16294
16295	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
16296	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
16297	*/
16298
16299	/* THIS VERSION DATED AUGUST 1983. */
16300
16301	/* ------------------------------------------------------------------
16302	*/
16303
16304	/* Parameter adjustments */
16305	z_dim1 = *nm;
16306	z_offset = z_dim1 + 1;
16307	z -= z_offset;
16308	--e;
16309	--d;
16310	a_dim1 = *nm;
16311	a_offset = a_dim1 + 1;
16312	a -= a_offset;
16313
16314	/* Function Body */
16315	i_1 = *n;
16316	for (i = 1; i <= i_1; ++i) {
16317
16318	i_2 = *n;
16319	for (j = i; j <= i_2; ++j) {
16320	/* L80: */
16321	z[j + i * z_dim1] = a[j + i * a_dim1];
16322	}
16323
16324	d[i] = a[n + i a_dim1];
16325	/* L100: */
16326	}
16327
16328	if (*n == 1) {
16329	goto L510;
16330	}
16331	/* .......... FOR I=N STEP -1 UNTIL 2 DO -- .......... */
16332	i_1 = *n;
16333	for (ii = 2; ii <= i_1; ++ii) {
16334	i = *n + 2 - ii;
16335	l = i - 1;
16336	h = 0.;
16337	scale = 0.;
16338	if (l < 2) {
16339	goto L130;
16340	}
16341	/* .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... */
16342	i_2 = l;
16343	for (k = 1; k <= i_2; ++k) {
16344	/* L120: */
16345	scale += (d_1 = d[k], abs(d_1));
16346	}
16347
16348	if (scale != 0.) {
16349	goto L140;
16350	}
16351	L130:
16352	e[i] = d[l];
16353
16354	i_2 = l;
16355	for (j = 1; j <= i_2; ++j) {
16356	d[j] = z[l + j * z_dim1];
16357	z[i + j * z_dim1] = 0.;
16358	z[j + i * z_dim1] = 0.;
16359	/* L135: */
16360	}
16361
16362	goto L290;
16363
16364	L140:
16365	i_2 = l;
16366	for (k = 1; k <= i_2; ++k) {
16367	d[k] /= scale;
16368	h += d[k] * d[k];
16369	/* L150: */
16370	}
16371
16372	f = d[l];
16373	d_1 = sqrt(h);
16374	g = -d_sign(&d_1, &f);
16375	e[i] = scale * g;
16376	h -= f * g;
16377	d[l] = f - g;
16378	/* .......... FORM AU .......... /
16379	i_2 = l;
16380	for (j = 1; j <= i_2; ++j) {
16381	/* L170: */
16382	e[j] = 0.;
16383	}
16384
16385	i_2 = l;
16386	for (j = 1; j <= i_2; ++j) {
16387	f = d[j];
16388	z[j + i * z_dim1] = f;
16389	g = e[j] + z[j + j * z_dim1] * f;
16390	jp1 = j + 1;
16391	if (l < jp1) {
16392	goto L220;
16393	}
16394
16395	i_3 = l;
16396	for (k = jp1; k <= i_3; ++k) {
16397	g += z[k + j * z_dim1] * d[k];
16398	e[k] += z[k + j * z_dim1] * f;
16399	/* L200: */
16400	}
16401
16402	L220:
16403	e[j] = g;
16404	/* L240: */
16405	}
16406	/* .......... FORM P .......... */
16407	f = 0.;
16408
16409	i_2 = l;
16410	for (j = 1; j <= i_2; ++j) {
16411	e[j] /= h;
16412	f += e[j] * d[j];
16413	/* L245: */
16414	}
16415
16416	hh = f / (h + h);
16417	/* .......... FORM Q .......... */
16418	i_2 = l;
16419	for (j = 1; j <= i_2; ++j) {
16420	/* L250: */
16421	e[j] -= hh * d[j];
16422	}
16423	/* .......... FORM REDUCED A .......... */
16424	i_2 = l;
16425	for (j = 1; j <= i_2; ++j) {
16426	f = d[j];
16427	g = e[j];
16428
16429	i_3 = l;
16430	for (k = j; k <= i_3; ++k) {
16431	/* L260: */
16432	z[k + j * z_dim1] = z[k + j * z_dim1] - f * e[k] - g * d[k];
16433	}
16434
16435	d[j] = z[l + j * z_dim1];
16436	z[i + j * z_dim1] = 0.;
16437	/* L280: */
16438	}
16439
16440	L290:
16441	d[i] = h;
16442	/* L300: */
16443	}
16444	/* .......... ACCUMULATION OF TRANSFORMATION MATRICES .......... */
16445	i_1 = *n;
16446	for (i = 2; i <= i_1; ++i) {
16447	l = i - 1;
16448	z[n + l z_dim1] = z[l + l * z_dim1];
16449	z[l + l * z_dim1] = 1.;
16450	h = d[i];
16451	if (h == 0.) {
16452	goto L380;
16453	}
16454
16455	i_2 = l;
16456	for (k = 1; k <= i_2; ++k) {
16457	/* L330: */
16458	d[k] = z[k + i * z_dim1] / h;
16459	}
16460
16461	i_2 = l;
16462	for (j = 1; j <= i_2; ++j) {
16463	g = 0.;
16464
16465	i_3 = l;
16466	for (k = 1; k <= i_3; ++k) {
16467	/* L340: */
16468	g += z[k + i * z_dim1] * z[k + j * z_dim1];
16469	}
16470
16471	i_3 = l;
16472	for (k = 1; k <= i_3; ++k) {
16473	z[k + j * z_dim1] -= g * d[k];
16474	/* L360: */
16475	}
16476	}
16477
16478	L380:
16479	i_3 = l;
16480	for (k = 1; k <= i_3; ++k) {
16481	/* L400: */
16482	z[k + i * z_dim1] = 0.;
16483	}
16484
16485	/* L500: */
16486	}
16487
16488	L510:
16489	i_1 = *n;
16490	for (i = 1; i <= i_1; ++i) {
16491	d[i] = z[n + i z_dim1];
16492	z[n + i z_dim1] = 0.;
16493	/* L520: */
16494	}
16495
16496	z[n + n * z_dim1] = 1.;
16497	e[1] = 0.;
16498	return 0;
16499	} /* tred2_ */
16500
16501	/* Subroutine / int tred3_(integer n, integer /nv/, doublereal a,
16502	doublereal d, doublereal e, doublereal *e2)
16503	{
16504	/* System generated locals */
16505	integer i_1, i_2, i_3;
16506	doublereal d_1;
16507
16508	/* Builtin functions */
16509	double sqrt(doublereal), d_sign(doublereal , doublereal );
16510
16511	/* Local variables */
16512	static doublereal f, g, h;
16513	static integer i, j, k, l;
16514	static doublereal scale, hh;
16515	static integer ii, jk, iz, jm1;
16516
16517
16518
16519	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED3, */
16520	/* NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. */
16521	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). */
16522
16523	/* THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX, STORED AS */
16524	/* A ONE-DIMENSIONAL ARRAY, TO A SYMMETRIC TRIDIAGONAL MATRIX */
16525	/* USING ORTHOGONAL SIMILARITY TRANSFORMATIONS. */
16526
16527	/* ON INPUT */
16528
16529	/* N IS THE ORDER OF THE MATRIX. */
16530
16531	/* NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A */
16532	/* AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT. */
16533
16534	/* A CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC */
16535	/* INPUT MATRIX, STORED ROW-WISE AS A ONE-DIMENSIONAL */
16536	/* ARRAY, IN ITS FIRST N(N+1)/2 POSITIONS. /
16537
16538	/* ON OUTPUT */
16539
16540	/* A CONTAINS INFORMATION ABOUT THE ORTHOGONAL */
16541	/* TRANSFORMATIONS USED IN THE REDUCTION. */
16542
16543	/* D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. */
16544
16545	/* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL */
16546	/* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. */
16547
16548	/* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */
16549	/* E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. */
16550
16551	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
16552	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
16553	*/
16554
16555	/* THIS VERSION DATED AUGUST 1983. */
16556
16557	/* ------------------------------------------------------------------
16558	*/
16559
16560	/* .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... */
16561	/* Parameter adjustments */
16562	--e2;
16563	--e;
16564	--d;
16565	--a;
16566
16567	/* Function Body */
16568	i_1 = *n;
16569	for (ii = 1; ii <= i_1; ++ii) {
16570	i = *n + 1 - ii;
16571	l = i - 1;
16572	iz = i * l / 2;
16573	h = 0.;
16574	scale = 0.;
16575	if (l < 1) {
16576	goto L130;
16577	}
16578	/* .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... */
16579	i_2 = l;
16580	for (k = 1; k <= i_2; ++k) {
16581	++iz;
16582	d[k] = a[iz];
16583	scale += (d_1 = d[k], abs(d_1));
16584	/* L120: */
16585	}
16586
16587	if (scale != 0.) {
16588	goto L140;
16589	}
16590	L130:
16591	e[i] = 0.;
16592	e2[i] = 0.;
16593	goto L290;
16594
16595	L140:
16596	i_2 = l;
16597	for (k = 1; k <= i_2; ++k) {
16598	d[k] /= scale;
16599	h += d[k] * d[k];
16600	/* L150: */
16601	}
16602
16603	e2[i] = scale * scale * h;
16604	f = d[l];
16605	d_1 = sqrt(h);
16606	g = -d_sign(&d_1, &f);
16607	e[i] = scale * g;
16608	h -= f * g;
16609	d[l] = f - g;
16610	a[iz] = scale * d[l];
16611	if (l == 1) {
16612	goto L290;
16613	}
16614	jk = 1;
16615
16616	i_2 = l;
16617	for (j = 1; j <= i_2; ++j) {
16618	f = d[j];
16619	g = 0.;
16620	jm1 = j - 1;
16621	if (jm1 < 1) {
16622	goto L220;
16623	}
16624
16625	i_3 = jm1;
16626	for (k = 1; k <= i_3; ++k) {
16627	g += a[jk] * d[k];
16628	e[k] += a[jk] * f;
16629	++jk;
16630	/* L200: */
16631	}
16632
16633	L220:
16634	e[j] = g + a[jk] * f;
16635	++jk;
16636	/* L240: */
16637	}
16638	/* .......... FORM P .......... */
16639	f = 0.;
16640
16641	i_2 = l;
16642	for (j = 1; j <= i_2; ++j) {
16643	e[j] /= h;
16644	f += e[j] * d[j];
16645	/* L245: */
16646	}
16647
16648	hh = f / (h + h);
16649	/* .......... FORM Q .......... */
16650	i_2 = l;
16651	for (j = 1; j <= i_2; ++j) {
16652	/* L250: */
16653	e[j] -= hh * d[j];
16654	}
16655
16656	jk = 1;
16657	/* .......... FORM REDUCED A .......... */
16658	i_2 = l;
16659	for (j = 1; j <= i_2; ++j) {
16660	f = d[j];
16661	g = e[j];
16662
16663	i_3 = j;
16664	for (k = 1; k <= i_3; ++k) {
16665	a[jk] = a[jk] - f * e[k] - g * d[k];
16666	++jk;
16667	/* L260: */
16668	}
16669
16670	/* L280: */
16671	}
16672
16673	L290:
16674	d[i] = a[iz + 1];
16675	a[iz + 1] = scale * sqrt(h);
16676	/* L300: */
16677	}
16678
16679	return 0;
16680	} /* tred3_ */
16681
16682	/* Subroutine / int tridib_(integer n, doublereal eps1, doublereal d,
16683	doublereal e, doublereal e2, doublereal lb, doublereal ub,
16684	integer m11, integer m, doublereal w, integer ind, integer *ierr,
16685	doublereal rv4, doublereal rv5)
16686	{
16687	/* System generated locals */
16688	integer i_1, i_2;
16689	doublereal d_1, d_2, d_3;
16690
16691	/* Local variables */
16692	static integer i, j, k, l, p, q, r, s;
16693	static doublereal u, v;
16694	static integer m1, m2;
16695	static doublereal t1, t2, x0, x1;
16696	static integer m22, ii;
16697	static doublereal xu;
16698	extern doublereal epslon_(doublereal *);
16699	static integer isturm, tag;
16700	static doublereal tst1, tst2;
16701
16702
16703
16704	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BISECT, */
16705	/* NUM. MATH. 9, 386-393(1967) BY BARTH, MARTIN, AND WILKINSON. */
16706	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 249-256(1971). */
16707
16708	/* THIS SUBROUTINE FINDS THOSE EIGENVALUES OF A TRIDIAGONAL */
16709	/* SYMMETRIC MATRIX BETWEEN SPECIFIED BOUNDARY INDICES, */
16710	/* USING BISECTION. */
16711
16712	/* ON INPUT */
16713
16714	/* N IS THE ORDER OF THE MATRIX. */
16715
16716	/* EPS1 IS AN ABSOLUTE ERROR TOLERANCE FOR THE COMPUTED */
16717	/* EIGENVALUES. IF THE INPUT EPS1 IS NON-POSITIVE, */
16718	/* IT IS RESET FOR EACH SUBMATRIX TO A DEFAULT VALUE, */
16719	/* NAMELY, MINUS THE PRODUCT OF THE RELATIVE MACHINE */
16720	/* PRECISION AND THE 1-NORM OF THE SUBMATRIX. */
16721
16722	/* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */
16723
16724	/* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */
16725	/* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */
16726
16727	/* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */
16728	/* E2(1) IS ARBITRARY. */
16729
16730	/* M11 SPECIFIES THE LOWER BOUNDARY INDEX FOR THE DESIRED */
16731	/* EIGENVALUES. */
16732
16733	/* M SPECIFIES THE NUMBER OF EIGENVALUES DESIRED. THE UPPER */
16734	/* BOUNDARY INDEX M22 IS THEN OBTAINED AS M22=M11+M-1. */
16735
16736	/* ON OUTPUT */
16737
16738	/* EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS */
16739	/* (LAST) DEFAULT VALUE. */
16740
16741	/* D AND E ARE UNALTERED. */
16742
16743	/* ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED */
16744	/* AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE */
16745	/* MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES. */
16746	/* E2(1) IS ALSO SET TO ZERO. */
16747
16748	/* LB AND UB DEFINE AN INTERVAL CONTAINING EXACTLY THE DESIRED */
16749	/* EIGENVALUES. */
16750
16751	/* W CONTAINS, IN ITS FIRST M POSITIONS, THE EIGENVALUES */
16752	/* BETWEEN INDICES M11 AND M22 IN ASCENDING ORDER. */
16753
16754	/* IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES */
16755	/* ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W -- */
16756	/* 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM */
16757	/* THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC..
16758	*/
16759
16760	/* IERR IS SET TO */
16761	/* ZERO FOR NORMAL RETURN, */
16762	/* 3N+1 IF MULTIPLE EIGENVALUES AT INDEX M11 MAKE /
16763	/* UNIQUE SELECTION IMPOSSIBLE, */
16764	/* 3N+2 IF MULTIPLE EIGENVALUES AT INDEX M22 MAKE /
16765	/* UNIQUE SELECTION IMPOSSIBLE. */
16766
16767	/* RV4 AND RV5 ARE TEMPORARY STORAGE ARRAYS. */
16768
16769	/* NOTE THAT SUBROUTINE TQL1, IMTQL1, OR TQLRAT IS GENERALLY FASTER */
16770	/* THAN TRIDIB, IF MORE THAN N/4 EIGENVALUES ARE TO BE FOUND. */
16771
16772	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
16773	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
16774	*/
16775
16776	/* THIS VERSION DATED AUGUST 1983. */
16777
16778	/* ------------------------------------------------------------------
16779	*/
16780
16781	/* Parameter adjustments */
16782	--rv5;
16783	--rv4;
16784	--e2;
16785	--e;
16786	--d;
16787	--ind;
16788	--w;
16789
16790	/* Function Body */
16791	*ierr = 0;
16792	tag = 0;
16793	xu = d[1];
16794	x0 = d[1];
16795	u = 0.;
16796	/* .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES AND DETERMINE AN */
16797	/* INTERVAL CONTAINING ALL THE EIGENVALUES .......... */
16798	i_1 = *n;
16799	for (i = 1; i <= i_1; ++i) {
16800	x1 = u;
16801	u = 0.;
16802	if (i != *n) {
16803	u = (d_1 = e[i + 1], abs(d_1));
16804	}
16805	/* Computing MIN */
16806	d_1 = d[i] - (x1 + u);
16807	xu = min(d_1,xu);
16808	/* Computing MAX */
16809	d_1 = d[i] + (x1 + u);
16810	x0 = max(d_1,x0);
16811	if (i == 1) {
16812	goto L20;
16813	}
16814	tst1 = (d_1 = d[i], abs(d_1)) + (d_2 = d[i - 1], abs(d_2));
16815	tst2 = tst1 + (d_1 = e[i], abs(d_1));
16816	if (tst2 > tst1) {
16817	goto L40;
16818	}
16819	L20:
16820	e2[i] = 0.;
16821	L40:
16822	;
16823	}
16824
16825	x1 = (doublereal) (*n);
16826	/* Computing MAX */
16827	d_2 = abs(xu), d_3 = abs(x0);
16828	d_1 = max(d_2,d_3);
16829	x1 *= epslon_(&d_1);
16830	xu -= x1;
16831	t1 = xu;
16832	x0 += x1;
16833	t2 = x0;
16834	/* .......... DETERMINE AN INTERVAL CONTAINING EXACTLY */
16835	/* THE DESIRED EIGENVALUES .......... */
16836	p = 1;
16837	q = *n;
16838	m1 = *m11 - 1;
16839	if (m1 == 0) {
16840	goto L75;
16841	}
16842	isturm = 1;
16843	L50:
16844	v = x1;
16845	x1 = xu + (x0 - xu) * .5;
16846	if (x1 == v) {
16847	goto L980;
16848	}
16849	goto L320;
16850	L60:
16851	if ((i_1 = s - m1) < 0) {
16852	goto L65;
16853	} else if (i_1 == 0) {
16854	goto L73;
16855	} else {
16856	goto L70;
16857	}
16858	L65:
16859	xu = x1;
16860	goto L50;
16861	L70:
16862	x0 = x1;
16863	goto L50;
16864	L73:
16865	xu = x1;
16866	t1 = x1;
16867	L75:
16868	m22 = m1 + *m;
16869	if (m22 == *n) {
16870	goto L90;
16871	}
16872	x0 = t2;
16873	isturm = 2;
16874	goto L50;
16875	L80:
16876	if ((i_1 = s - m22) < 0) {
16877	goto L65;
16878	} else if (i_1 == 0) {
16879	goto L85;
16880	} else {
16881	goto L70;
16882	}
16883	L85:
16884	t2 = x1;
16885	L90:
16886	q = 0;
16887	r = 0;
16888	/* .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING */
16889	/* INTERVAL BY THE GERSCHGORIN BOUNDS .......... */
16890	L100:
16891	if (r == *m) {
16892	goto L1001;
16893	}
16894	++tag;
16895	p = q + 1;
16896	xu = d[p];
16897	x0 = d[p];
16898	u = 0.;
16899
16900	i_1 = *n;
16901	for (q = p; q <= i_1; ++q) {
16902	x1 = u;
16903	u = 0.;
16904	v = 0.;
16905	if (q == *n) {
16906	goto L110;
16907	}
16908	u = (d_1 = e[q + 1], abs(d_1));
16909	v = e2[q + 1];
16910	L110:
16911	/* Computing MIN */
16912	d_1 = d[q] - (x1 + u);
16913	xu = min(d_1,xu);
16914	/* Computing MAX */
16915	d_1 = d[q] + (x1 + u);
16916	x0 = max(d_1,x0);
16917	if (v == 0.) {
16918	goto L140;
16919	}
16920	/* L120: */
16921	}
16922
16923	L140:
16924	/* Computing MAX */
16925	d_2 = abs(xu), d_3 = abs(x0);
16926	d_1 = max(d_2,d_3);
16927	x1 = epslon_(&d_1);
16928	if (*eps1 <= 0.) {
16929	*eps1 = -x1;
16930	}
16931	if (p != q) {
16932	goto L180;
16933	}
16934	/* .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL .......... */
16935	if (t1 > d[p] \|\| d[p] >= t2) {
16936	goto L940;
16937	}
16938	m1 = p;
16939	m2 = p;
16940	rv5[p] = d[p];
16941	goto L900;
16942	L180:
16943	x1 *= q - p + 1;
16944	/* Computing MAX */
16945	d_1 = t1, d_2 = xu - x1;
16946	*lb = max(d_1,d_2);
16947	/* Computing MIN */
16948	d_1 = t2, d_2 = x0 + x1;
16949	*ub = min(d_1,d_2);
16950	x1 = *lb;
16951	isturm = 3;
16952	goto L320;
16953	L200:
16954	m1 = s + 1;
16955	x1 = *ub;
16956	isturm = 4;
16957	goto L320;
16958	L220:
16959	m2 = s;
16960	if (m1 > m2) {
16961	goto L940;
16962	}
16963	/* .......... FIND ROOTS BY BISECTION .......... */
16964	x0 = *ub;
16965	isturm = 5;
16966
16967	i_1 = m2;
16968	for (i = m1; i <= i_1; ++i) {
16969	rv5[i] = *ub;
16970	rv4[i] = *lb;
16971	/* L240: */
16972	}
16973	/* .......... LOOP FOR K-TH EIGENVALUE */
16974	/* FOR K=M2 STEP -1 UNTIL M1 DO -- */
16975	/* (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) ..........
16976	*/
16977	k = m2;
16978	L250:
16979	xu = *lb;
16980	/* .......... FOR I=K STEP -1 UNTIL M1 DO -- .......... */
16981	i_1 = k;
16982	for (ii = m1; ii <= i_1; ++ii) {
16983	i = m1 + k - ii;
16984	if (xu >= rv4[i]) {
16985	goto L260;
16986	}
16987	xu = rv4[i];
16988	goto L280;
16989	L260:
16990	;
16991	}
16992
16993	L280:
16994	if (x0 > rv5[k]) {
16995	x0 = rv5[k];
16996	}
16997	/* .......... NEXT BISECTION STEP .......... */
16998	L300:
16999	x1 = (xu + x0) * .5;
17000	if (x0 - xu <= abs(*eps1)) {
17001	goto L420;
17002	}
17003	tst1 = (abs(xu) + abs(x0)) * 2.;
17004	tst2 = tst1 + (x0 - xu);
17005	if (tst2 == tst1) {
17006	goto L420;
17007	}
17008	/* .......... IN-LINE PROCEDURE FOR STURM SEQUENCE .......... */
17009	L320:
17010	s = p - 1;
17011	u = 1.;
17012
17013	i_1 = q;
17014	for (i = p; i <= i_1; ++i) {
17015	if (u != 0.) {
17016	goto L325;
17017	}
17018	v = (d_1 = e[i], abs(d_1)) / epslon_(&c_b141);
17019	if (e2[i] == 0.) {
17020	v = 0.;
17021	}
17022	goto L330;
17023	L325:
17024	v = e2[i] / u;
17025	L330:
17026	u = d[i] - x1 - v;
17027	if (u < 0.) {
17028	++s;
17029	}
17030	/* L340: */
17031	}
17032
17033	switch (isturm) {
17034	case 1: goto L60;
17035	case 2: goto L80;
17036	case 3: goto L200;
17037	case 4: goto L220;
17038	case 5: goto L360;
17039	}
17040	/* .......... REFINE INTERVALS .......... */
17041	L360:
17042	if (s >= k) {
17043	goto L400;
17044	}
17045	xu = x1;
17046	if (s >= m1) {
17047	goto L380;
17048	}
17049	rv4[m1] = x1;
17050	goto L300;
17051	L380:
17052	rv4[s + 1] = x1;
17053	if (rv5[s] > x1) {
17054	rv5[s] = x1;
17055	}
17056	goto L300;
17057	L400:
17058	x0 = x1;
17059	goto L300;
17060	/* .......... K-TH EIGENVALUE FOUND .......... */
17061	L420:
17062	rv5[k] = x1;
17063	--k;
17064	if (k >= m1) {
17065	goto L250;
17066	}
17067	/* .......... ORDER EIGENVALUES TAGGED WITH THEIR */
17068	/* SUBMATRIX ASSOCIATIONS .......... */
17069	L900:
17070	s = r;
17071	r = r + m2 - m1 + 1;
17072	j = 1;
17073	k = m1;
17074
17075	i_1 = r;
17076	for (l = 1; l <= i_1; ++l) {
17077	if (j > s) {
17078	goto L910;
17079	}
17080	if (k > m2) {
17081	goto L940;
17082	}
17083	if (rv5[k] >= w[l]) {
17084	goto L915;
17085	}
17086
17087	i_2 = s;
17088	for (ii = j; ii <= i_2; ++ii) {
17089	i = l + s - ii;
17090	w[i + 1] = w[i];
17091	ind[i + 1] = ind[i];
17092	/* L905: */
17093	}
17094
17095	L910:
17096	w[l] = rv5[k];
17097	ind[l] = tag;
17098	++k;
17099	goto L920;
17100	L915:
17101	++j;
17102	L920:
17103	;
17104	}
17105
17106	L940:
17107	if (q < *n) {
17108	goto L100;
17109	}
17110	goto L1001;
17111	/* .......... SET ERROR -- INTERVAL CANNOT BE FOUND CONTAINING */
17112	/* EXACTLY THE DESIRED EIGENVALUES .......... */
17113	L980:
17114	ierr = n * 3 + isturm;
17115	L1001:
17116	*lb = t1;
17117	*ub = t2;
17118	return 0;
17119	} /* tridib_ */
17120
17121	/* Subroutine / int tsturm_(integer nm, integer n, doublereal eps1,
17122	doublereal d, doublereal e, doublereal e2, doublereal lb,
17123	doublereal ub, integer mm, integer m, doublereal w, doublereal *z,
17124	integer ierr, doublereal rv1, doublereal rv2, doublereal rv3,
17125	doublereal rv4, doublereal rv5, doublereal *rv6)
17126	{
17127	/* System generated locals */
17128	integer z_dim1, z_offset, i_1, i_2, i_3;
17129	doublereal d_1, d_2, d_3, d_4;
17130
17131	/* Builtin functions */
17132	double sqrt(doublereal);
17133
17134	/* Local variables */
17135	static doublereal norm;
17136	static integer i, j, k, p, q, r, s;
17137	static doublereal u, v;
17138	static integer group, m1, m2;
17139	static doublereal t1, t2, x0, x1;
17140	static integer ii, jj, ip;
17141	static doublereal uk, xu;
17142	extern doublereal pythag_(doublereal , doublereal ), epslon_(doublereal
17143	*);
17144	static integer isturm, its;
17145	static doublereal eps2, eps3, eps4, tst1, tst2;
17146
17147
17148
17149	/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRISTURM */
17150	/* BY PETERS AND WILKINSON. */
17151	/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). */
17152
17153	/* THIS SUBROUTINE FINDS THOSE EIGENVALUES OF A TRIDIAGONAL */
17154	/* SYMMETRIC MATRIX WHICH LIE IN A SPECIFIED INTERVAL AND THEIR */
17155	/* ASSOCIATED EIGENVECTORS, USING BISECTION AND INVERSE ITERATION. */
17156
17157	/* ON INPUT */
17158
17159	/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */
17160	/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */
17161	/* DIMENSION STATEMENT. */
17162
17163	/* N IS THE ORDER OF THE MATRIX. */
17164
17165	/* EPS1 IS AN ABSOLUTE ERROR TOLERANCE FOR THE COMPUTED */
17166	/* EIGENVALUES. IT SHOULD BE CHOSEN COMMENSURATE WITH */
17167	/* RELATIVE PERTURBATIONS IN THE MATRIX ELEMENTS OF THE */
17168	/* ORDER OF THE RELATIVE MACHINE PRECISION. IF THE */
17169	/* INPUT EPS1 IS NON-POSITIVE, IT IS RESET FOR EACH */
17170	/* SUBMATRIX TO A DEFAULT VALUE, NAMELY, MINUS THE */
17171	/* PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE */
17172	/* 1-NORM OF THE SUBMATRIX. */
17173
17174	/* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */
17175
17176	/* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */
17177	/* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */
17178
17179	/* E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. */
17180	/* E2(1) IS ARBITRARY. */
17181
17182	/* LB AND UB DEFINE THE INTERVAL TO BE SEARCHED FOR EIGENVALUES. */
17183	/* IF LB IS NOT LESS THAN UB, NO EIGENVALUES WILL BE FOUND. */
17184
17185	/* MM SHOULD BE SET TO AN UPPER BOUND FOR THE NUMBER OF */
17186	/* EIGENVALUES IN THE INTERVAL. WARNING. IF MORE THAN */
17187	/* MM EIGENVALUES ARE DETERMINED TO LIE IN THE INTERVAL, */
17188	/* AN ERROR RETURN IS MADE WITH NO VALUES OR VECTORS FOUND. */
17189
17190	/* ON OUTPUT */
17191
17192	/* EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS */
17193	/* (LAST) DEFAULT VALUE. */
17194
17195	/* D AND E ARE UNALTERED. */
17196
17197	/* ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED */
17198	/* AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE */
17199	/* MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES. */
17200	/* E2(1) IS ALSO SET TO ZERO. */
17201
17202	/* M IS THE NUMBER OF EIGENVALUES DETERMINED TO LIE IN (LB,UB). */
17203
17204	/* W CONTAINS THE M EIGENVALUES IN ASCENDING ORDER IF THE MATRIX */
17205	/* DOES NOT SPLIT. IF THE MATRIX SPLITS, THE EIGENVALUES ARE */
17206	/* IN ASCENDING ORDER FOR EACH SUBMATRIX. IF A VECTOR ERROR */
17207	/* EXIT IS MADE, W CONTAINS THOSE VALUES ALREADY FOUND. */
17208
17209	/* Z CONTAINS THE ASSOCIATED SET OF ORTHONORMAL EIGENVECTORS. */
17210	/* IF AN ERROR EXIT IS MADE, Z CONTAINS THOSE VECTORS */
17211	/* ALREADY FOUND. */
17212
17213	/* IERR IS SET TO */
17214	/* ZERO FOR NORMAL RETURN, */
17215	/* 3N+1 IF M EXCEEDS MM. /
17216	/* 4N+R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH /
17217	/* EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS. */
17218
17219	/* RV1, RV2, RV3, RV4, RV5, AND RV6 ARE TEMPORARY STORAGE ARRAYS.
17220	*/
17221
17222	/* THE ALGOL PROCEDURE STURMCNT CONTAINED IN TRISTURM */
17223	/* APPEARS IN TSTURM IN-LINE. */
17224
17225	/* CALLS PYTHAG FOR DSQRT(AA + BB) . */
17226
17227	/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */
17228	/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
17229	*/
17230
17231	/* THIS VERSION DATED AUGUST 1983. */
17232
17233	/* ------------------------------------------------------------------
17234	*/
17235
17236	/* Parameter adjustments */
17237	--rv6;
17238	--rv5;
17239	--rv4;
17240	--rv3;
17241	--rv2;
17242	--rv1;
17243	--e2;
17244	--e;
17245	--d;
17246	z_dim1 = *nm;
17247	z_offset = z_dim1 + 1;
17248	z -= z_offset;
17249	--w;
17250
17251	/* Function Body */
17252	*ierr = 0;
17253	t1 = *lb;
17254	t2 = *ub;
17255	/* .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES .......... */
17256	i_1 = *n;
17257	for (i = 1; i <= i_1; ++i) {
17258	if (i == 1) {
17259	goto L20;
17260	}
17261	tst1 = (d_1 = d[i], abs(d_1)) + (d_2 = d[i - 1], abs(d_2));
17262	tst2 = tst1 + (d_1 = e[i], abs(d_1));
17263	if (tst2 > tst1) {
17264	goto L40;
17265	}
17266	L20:
17267	e2[i] = 0.;
17268	L40:
17269	;
17270	}
17271	/* .......... DETERMINE THE NUMBER OF EIGENVALUES */
17272	/* IN THE INTERVAL .......... */
17273	p = 1;
17274	q = *n;
17275	x1 = *ub;
17276	isturm = 1;
17277	goto L320;
17278	L60:
17279	*m = s;
17280	x1 = *lb;
17281	isturm = 2;
17282	goto L320;
17283	L80:
17284	*m -= s;
17285	if (m > mm) {
17286	goto L980;
17287	}
17288	q = 0;
17289	r = 0;
17290	/* .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING */
17291	/* INTERVAL BY THE GERSCHGORIN BOUNDS .......... */
17292	L100:
17293	if (r == *m) {
17294	goto L1001;
17295	}
17296	p = q + 1;
17297	xu = d[p];
17298	x0 = d[p];
17299	u = 0.;
17300
17301	i_1 = *n;
17302	for (q = p; q <= i_1; ++q) {
17303	x1 = u;
17304	u = 0.;
17305	v = 0.;
17306	if (q == *n) {
17307	goto L110;
17308	}
17309	u = (d_1 = e[q + 1], abs(d_1));
17310	v = e2[q + 1];
17311	L110:
17312	/* Computing MIN */
17313	d_1 = d[q] - (x1 + u);
17314	xu = min(d_1,xu);
17315	/* Computing MAX */
17316	d_1 = d[q] + (x1 + u);
17317	x0 = max(d_1,x0);
17318	if (v == 0.) {
17319	goto L140;
17320	}
17321	/* L120: */
17322	}
17323
17324	L140:
17325	/* Computing MAX */
17326	d_2 = abs(xu), d_3 = abs(x0);
17327	d_1 = max(d_2,d_3);
17328	x1 = epslon_(&d_1);
17329	if (*eps1 <= 0.) {
17330	*eps1 = -x1;
17331	}
17332	if (p != q) {
17333	goto L180;
17334	}
17335	/* .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL .......... */
17336	if (t1 > d[p] \|\| d[p] >= t2) {
17337	goto L940;
17338	}
17339	++r;
17340
17341	i_1 = *n;
17342	for (i = 1; i <= i_1; ++i) {
17343	/* L160: */
17344	z[i + r * z_dim1] = 0.;
17345	}
17346
17347	w[r] = d[p];
17348	z[p + r * z_dim1] = 1.;
17349	goto L940;
17350	L180:
17351	u = (doublereal) (q - p + 1);
17352	x1 = u * x1;
17353	/* Computing MAX */
17354	d_1 = t1, d_2 = xu - x1;
17355	*lb = max(d_1,d_2);
17356	/* Computing MIN */
17357	d_1 = t2, d_2 = x0 + x1;
17358	*ub = min(d_1,d_2);
17359	x1 = *lb;
17360	isturm = 3;
17361	goto L320;
17362	L200:
17363	m1 = s + 1;
17364	x1 = *ub;
17365	isturm = 4;
17366	goto L320;
17367	L220:
17368	m2 = s;
17369	if (m1 > m2) {
17370	goto L940;
17371	}
17372	/* .......... FIND ROOTS BY BISECTION .......... */
17373	x0 = *ub;
17374	isturm = 5;
17375
17376	i_1 = m2;
17377	for (i = m1; i <= i_1; ++i) {
17378	rv5[i] = *ub;
17379	rv4[i] = *lb;
17380	/* L240: */
17381	}
17382	/* .......... LOOP FOR K-TH EIGENVALUE */
17383	/* FOR K=M2 STEP -1 UNTIL M1 DO -- */
17384	/* (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) ..........
17385	*/
17386	k = m2;
17387	L250:
17388	xu = *lb;
17389	/* .......... FOR I=K STEP -1 UNTIL M1 DO -- .......... */
17390	i_1 = k;
17391	for (ii = m1; ii <= i_1; ++ii) {
17392	i = m1 + k - ii;
17393	if (xu >= rv4[i]) {
17394	goto L260;
17395	}
17396	xu = rv4[i];
17397	goto L280;
17398	L260:
17399	;
17400	}
17401
17402	L280:
17403	if (x0 > rv5[k]) {
17404	x0 = rv5[k];
17405	}
17406	/* .......... NEXT BISECTION STEP .......... */
17407	L300:
17408	x1 = (xu + x0) * .5;
17409	if (x0 - xu <= abs(*eps1)) {
17410	goto L420;
17411	}
17412	tst1 = (abs(xu) + abs(x0)) * 2.;
17413	tst2 = tst1 + (x0 - xu);
17414	if (tst2 == tst1) {
17415	goto L420;
17416	}
17417	/* .......... IN-LINE PROCEDURE FOR STURM SEQUENCE .......... */
17418	L320:
17419	s = p - 1;
17420	u = 1.;
17421
17422	i_1 = q;
17423	for (i = p; i <= i_1; ++i) {
17424	if (u != 0.) {
17425	goto L325;
17426	}
17427	v = (d_1 = e[i], abs(d_1)) / epslon_(&c_b141);
17428	if (e2[i] == 0.) {
17429	v = 0.;
17430	}
17431	goto L330;
17432	L325:
17433	v = e2[i] / u;
17434	L330:
17435	u = d[i] - x1 - v;
17436	if (u < 0.) {
17437	++s;
17438	}
17439	/* L340: */
17440	}
17441
17442	switch (isturm) {
17443	case 1: goto L60;
17444	case 2: goto L80;
17445	case 3: goto L200;
17446	case 4: goto L220;
17447	case 5: goto L360;
17448	}
17449	/* .......... REFINE INTERVALS .......... */
17450	L360:
17451	if (s >= k) {
17452	goto L400;
17453	}
17454	xu = x1;
17455	if (s >= m1) {
17456	goto L380;
17457	}
17458	rv4[m1] = x1;
17459	goto L300;
17460	L380:
17461	rv4[s + 1] = x1;
17462	if (rv5[s] > x1) {
17463	rv5[s] = x1;
17464	}
17465	goto L300;
17466	L400:
17467	x0 = x1;
17468	goto L300;
17469	/* .......... K-TH EIGENVALUE FOUND .......... */
17470	L420:
17471	rv5[k] = x1;
17472	--k;
17473	if (k >= m1) {
17474	goto L250;
17475	}
17476	/* .......... FIND VECTORS BY INVERSE ITERATION .......... */
17477	norm = (d_1 = d[p], abs(d_1));
17478	ip = p + 1;
17479
17480	i_1 = q;
17481	for (i = ip; i <= i_1; ++i) {
17482	/* L500: */
17483	/* Computing MAX */
17484	d_3 = norm, d_4 = (d_1 = d[i], abs(d_1)) + (d_2 = e[i], abs(d_2)
17485	);
17486	norm = max(d_3,d_4);
17487	}
17488	/* .......... EPS2 IS THE CRITERION FOR GROUPING, */
17489	/* EPS3 REPLACES ZERO PIVOTS AND EQUAL */
17490	/* ROOTS ARE MODIFIED BY EPS3, */
17491	/* EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW .......... */
17492	eps2 = norm * .001;
17493	eps3 = epslon_(&norm);
17494	uk = (doublereal) (q - p + 1);
17495	eps4 = uk * eps3;
17496	uk = eps4 / sqrt(uk);
17497	group = 0;
17498	s = p;
17499
17500	i_1 = m2;
17501	for (k = m1; k <= i_1; ++k) {
17502	++r;
17503	its = 1;
17504	w[r] = rv5[k];
17505	x1 = rv5[k];
17506	/* .......... LOOK FOR CLOSE OR COINCIDENT ROOTS .......... */
17507	if (k == m1) {
17508	goto L520;
17509	}
17510	if (x1 - x0 >= eps2) {
17511	group = -1;
17512	}
17513	++group;
17514	if (x1 <= x0) {
17515	x1 = x0 + eps3;
17516	}
17517	/* .......... ELIMINATION WITH INTERCHANGES AND */
17518	/* INITIALIZATION OF VECTOR .......... */
17519	L520:
17520	v = 0.;
17521
17522	i_2 = q;
17523	for (i = p; i <= i_2; ++i) {
17524	rv6[i] = uk;
17525	if (i == p) {
17526	goto L560;
17527	}
17528	if ((d_1 = e[i], abs(d_1)) < abs(u)) {
17529	goto L540;
17530	}
17531	xu = u / e[i];
17532	rv4[i] = xu;
17533	rv1[i - 1] = e[i];
17534	rv2[i - 1] = d[i] - x1;
17535	rv3[i - 1] = 0.;
17536	if (i != q) {
17537	rv3[i - 1] = e[i + 1];
17538	}
17539	u = v - xu * rv2[i - 1];
17540	v = -xu * rv3[i - 1];
17541	goto L580;
17542	L540:
17543	xu = e[i] / u;
17544	rv4[i] = xu;
17545	rv1[i - 1] = u;
17546	rv2[i - 1] = v;
17547	rv3[i - 1] = 0.;
17548	L560:
17549	u = d[i] - x1 - xu * v;
17550	if (i != q) {
17551	v = e[i + 1];
17552	}
17553	L580:
17554	;
17555	}
17556
17557	if (u == 0.) {
17558	u = eps3;
17559	}
17560	rv1[q] = u;
17561	rv2[q] = 0.;
17562	rv3[q] = 0.;
17563	/* .......... BACK SUBSTITUTION */
17564	/* FOR I=Q STEP -1 UNTIL P DO -- .......... */
17565	L600:
17566	i_2 = q;
17567	for (ii = p; ii <= i_2; ++ii) {
17568	i = p + q - ii;
17569	rv6[i] = (rv6[i] - u * rv2[i] - v * rv3[i]) / rv1[i];
17570	v = u;
17571	u = rv6[i];
17572	/* L620: */
17573	}
17574	/* .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS */
17575	/* MEMBERS OF GROUP .......... */
17576	if (group == 0) {
17577	goto L700;
17578	}
17579
17580	i_2 = group;
17581	for (jj = 1; jj <= i_2; ++jj) {
17582	j = r - group - 1 + jj;
17583	xu = 0.;
17584
17585	i_3 = q;
17586	for (i = p; i <= i_3; ++i) {
17587	/* L640: */
17588	xu += rv6[i] * z[i + j * z_dim1];
17589	}
17590
17591	i_3 = q;
17592	for (i = p; i <= i_3; ++i) {
17593	/* L660: */
17594	rv6[i] -= xu * z[i + j * z_dim1];
17595	}
17596
17597	/* L680: */
17598	}
17599
17600	L700:
17601	norm = 0.;
17602
17603	i_2 = q;
17604	for (i = p; i <= i_2; ++i) {
17605	/* L720: */
17606	norm += (d_1 = rv6[i], abs(d_1));
17607	}
17608
17609	if (norm >= 1.) {
17610	goto L840;
17611	}
17612	/* .......... FORWARD SUBSTITUTION .......... */
17613	if (its == 5) {
17614	goto L960;
17615	}
17616	if (norm != 0.) {
17617	goto L740;
17618	}
17619	rv6[s] = eps4;
17620	++s;
17621	if (s > q) {
17622	s = p;
17623	}
17624	goto L780;
17625	L740:
17626	xu = eps4 / norm;
17627
17628	i_2 = q;
17629	for (i = p; i <= i_2; ++i) {
17630	/* L760: */
17631	rv6[i] *= xu;
17632	}
17633	/* .......... ELIMINATION OPERATIONS ON NEXT VECTOR */
17634	/* ITERATE .......... */
17635	L780:
17636	i_2 = q;
17637	for (i = ip; i <= i_2; ++i) {
17638	u = rv6[i];
17639	/* .......... IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE */
17640	/* WAS PERFORMED EARLIER IN THE */
17641	/* TRIANGULARIZATION PROCESS .......... */
17642	if (rv1[i - 1] != e[i]) {
17643	goto L800;
17644	}
17645	u = rv6[i - 1];
17646	rv6[i - 1] = rv6[i];
17647	L800:
17648	rv6[i] = u - rv4[i] * rv6[i - 1];
17649	/* L820: */
17650	}
17651
17652	++its;
17653	goto L600;
17654	/* .......... NORMALIZE SO THAT SUM OF SQUARES IS */
17655	/* 1 AND EXPAND TO FULL ORDER .......... */
17656	L840:
17657	u = 0.;
17658
17659	i_2 = q;
17660	for (i = p; i <= i_2; ++i) {
17661	/* L860: */
17662	u = pythag_(&u, &rv6[i]);
17663	}
17664
17665	xu = 1. / u;
17666
17667	i_2 = *n;
17668	for (i = 1; i <= i_2; ++i) {
17669	/* L880: */
17670	z[i + r * z_dim1] = 0.;
17671	}
17672
17673	i_2 = q;
17674	for (i = p; i <= i_2; ++i) {
17675	/* L900: */
17676	z[i + r * z_dim1] = rv6[i] * xu;
17677	}
17678
17679	x0 = x1;
17680	/* L920: */
17681	}
17682
17683	L940:
17684	if (q < *n) {
17685	goto L100;
17686	}
17687	goto L1001;
17688	/* .......... SET ERROR -- NON-CONVERGED EIGENVECTOR .......... */
17689	L960:
17690	ierr = (n << 2) + r;
17691	goto L1001;
17692	/* .......... SET ERROR -- UNDERESTIMATE OF NUMBER OF */
17693	/* EIGENVALUES IN INTERVAL .......... */
17694	L980:
17695	ierr = n * 3 + 1;
17696	L1001:
17697	*lb = t1;
17698	*ub = t2;
17699	return 0;
17700	} /* tsturm_ */
17701
17702	#ifdef __cplusplus
17703	}
17704	#endif

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

Download in other formats: